Mercurial > octave-nkf
changeset 2362:1865e40602a3
[project @ 1996-10-11 21:49:59 by jwe]
| author | jwe |
|---|---|
| date | Fri, 11 Oct 1996 21:50:01 +0000 |
| parents | 8fd593c4b714 |
| children | 74f9c8283d31 |
| files | src/t-builtins.cc src/t-builtins.h src/tc-assign.cc src/tc-extras.cc src/tc-index.cc src/tc-inlines.h src/tc-rep-ass.cc src/tc-rep-idx.cc src/tc-rep.h |
| diffstat | 9 files changed, 0 insertions(+), 11239 deletions(-) [+] |
line wrap: on
line diff
--- a/src/t-builtins.cc Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1309 +0,0 @@ -// t-builtins.cc -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -/* - -The function builtin_cd was adapted from a similar function from GNU -Bash, the Bourne Again SHell, copyright (C) 1987, 1989, 1991 Free -Software Foundation, Inc. - -The function list_in_columns was adapted from a similar function from -GNU ls, print_many_per_line, copyright (C) 1985, 1988, 1990, 1991 Free -Software Foundation, Inc. - -The function glob_pattern_p was taken from the file glob.c distributed -with GNU Bash, the Bourne Again SHell, copyright (C) 1985, 1988, 1989 -Free Software Foundation, Inc. - -*/ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif - -#include <sys/types.h> -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif -#include <iostream.h> -#include <strstream.h> -#include <fstream.h> -#include <stdio.h> -#include <fcntl.h> -#include <sys/file.h> -#include <sys/stat.h> -#include <time.h> -#include <errno.h> -#include <signal.h> - -#include "procstream.h" - -#include "variables.h" -#include "symtab.h" -#include "error.h" -#include "input.h" -#include "pager.h" -#include "utils.h" -#include "sighandlers.h" -#include "builtins.h" -#include "t-builtins.h" -#include "octave.h" -#include "octave-hist.h" -#include "user-prefs.h" -#include "pr-output.h" -#include "defaults.h" -#include "tree.h" -#include "help.h" - -extern "C" -{ -#include "fnmatch.h" -} - -// May need replacement for this on some machines. -extern "C" -{ - extern char *strerror (int); - char *tilde_expand (char *s); /* From readline's tilde.c */ -} - -extern "C" -{ -#include "info/info.h" -#include "info/dribble.h" -#include "info/terminal.h" - - extern int initialize_info_session (); - extern int index_entry_exists (); - extern int do_info_index_search (); - extern void finish_info_session (); - extern char *replace_in_documentation (); -} - -// Is this a parametric plot? Makes a difference for 3D plotting. -extern int parametric_plot; - -// Should the graph window be cleared before plotting the next line? -extern int clear_before_plotting; - -/* - * Format a list in neat columns. Mostly stolen from GNU ls. This - * should maybe be in utils.cc. - */ -static ostrstream& -list_in_columns (ostrstream& os, char **list) -{ -// Compute the maximum name length. - - int max_name_length = 0; - int total_names = 0; - for (char **names = list; *names != (char *) NULL; names++) - { - total_names++; - int name_length = strlen (*names); - if (name_length > max_name_length) - max_name_length = name_length; - } - -// Allow at least two spaces between names. - - max_name_length += 2; - -// Calculate the maximum number of columns that will fit. - - int line_length = terminal_columns (); - int cols = line_length / max_name_length; - if (cols == 0) - cols = 1; - -// Calculate the number of rows that will be in each column except -// possibly for a short column on the right. - - int rows = total_names / cols + (total_names % cols != 0); - -// Recalculate columns based on rows. - - cols = total_names / rows + (total_names % rows != 0); - - names = list; - int count; - for (int row = 0; row < rows; row++) - { - count = row; - int pos = 0; - -// Print the next row. - - while (1) - { - os << *(names + count); - int name_length = strlen (*(names + count)); - - count += rows; - if (count >= total_names) - break; - - int spaces_to_pad = max_name_length - name_length; - for (int i = 0; i < spaces_to_pad; i++) - os << " "; - pos += max_name_length; - } - os << "\n"; - } - - return os; -} - -Octave_object -builtin_casesen (int argc, char **argv, int nargout) -{ - Octave_object retval; - - if (argc == 1 || (argc > 1 && strcmp (argv[1], "off") == 0)) - warning ("casesen: sorry, Octave is always case sensitive"); - else if (argc > 1 && strcmp (argv[1], "on") == 0) - ; // ok. - else - print_usage ("casesen"); - - return retval; -} - -/* - * Change current working directory. - */ -Octave_object -builtin_cd (int argc, char **argv, int nargout) -{ - Octave_object retval; - - if (argc > 1) - { - static char *dirname = (char *) NULL; - - if (dirname) - free (dirname); - - dirname = tilde_expand (argv[1]); - - if (dirname != (char *) NULL && !change_to_directory (dirname)) - { - error ("%s: %s", dirname, strerror (errno)); - return retval; - } - } - else - { - if (!home_directory) - return retval; - - if (!change_to_directory (home_directory)) - { - error ("%s: %s", home_directory, strerror (errno)); - return retval; - } - } - - - char *directory = get_working_directory ("cd"); - tree_constant *dir = new tree_constant (directory); - bind_builtin_variable ("PWD", dir, 1); - - return retval; -} - -#if 0 -static int -in_list (char *s, char **list) -{ - while (*list != (char *) NULL) - { - if (strcmp (s, *list) == 0) - return 1; - list++; - } - - return 0; -} -#endif - -/* - * Wipe out user-defined variables and functions given a list of - * globbing patterns. - */ -Octave_object -builtin_clear (int argc, char **argv, int nargout) -{ - Octave_object retval; - -// Always clear the local table, but don't clear currently compiled -// functions unless we are at the top level. (Allowing that to happen -// inside functions would result in pretty odd behavior...) - - int clear_user_functions = (curr_sym_tab == top_level_sym_tab); - - if (argc == 1) - { - curr_sym_tab->clear (); - global_sym_tab->clear (clear_user_functions); - } - else - { - int lcount; - char **lvars = curr_sym_tab->list (lcount, 0, - symbol_def::USER_VARIABLE, - SYMTAB_LOCAL_SCOPE); - int gcount; - char **gvars = curr_sym_tab->list (gcount, 0, - symbol_def::USER_VARIABLE, - SYMTAB_GLOBAL_SCOPE); - int fcount; - char **fcns = curr_sym_tab->list (fcount, 0, - symbol_def::USER_FUNCTION, - SYMTAB_ALL_SCOPES); - - while (--argc > 0) - { - argv++; - if (*argv != (char *) NULL) - { - int i; - for (i = 0; i < lcount; i++) - { - if (fnmatch (*argv, lvars[i], __FNM_FLAGS) == 0) - curr_sym_tab->clear (lvars[i]); - } - - int count; - for (i = 0; i < gcount; i++) - { - if (fnmatch (*argv, gvars[i], __FNM_FLAGS) == 0) - { - count = curr_sym_tab->clear (gvars[i]); - if (count > 0) - global_sym_tab->clear (gvars[i], clear_user_functions); - } - } - - for (i = 0; i < fcount; i++) - { - if (fnmatch (*argv, fcns[i], __FNM_FLAGS) == 0) - { - count = curr_sym_tab->clear (fcns[i]); - if (count > 0) - global_sym_tab->clear (fcns[i], clear_user_functions); - } - } - } - } - - delete [] lvars; - delete [] gvars; - delete [] fcns; - - } - return retval; -} - -/* - * Associate a cryptic message with a variable name. - */ -Octave_object -builtin_document (int argc, char **argv, int nargout) -{ - Octave_object retval; - if (argc == 3) - document_symbol (argv[1], argv[2]); - else - print_usage ("document"); - return retval; -} - -/* - * Edit commands with your favorite editor. - */ -Octave_object -builtin_edit_history (int argc, char **argv, int nargout) -{ - Octave_object retval; - do_edit_history (argc, argv); - return retval; -} - -/* - * Set output format state. - */ -Octave_object -builtin_format (int argc, char **argv, int nargout) -{ - Octave_object retval; - set_format_style (argc, argv); - return retval; -} - -static void -help_syms_list (ostrstream& output_buf, help_list *list, - const char *desc) -{ - int count = 0; - char **symbols = names (list, count); - output_buf << "\n*** " << desc << ":\n\n"; - if (symbols != (char **) NULL && count > 0) - list_in_columns (output_buf, symbols); - delete [] symbols; -} - -static void -simple_help (void) -{ - ostrstream output_buf; - - help_syms_list (output_buf, operator_help (), "operators"); - - help_syms_list (output_buf, keyword_help (), "reserved words"); - - help_syms_list (output_buf, builtin_text_functions_help (), - "text functions (these names are also reserved)"); - - help_syms_list (output_buf, builtin_mapper_functions_help (), - "mapper functions"); - - help_syms_list (output_buf, builtin_general_functions_help (), - "general functions"); - - help_syms_list (output_buf, builtin_variables_help (), - "builtin variables"); - -// Also need to list variables and currently compiled functions from -// the symbol table, if there are any. - -// Also need to search octave_path for script files. - - char **path = pathstring_to_vector (user_pref.loadpath); - - char **ptr = path; - if (ptr != (char **) NULL) - { - while (*ptr != (char *) NULL) - { - int count; - char **names = get_fcn_file_names (count, *ptr, 0); - output_buf << "\n*** function files in " - << make_absolute (*ptr, the_current_working_directory) - << ":\n\n"; - if (names != (char **) NULL && count > 0) - list_in_columns (output_buf, names); - delete [] names; - ptr++; - } - } - - additional_help_message (output_buf); - output_buf << ends; - maybe_page_output (output_buf); -} - -static int -try_info (const char *string, int force = 0) -{ - int status = 0; - - char *directory_name = strsave (user_pref.info_file); - char *temp = filename_non_directory (directory_name); - - if (temp != directory_name) - { - *temp = 0; - info_add_path (directory_name, INFOPATH_PREPEND); - } - - delete [] directory_name; - - NODE *initial_node = info_get_node (user_pref.info_file, (char *)NULL); - - if (! initial_node) - { - warning ("can't find info file!\n"); - status = -1; - } - else - { - status = initialize_info_session (initial_node, 0); - - if (status == 0 && (force || index_entry_exists (windows, string))) - { - terminal_clear_screen (); - - terminal_prep_terminal (); - - display_update_display (windows); - - info_last_executed_command = (VFunction *)NULL; - - if (! force) - do_info_index_search (windows, 0, string); - - char *format = replace_in_documentation - ("Type \"\\[quit]\" to quit, \"\\[get-help-window]\" for help."); - - window_message_in_echo_area (format); - - info_read_and_dispatch (); - - terminal_goto_xy (0, screenheight - 1); - - terminal_clear_to_eol (); - - terminal_unprep_terminal (); - - status = 1; - } - - finish_info_session (initial_node, 0); - } - - return status; -} - -/* - * Print cryptic yet witty messages. - */ -Octave_object -builtin_help (int argc, char **argv, int nargout) -{ - Octave_object retval; - - if (argc == 1) - { - simple_help (); - } - else - { - if (argv[1] != (char *) NULL && strcmp (argv[1], "-i") == 0) - { - argc--; - argv++; - - if (argc == 1) - { - volatile sig_handler *old_sigint_handler; - old_sigint_handler = signal (SIGINT, SIG_IGN); - - try_info ((char *) NULL, 1); - - signal (SIGINT, old_sigint_handler); - } - else - { - while (--argc > 0) - { - argv++; - - if (*argv == (char *) NULL || **argv == '\0') - continue; - - volatile sig_handler *old_sigint_handler; - old_sigint_handler = signal (SIGINT, SIG_IGN); - - if (! try_info (*argv)) - { - message ("help", - "sorry, `%s' is not indexed in the manual", - *argv); - sleep (2); - } - - signal (SIGINT, old_sigint_handler); - } - } - } - else - { - ostrstream output_buf; - - char *fcn_file_name = (char *) NULL; - symbol_record *sym_rec; - help_list *op_help_list = operator_help (); - help_list *kw_help_list = keyword_help (); - - while (--argc > 0) - { - argv++; - - if (*argv == (char *) NULL || **argv == '\0') - continue; - - if (help_from_list (output_buf, op_help_list, *argv, 0)) - continue; - - if (help_from_list (output_buf, kw_help_list, *argv, 0)) - continue; - - sym_rec = curr_sym_tab->lookup (*argv, 0, 0); - if (sym_rec != (symbol_record *) NULL) - { - char *h = sym_rec->help (); - if (h != (char *) NULL && *h != '\0') - { - output_buf << "\n*** " << *argv << ":\n\n" - << h << "\n"; - continue; - } - } - - sym_rec = global_sym_tab->lookup (*argv, 0, 0); - if (sym_rec != (symbol_record *) NULL - && ! symbol_out_of_date (sym_rec)) - { - char *h = sym_rec->help (); - if (h != (char *) NULL && *h != '\0') - { - output_buf << "\n*** " << *argv << ":\n\n" - << h << "\n"; - continue; - } - } - -// Try harder to find function files that might not be defined yet, or -// that appear to be out of date. Don\'t execute commands from the -// file if it turns out to be a script file. - - fcn_file_name = fcn_file_in_path (*argv); - if (fcn_file_name != (char *) NULL) - { - sym_rec = global_sym_tab->lookup (*argv, 1, 0); - if (sym_rec != (symbol_record *) NULL) - { - tree_identifier tmp (sym_rec); - tmp.parse_fcn_file (0); - char *h = sym_rec->help (); - if (h != (char *) NULL && *h != '\0') - { - output_buf << "\n*** " << *argv << ":\n\n" - << h << "\n"; - continue; - } - } - } - delete [] fcn_file_name; - - output_buf << "\nhelp: sorry, `" << *argv - << "' is not documented\n"; - } - - additional_help_message (output_buf); - output_buf << ends; - maybe_page_output (output_buf); - } - } - - return retval; -} - -/* - * Display, save, or load history. - */ -Octave_object -builtin_history (int argc, char **argv, int nargout) -{ - Octave_object retval; - - do_history (argc, argv); - - return retval; -} - -/* - * Change state flag that determines whether lines are added to plots - * or drawn on new plots. - */ -Octave_object -builtin_hold (int argc, char **argv, int nargout) -{ - Octave_object retval; - - switch (argc) - { - case 1: - clear_before_plotting = ! clear_before_plotting; - break; - case 2: - if (strcasecmp (argv[1], "on") == 0) - clear_before_plotting = 0; - else if (strcasecmp (argv[1], "off") == 0) - clear_before_plotting = 1; - else - print_usage ("hold"); - break; - default: - print_usage ("hold"); - break; - } - - return retval; -} - -static int -load_variable (char *nm, int force, istream& is) -{ -// Is there already a symbol by this name? If so, what is it? - - symbol_record *lsr = curr_sym_tab->lookup (nm, 0, 0); - - int is_undefined = 1; - int is_variable = 0; - int is_function = 0; - int is_global = 0; - - if (lsr != (symbol_record *) NULL) - { - is_undefined = ! lsr->is_defined (); - is_variable = lsr->is_variable (); - is_function = lsr->is_function (); - is_global = lsr->is_linked_to_global (); - } - -// Try to read data for this name. - - tree_constant tc; - int global = tc.load (is); - - if (tc.const_type () == tree_constant_rep::unknown_constant) - { - error ("load: unable to load variable `%s'", nm); - return 0; - } - - symbol_record *sr = (symbol_record *) NULL; - - if (global) - { - if (is_global || is_undefined) - { - if (force || is_undefined) - { - lsr = curr_sym_tab->lookup (nm, 1, 0); - link_to_global_variable (lsr); - sr = lsr; - } - else - { - warning ("load: global variable name `%s' exists.", nm); - warning ("use `load -force' to overwrite"); - } - } - else if (is_function) - { - if (force) - { - lsr = curr_sym_tab->lookup (nm, 1, 0); - link_to_global_variable (lsr); - sr = lsr; - } - else - { - warning ("load: `%s' is currently a function in this scope", nm); - warning ("`load -force' will load variable and hide function"); - } - } - else if (is_variable) - { - if (force) - { - lsr = curr_sym_tab->lookup (nm, 1, 0); - link_to_global_variable (lsr); - sr = lsr; - } - else - { - warning ("load: local variable name `%s' exists.", nm); - warning ("use `load -force' to overwrite"); - } - } - else - panic_impossible (); - } - else - { - if (is_global) - { - if (force || is_undefined) - { - lsr = curr_sym_tab->lookup (nm, 1, 0); - link_to_global_variable (lsr); - sr = lsr; - } - else - { - warning ("load: global variable name `%s' exists.", nm); - warning ("use `load -force' to overwrite"); - } - } - else if (is_function) - { - if (force) - { - lsr = curr_sym_tab->lookup (nm, 1, 0); - link_to_global_variable (lsr); - sr = lsr; - } - else - { - warning ("load: `%s' is currently a function in this scope", nm); - warning ("`load -force' will load variable and hide function"); - } - } - else if (is_variable || is_undefined) - { - if (force || is_undefined) - { - lsr = curr_sym_tab->lookup (nm, 1, 0); - sr = lsr; - } - else - { - warning ("load: local variable name `%s' exists.", nm); - warning ("use `load -force' to overwrite"); - } - } - else - panic_impossible (); - } - - if (sr != (symbol_record *) NULL) - { - tree_constant *tmp_tc = new tree_constant (tc); - sr->define (tmp_tc); - return 1; - } - else - error ("load: unable to load variable `%s'", nm); - - return 0; -} - -/* - * Read variables from an input stream. - * - * BUGS: - * - * -- This function is not terribly robust. - */ -Octave_object -builtin_load (int argc, char **argv, int nargout) -{ - Octave_object retval; - - argc--; - argv++; - - int force = 0; - if (argc > 0 && strcmp (*argv, "-force") == 0) - { - force++; - argc--; - argv++; - } - - if (argc < 1) - { - error ("load: you must specify a single file to read"); - return retval; - } - - static istream stream; - static ifstream file; - if (strcmp (*argv, "-") == 0) - { - stream = cin; - } - else - { - char *fname = tilde_expand (*argv); - file.open (fname); - if (! file) - { - error ("load: couldn't open input file `%s'", *argv); - return retval; - } - stream = file; - } - - int count = 0; - char *nm = (char *) NULL; - for (;;) - { -// Read name for this entry or break on EOF. - delete [] nm; - nm = extract_keyword (stream, "name"); - if (nm == (char *) NULL) - { - if (count == 0) - { - error ("load: no name keywords found in file `%s'", *argv); - error ("Are you sure this is an octave data file?"); - } - break; - } - else - count++; - - if (*nm == '\0') - continue; - - if (! valid_identifier (nm)) - { - warning ("load: skipping bogus identifier `%s'"); - continue; - } - - load_variable (nm, force, stream); - - if (error_state) - { - error ("reading file %s", *argv); - break; - } - } - - if (file); - file.close (); - - return retval; -} - -/* - * Get a directory listing. - */ -Octave_object -builtin_ls (int argc, char **argv, int nargout) -{ - Octave_object retval; - - ostrstream ls_buf; - - ls_buf << "ls -C "; - for (int i = 1; i < argc; i++) - ls_buf << tilde_expand (argv[i]) << " "; - - ls_buf << ends; - - char *ls_command = ls_buf.str (); - - iprocstream cmd (ls_command); - - char ch; - ostrstream output_buf; - while (cmd.get (ch)) - output_buf.put (ch); - - output_buf << ends; - - maybe_page_output (output_buf); - - delete [] ls_command; - - return retval; -} - -/* - * Run previous commands from the history list. - */ -Octave_object -builtin_run_history (int argc, char **argv, int nargout) -{ - Octave_object retval; - do_run_history (argc, argv); - return retval; -} - -/* - * Return nonzero if PATTERN has any special globbing chars in it. - */ -static int -glob_pattern_p (char *pattern) -{ - char *p = pattern; - char c; - int open = 0; - - while ((c = *p++) != '\0') - { - switch (c) - { - case '?': - case '*': - return 1; - - case '[': // Only accept an open brace if there is a close - open++; // brace to match it. Bracket expressions must be - continue; // complete, according to Posix.2 - - case ']': - if (open) - return 1; - continue; - - case '\\': - if (*p++ == '\0') - return 0; - - default: - continue; - } - } - - return 0; -} - -/* - * Write variables to an output stream. - */ -Octave_object -builtin_save (int argc, char **argv, int nargout) -{ - Octave_object retval; - - if (argc < 2) - { - print_usage ("save"); - return retval; - } - - argc--; - argv++; - - static ostream stream; - static ofstream file; - if (strcmp (*argv, "-") == 0) - { -// XXX FIXME XXX -- should things intended for the screen end up in a -// tree_constant (string)? - stream = cout; - } - else if (argc == 1 && glob_pattern_p (*argv)) // Guard against things - { // like `save a*', - print_usage ("save"); // which are probably - return retval; // mistakes... - } - else - { - char *fname = tilde_expand (*argv); - file.open (fname); - if (! file) - { - error ("save: couldn't open output file `%s'", *argv); - return retval; - } - stream = file; - - } - - int prec = user_pref.save_precision; - - if (argc == 1) - { - int count; - char **vars = curr_sym_tab->list (count, 0, - symbol_def::USER_VARIABLE, - SYMTAB_ALL_SCOPES); - - for (int i = 0; i < count; i++) - curr_sym_tab->save (stream, vars[i], - is_globally_visible (vars[i]), prec); - - delete [] vars; - } - else - { - while (--argc > 0) - { - argv++; - - int count; - char **lvars = curr_sym_tab->list (count, 0, - symbol_def::USER_VARIABLE); - - int saved_or_error = 0; - int i; - for (i = 0; i < count; i++) - { - if (fnmatch (*argv, lvars[i], __FNM_FLAGS) == 0 - && curr_sym_tab->save (stream, lvars[i], - is_globally_visible (lvars[i]), - prec) != 0) - saved_or_error++; - } - - char **bvars = global_sym_tab->list (count, 0, - symbol_def::BUILTIN_VARIABLE); - - for (i = 0; i < count; i++) - { - if (fnmatch (*argv, bvars[i], __FNM_FLAGS) == 0 - && global_sym_tab->save (stream, bvars[i], 0, prec) != 0) - saved_or_error++; - } - - delete [] lvars; - delete [] bvars; - - if (! saved_or_error) - warning ("save: no such variable `%s'", *argv); - } - } - - if (file); - file.close (); - - return retval; -} - -/* - * Set plotting options. - */ -Octave_object -builtin_set (int argc, char **argv, int nargout) -{ - Octave_object retval; - - ostrstream plot_buf; - - if (argc > 1) - { - if (almost_match ("parametric", argv[1], 3)) - parametric_plot = 1; - else if (almost_match ("noparametric", argv[1], 5)) - parametric_plot = 0; - } - - for (int i = 0; i < argc; i++) - plot_buf << argv[i] << " "; - - plot_buf << "\n" << ends; - - char *plot_command = plot_buf.str (); - send_to_plot_stream (plot_command); - - delete [] plot_command; - - return retval; -} - -/* - * Set plotting options. - */ -Octave_object -builtin_show (int argc, char **argv, int nargout) -{ - Octave_object retval; - - ostrstream plot_buf; - - for (int i = 0; i < argc; i++) - plot_buf << argv[i] << " "; - - plot_buf << "\n" << ends; - - char *plot_command = plot_buf.str (); - send_to_plot_stream (plot_command); - - delete [] plot_command; - - return retval; -} - -/* - * List variable names. - */ -static void -print_symbol_info_line (ostrstream& output_buf, const symbol_record_info& s) -{ - output_buf << (s.is_read_only () ? " -" : " w"); - output_buf << (s.is_eternal () ? "- " : "d "); -#if 0 - output_buf << (s.hides_fcn () ? "f" : (s.hides_builtin () ? "F" : "-")); -#endif - output_buf.form (" %-16s", s.type_as_string ()); - if (s.is_function ()) - output_buf << " - -"; - else - { - output_buf.form ("%7d", s.rows ()); - output_buf.form ("%7d", s.columns ()); - } - output_buf << " " << s.name () << "\n"; -} - -static void -print_long_listing (ostrstream& output_buf, symbol_record_info *s) -{ - if (s == (symbol_record_info *) NULL) - return; - - symbol_record_info *ptr = s; - while (ptr->is_defined ()) - { - print_symbol_info_line (output_buf, *ptr); - ptr++; - } -} - -static int -maybe_list (const char *header, ostrstream& output_buf, - int show_verbose, symbol_table *sym_tab, unsigned type, - unsigned scope) -{ - int count; - int status = 0; - if (show_verbose) - { - symbol_record_info *symbols; - symbols = sym_tab->long_list (count, 1, type, scope); - if (symbols != (symbol_record_info *) NULL && count > 0) - { - output_buf << "\n" << header << "\n\n" - << "prot type rows cols name\n" - << "==== ==== ==== ==== ====\n"; - - print_long_listing (output_buf, symbols); - status = 1; - } - delete [] symbols; - } - else - { - char **symbols = sym_tab->list (count, 1, type, scope); - if (symbols != (char **) NULL && count > 0) - { - output_buf << "\n" << header << "\n\n"; - list_in_columns (output_buf, symbols); - status = 1; - } - delete [] symbols; - } - return status; -} - -Octave_object -builtin_who (int argc, char **argv, int nargout) -{ - Octave_object retval; - - int show_builtins = 0; - int show_functions = (curr_sym_tab == top_level_sym_tab); - int show_variables = 1; - int show_verbose = 0; - - if (argc > 1) - { - show_functions = 0; - show_variables = 0; - } - - for (int i = 1; i < argc; i++) - { - argv++; - if (strcmp (*argv, "-all") == 0 || strcmp (*argv, "-a") == 0) - { - show_builtins++; - show_functions++; - show_variables++; - } - else if (strcmp (*argv, "-builtins") == 0 - || strcmp (*argv, "-b") == 0) - show_builtins++; - else if (strcmp (*argv, "-functions") == 0 - || strcmp (*argv, "-f") == 0) - show_functions++; - else if (strcmp (*argv, "-long") == 0 - || strcmp (*argv, "-l") == 0) - show_verbose++; - else if (strcmp (*argv, "-variables") == 0 - || strcmp (*argv, "-v") == 0) - show_variables++; - else - warning ("who: unrecognized option `%s'", *argv); - } - -// If the user specified -l and nothing else, show variables. If -// evaluating this at the top level, also show functions. - - if (show_verbose && ! (show_builtins || show_functions || show_variables)) - { - show_functions = (curr_sym_tab == top_level_sym_tab); - show_variables = 1; - } - - ostrstream output_buf; - int pad_after = 0; - - if (show_builtins) - { - pad_after += maybe_list ("*** built-in variables:", - output_buf, show_verbose, global_sym_tab, - symbol_def::BUILTIN_VARIABLE, - SYMTAB_ALL_SCOPES); - - pad_after += maybe_list ("*** built-in functions:", - output_buf, show_verbose, global_sym_tab, - symbol_def::BUILTIN_FUNCTION, - SYMTAB_ALL_SCOPES); - } - - if (show_functions) - { - pad_after += maybe_list ("*** currently compiled functions:", - output_buf, show_verbose, global_sym_tab, - symbol_def::USER_FUNCTION, - SYMTAB_ALL_SCOPES); - } - - if (show_variables) - { - pad_after += maybe_list ("*** local user variables:", - output_buf, show_verbose, curr_sym_tab, - symbol_def::USER_VARIABLE, - SYMTAB_LOCAL_SCOPE); - - pad_after += maybe_list ("*** globally visible user variables:", - output_buf, show_verbose, curr_sym_tab, - symbol_def::USER_VARIABLE, - SYMTAB_GLOBAL_SCOPE); - } - - if (pad_after) - output_buf << "\n"; - - output_buf << ends; - maybe_page_output (output_buf); - - return retval; -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/t-builtins.h Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -// builtin text function support. -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -#if !defined (octave_t_builtins_h) -#define octave_t_builtins_h 1 - -#include "tree-const.h" - -struct builtin_text_functions -{ - char *name; - int nargin_max; - Text_fcn text_fcn; - char *help_string; -}; - -extern Octave_object builtin_casesen (int argc, char **argv, int nargout); -extern Octave_object builtin_cd (int argc, char **argv, int nargout); -extern Octave_object builtin_clear (int argc, char **argv, int nargout); -extern Octave_object builtin_document (int argc, char **argv, int nargout); -extern Octave_object builtin_edit_history (int argc, char **argv, - int nargout); -extern Octave_object builtin_format (int argc, char **argv, int nargout); -extern Octave_object builtin_help (int argc, char **argv, int nargout); -extern Octave_object builtin_history (int argc, char **argv, int nargout); -extern Octave_object builtin_hold (int argc, char **argv, int nargout); -extern Octave_object builtin_load (int argc, char **argv, int nargout); -extern Octave_object builtin_ls (int argc, char **argv, int nargout); -extern Octave_object builtin_run_history (int argc, char **argv, int nargout); -extern Octave_object builtin_save (int argc, char **argv, int nargout); -extern Octave_object builtin_set (int argc, char **argv, int nargout); -extern Octave_object builtin_show (int argc, char **argv, int nargout); -extern Octave_object builtin_who (int argc, char **argv, int nargout); - -#endif - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/tc-assign.cc Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2361 +0,0 @@ -// tc-assign.cc -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif - -#include "idx-vector.h" -#include "user-prefs.h" -#include "tree-const.h" -#include "utils.h" -#include "gripes.h" -#include "error.h" - -#include "tc-inlines.cc" - -// Top-level tree-constant function that handles assignments. Only -// decide if the left-hand side is currently a scalar or a matrix and -// hand off to other functions to do the real work. - -void -tree_constant_rep::assign (tree_constant& rhs, tree_constant *args, int nargs) -{ - tree_constant rhs_tmp = rhs.make_numeric (); - -// This is easier than actually handling assignments to strings. -// An assignment to a range will normally require a conversion to a -// vector since it will normally destroy the equally-spaced property -// of the range elements. - - if (type_tag == string_constant || type_tag == range_constant) - force_numeric (); - - switch (type_tag) - { - case complex_scalar_constant: - case scalar_constant: - case unknown_constant: - do_scalar_assignment (rhs_tmp, args, nargs); - break; - case complex_matrix_constant: - case matrix_constant: - do_matrix_assignment (rhs_tmp, args, nargs); - break; - case string_constant: - ::error ("invalid assignment to string type"); - break; - case range_constant: - case magic_colon: - default: - panic_impossible (); - break; - } -} - -// Assignments to scalars. If resize_on_range_error is true, -// this can convert the left-hand size to a matrix. - -void -tree_constant_rep::do_scalar_assignment (tree_constant& rhs, - tree_constant *args, int nargs) -{ - assert (type_tag == unknown_constant - || type_tag == scalar_constant - || type_tag == complex_scalar_constant); - - if ((rhs.is_scalar_type () || rhs.is_zero_by_zero) - && valid_scalar_indices (args, nargs)) - { - if (rhs.is_zero_by_zero ()) - { - if (type_tag == complex_scalar_constant) - delete complex_scalar; - - matrix = new Matrix (0, 0); - type_tag = matrix_constant; - } - else if (type_tag == unknown_constant || type_tag == scalar_constant) - { - if (rhs.const_type () == scalar_constant) - { - scalar = rhs.double_value (); - type_tag = scalar_constant; - } - else if (rhs.const_type () == complex_scalar_constant) - { - complex_scalar = new Complex (rhs.complex_value ()); - type_tag = complex_scalar_constant; - } - else - { - ::error ("invalid assignment to scalar"); - return; - } - } - else - { - if (rhs.const_type () == scalar_constant) - { - delete complex_scalar; - scalar = rhs.double_value (); - type_tag = scalar_constant; - } - else if (rhs.const_type () == complex_scalar_constant) - { - *complex_scalar = rhs.complex_value (); - type_tag = complex_scalar_constant; - } - else - { - ::error ("invalid assignment to scalar"); - return; - } - } - } - else if (user_pref.resize_on_range_error) - { - tree_constant_rep::constant_type old_type_tag = type_tag; - - if (type_tag == complex_scalar_constant) - { - Complex *old_complex = complex_scalar; - complex_matrix = new ComplexMatrix (1, 1, *complex_scalar); - type_tag = complex_matrix_constant; - delete old_complex; - } - else if (type_tag == scalar_constant) - { - matrix = new Matrix (1, 1, scalar); - type_tag = matrix_constant; - } - -// If there is an error, the call to do_matrix_assignment should not -// destroy the current value. tree_constant_rep::eval(int) will take -// care of converting single element matrices back to scalars. - - do_matrix_assignment (rhs, args, nargs); - -// I don't think there's any other way to revert back to unknown -// constant types, so here it is. - - if (old_type_tag == unknown_constant && error_state) - { - if (type_tag == matrix_constant) - delete matrix; - else if (type_tag == complex_matrix_constant) - delete complex_matrix; - - type_tag = unknown_constant; - } - } - else if (nargs > 3 || nargs < 2) - ::error ("invalid index expression for scalar type"); - else - ::error ("index invalid or out of range for scalar type"); -} - -// Assignments to matrices (and vectors). -// -// For compatibility with Matlab, we allow assignment of an empty -// matrix to an expression with empty indices to do nothing. - -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant *args, int nargs) -{ - assert (type_tag == unknown_constant - || type_tag == matrix_constant - || type_tag == complex_matrix_constant); - - if (type_tag == matrix_constant && rhs.is_complex_type ()) - { - Matrix *old_matrix = matrix; - complex_matrix = new ComplexMatrix (*matrix); - type_tag = complex_matrix_constant; - delete old_matrix; - } - else if (type_tag == unknown_constant) - { - if (rhs.is_complex_type ()) - { - complex_matrix = new ComplexMatrix (); - type_tag = complex_matrix_constant; - } - else - { - matrix = new Matrix (); - type_tag = matrix_constant; - } - } - -// The do_matrix_assignment functions can't handle empty matrices, so -// don't let any pass through here. - switch (nargs) - { - case 2: - if (args == NULL_TREE_CONST) - ::error ("matrix index is null"); - else if (args[1].is_undefined ()) - ::error ("matrix index is undefined"); - else - do_matrix_assignment (rhs, args[1]); - break; - case 3: - if (args == NULL_TREE_CONST) - ::error ("matrix indices are null"); - else if (args[1].is_undefined ()) - ::error ("first matrix index is undefined"); - else if (args[2].is_undefined ()) - ::error ("second matrix index is undefined"); - else if (args[1].is_empty () || args[2].is_empty ()) - { - if (! rhs.is_empty ()) - { - ::error ("in assignment expression, a matrix index is empty"); - ::error ("but hte right hand side is not an empty matrix"); - } -// XXX FIXME XXX -- to really be correct here, we should probably -// check to see if the assignment conforms, but that seems like more -// work than it's worth right now... - } - else - do_matrix_assignment (rhs, args[1], args[2]); - break; - default: - ::error ("too many indices for matrix expression"); - break; - } -} - -// Matrix assignments indexed by a single value. - -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant& i_arg) -{ - int nr = rows (); - int nc = columns (); - - if (user_pref.do_fortran_indexing || nr <= 1 || nc <= 1) - { - if (i_arg.is_empty ()) - { - if (! rhs.is_empty ()) - { - ::error ("in assignment expression, matrix index is empty but"); - ::error ("right hand side is not an empty matrix"); - } -// XXX FIXME XXX -- to really be correct here, we should probably -// check to see if the assignment conforms, but that seems like more -// work than it's worth right now... - -// The assignment functions can't handle empty matrices, so don't let -// any pass through here. - return; - } - -// We can't handle the case of assigning to a vector first, since even -// then, the two operations are not equivalent. For example, the -// expression V(:) = M is handled differently depending on whether the -// user specified do_fortran_indexing = "true". - - if (user_pref.do_fortran_indexing) - fortran_style_matrix_assignment (rhs, i_arg); - else if (nr <= 1 || nc <= 1) - vector_assignment (rhs, i_arg); - else - panic_impossible (); - } - else - ::error ("single index only valid for row or column vector"); -} - -// Fortran-style assignments. Matrices are assumed to be stored in -// column-major order and it is ok to use a single index for -// multi-dimensional matrices. - -void -tree_constant_rep::fortran_style_matrix_assignment (tree_constant& rhs, - tree_constant& i_arg) -{ - tree_constant tmp_i = i_arg.make_numeric_or_magic (); - - tree_constant_rep::constant_type itype = tmp_i.const_type (); - - int nr = rows (); - int nc = columns (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = NINT (tmp_i.double_value ()); - int idx = i - 1; - - if (rhs_nr == 0 && rhs_nc == 0) - { - if (idx < nr * nc) - { - convert_to_row_or_column_vector (); - - nr = rows (); - nc = columns (); - - if (nr == 1) - delete_column (idx); - else if (nc == 1) - delete_row (idx); - else - panic_impossible (); - } - return; - } - - if (index_check (idx, "") < 0) - return; - - if (nr <= 1 || nc <= 1) - { - maybe_resize (idx); - if (error_state) - return; - } - else if (range_max_check (idx, nr * nc) < 0) - return; - - nr = rows (); - nc = columns (); - - if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) - { - ::error ("for A(int) = X: X must be a scalar"); - return; - } - int ii = fortran_row (i, nr) - 1; - int jj = fortran_column (i, nr) - 1; - do_matrix_assignment (rhs, ii, jj); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - int len = nr * nc; - idx_vector ii (mi, 1, "", len); // Always do fortran indexing here... - if (! ii) - return; - - if (rhs_nr == 0 && rhs_nc == 0) - { - ii.sort_uniq (); - int num_to_delete = 0; - for (int i = 0; i < ii.length (); i++) - { - if (ii.elem (i) < len) - num_to_delete++; - else - break; - } - - if (num_to_delete > 0) - { - if (num_to_delete != ii.length ()) - ii.shorten (num_to_delete); - - convert_to_row_or_column_vector (); - - nr = rows (); - nc = columns (); - - if (nr == 1) - delete_columns (ii); - else if (nc == 1) - delete_rows (ii); - else - panic_impossible (); - } - return; - } - - if (nr <= 1 || nc <= 1) - { - maybe_resize (ii.max ()); - if (error_state) - return; - } - else if (range_max_check (ii.max (), len) < 0) - return; - - int ilen = ii.capacity (); - - if (ilen != rhs_nr * rhs_nc) - { - ::error ("A(matrix) = X: X and matrix must have the same number"); - ::error ("of elements"); - } - else if (ilen == 1 && rhs.is_scalar_type ()) - { - int nr = rows (); - int idx = ii.elem (0); - int ii = fortran_row (idx + 1, nr) - 1; - int jj = fortran_column (idx + 1, nr) - 1; - - if (rhs.const_type () == scalar_constant) - matrix->elem (ii, jj) = rhs.double_value (); - else if (rhs.const_type () == complex_scalar_constant) - complex_matrix->elem (ii, jj) = rhs.complex_value (); - else - panic_impossible (); - } - else - fortran_style_matrix_assignment (rhs, ii); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - gripe_range_invalid (); - break; - case magic_colon: -// a(:) = [] is equivalent to a(:,:) = foo. - if (rhs_nr == 0 && rhs_nc == 0) - do_matrix_assignment (rhs, magic_colon, magic_colon); - else - fortran_style_matrix_assignment (rhs, magic_colon); - break; - default: - panic_impossible (); - break; - } -} - -// Fortran-style assignment for vector index. - -void -tree_constant_rep::fortran_style_matrix_assignment (tree_constant& rhs, - idx_vector& i) -{ - assert (rhs.is_matrix_type ()); - - int ilen = i.capacity (); - - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int len = rhs_nr * rhs_nc; - - if (len == ilen) - { - int nr = rows (); - if (rhs.const_type () == matrix_constant) - { - double *cop_out = rhs_m.fortran_vec (); - for (int k = 0; k < len; k++) - { - int ii = fortran_row (i.elem (k) + 1, nr) - 1; - int jj = fortran_column (i.elem (k) + 1, nr) - 1; - - matrix->elem (ii, jj) = *cop_out++; - } - } - else - { - Complex *cop_out = rhs_cm.fortran_vec (); - for (int k = 0; k < len; k++) - { - int ii = fortran_row (i.elem (k) + 1, nr) - 1; - int jj = fortran_column (i.elem (k) + 1, nr) - 1; - - complex_matrix->elem (ii, jj) = *cop_out++; - } - } - } - else - ::error ("number of rows and columns must match for indexed assignment"); -} - -// Fortran-style assignment for colon index. - -void -tree_constant_rep::fortran_style_matrix_assignment - (tree_constant& rhs, tree_constant_rep::constant_type mci) -{ - assert (rhs.is_matrix_type () && mci == tree_constant_rep::magic_colon); - - int nr = rows (); - int nc = columns (); - - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int rhs_size = rhs_nr * rhs_nc; - if (rhs_size == 0) - { - if (rhs.const_type () == matrix_constant) - { - delete matrix; - matrix = new Matrix (0, 0); - return; - } - else - panic_impossible (); - } - else if (nr*nc != rhs_size) - { - ::error ("A(:) = X: X and A must have the same number of elements"); - return; - } - - if (rhs.const_type () == matrix_constant) - { - double *cop_out = rhs_m.fortran_vec (); - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - matrix->elem (i, j) = *cop_out++; - } - else - { - Complex *cop_out = rhs_cm.fortran_vec (); - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - complex_matrix->elem (i, j) = *cop_out++; - } -} - -// Assignments to vectors. Hand off to other functions once we know -// what kind of index we have. For a colon, it is the same as -// assignment to a matrix indexed by two colons. - -void -tree_constant_rep::vector_assignment (tree_constant& rhs, tree_constant& i_arg) -{ - int nr = rows (); - int nc = columns (); - - assert ((nr == 1 || nc == 1 || (nr == 0 && nc == 0)) - && ! user_pref.do_fortran_indexing); - - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type itype = tmp_i.const_type (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - if (index_check (i, "") < 0) - return; - do_vector_assign (rhs, i); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - int len = nr * nc; - idx_vector iv (mi, user_pref.do_fortran_indexing, "", len); - if (! iv) - return; - - do_vector_assign (rhs, iv); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range ri = tmp_i.range_value (); - int len = nr * nc; - if (len == 2 && is_zero_one (ri)) - { - do_vector_assign (rhs, 1); - } - else if (len == 2 && is_one_zero (ri)) - { - do_vector_assign (rhs, 0); - } - else - { - if (index_check (ri, "") < 0) - return; - do_vector_assign (rhs, ri); - } - } - break; - case magic_colon: - { - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - if (! indexed_assign_conforms (nr, nc, rhs_nr, rhs_nc)) - { - ::error ("A(:) = X: X and A must have the same dimensions"); - return; - } - do_matrix_assignment (rhs, magic_colon, magic_colon); - } - break; - default: - panic_impossible (); - break; - } -} - -// Check whether an indexed assignment to a vector is valid. - -void -tree_constant_rep::check_vector_assign (int rhs_nr, int rhs_nc, - int ilen, const char *rm) -{ - int nr = rows (); - int nc = columns (); - - if ((nr == 1 && nc == 1) || nr == 0 || nc == 0) // No orientation. - { - if (! (ilen == rhs_nr || ilen == rhs_nc)) - { - ::error ("A(%s) = X: X and %s must have the same number of elements", - rm, rm); - } - } - else if (nr == 1) // Preserve current row orientation. - { - if (! (rhs_nr == 1 && rhs_nc == ilen)) - { - ::error ("A(%s) = X: where A is a row vector, X must also be a", rm); - ::error ("row vector with the same number of elements as %s", rm); - } - } - else if (nc == 1) // Preserve current column orientation. - { - if (! (rhs_nc == 1 && rhs_nr == ilen)) - { - ::error ("A(%s) = X: where A is a column vector, X must also be", rm); - ::error ("a column vector with the same number of elements as %s", rm); - } - } - else - panic_impossible (); -} - -// Assignment to a vector with an integer index. - -void -tree_constant_rep::do_vector_assign (tree_constant& rhs, int i) -{ - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - if (indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) - { - maybe_resize (i); - if (error_state) - return; - - int nr = rows (); - int nc = columns (); - - if (nr == 1) - { - REP_ELEM_ASSIGN (0, i, rhs.double_value (), rhs.complex_value (), - rhs.is_real_type ()); - } - else if (nc == 1) - { - REP_ELEM_ASSIGN (i, 0, rhs.double_value (), rhs.complex_value (), - rhs.is_real_type ()); - } - else - panic_impossible (); - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - int nr = rows (); - int nc = columns (); - - int len = nr > nc ? nr : nc; - - if (i < 0 || i >= len) - { - ::error ("A(int) = []: index out of range"); - return; - } - - if (nr == 1) - delete_column (i); - else if (nc == 1) - delete_row (i); - else - panic_impossible (); - } - else - { - ::error ("for A(int) = X: X must be a scalar"); - return; - } -} - -// Assignment to a vector with a vector index. - -void -tree_constant_rep::do_vector_assign (tree_constant& rhs, idx_vector& iv) -{ - if (rhs.is_zero_by_zero ()) - { - int nr = rows (); - int nc = columns (); - - int len = nr > nc ? nr : nc; - - if (iv.max () >= len) - { - ::error ("A(matrix) = []: index out of range"); - return; - } - - if (nr == 1) - delete_columns (iv); - else if (nc == 1) - delete_rows (iv); - else - panic_impossible (); - } - else if (rhs.is_scalar_type ()) - { - int nr = rows (); - int nc = columns (); - - if (iv.capacity () == 1) - { - int idx = iv.elem (0); - - if (nr == 1) - { - REP_ELEM_ASSIGN (0, idx, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else if (nc == 1) - { - REP_ELEM_ASSIGN (idx, 0, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else - panic_impossible (); - } - else - { - if (nr == 1) - { - ::error ("A(matrix) = X: where A is a row vector, X must also be a"); - ::error ("row vector with the same number of elements as matrix"); - } - else if (nc == 1) - { - ::error ("A(matrix) = X: where A is a column vector, X must also be a"); - ::error ("column vector with the same number of elements as matrix"); - } - else - panic_impossible (); - } - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int ilen = iv.capacity (); - check_vector_assign (rhs_nr, rhs_nc, ilen, "matrix"); - if (error_state) - return; - - force_orient f_orient = no_orient; - if (rhs_nr == 1 && rhs_nc != 1) - f_orient = row_orient; - else if (rhs_nc == 1 && rhs_nr != 1) - f_orient = column_orient; - - maybe_resize (iv.max (), f_orient); - if (error_state) - return; - - int nr = rows (); - int nc = columns (); - - if (nr == 1) - { - for (int i = 0; i < iv.capacity (); i++) - REP_ELEM_ASSIGN (0, iv.elem (i), rhs_m.elem (0, i), - rhs_cm.elem (0, i), rhs.is_real_type ()); - } - else if (nc == 1) - { - for (int i = 0; i < iv.capacity (); i++) - REP_ELEM_ASSIGN (iv.elem (i), 0, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } - else - panic_impossible (); - } - else - panic_impossible (); -} - -// Assignment to a vector with a range index. - -void -tree_constant_rep::do_vector_assign (tree_constant& rhs, Range& ri) -{ - if (rhs.is_zero_by_zero ()) - { - int nr = rows (); - int nc = columns (); - - int len = nr > nc ? nr : nc; - - int b = tree_to_mat_idx (ri.min ()); - int l = tree_to_mat_idx (ri.max ()); - if (b < 0 || l >= len) - { - ::error ("A(range) = []: index out of range"); - return; - } - - if (nr == 1) - delete_columns (ri); - else if (nc == 1) - delete_rows (ri); - else - panic_impossible (); - } - else if (rhs.is_scalar_type ()) - { - int nr = rows (); - int nc = columns (); - - if (nr == 1) - { - ::error ("A(range) = X: where A is a row vector, X must also be a"); - ::error ("row vector with the same number of elements as range"); - } - else if (nc == 1) - { - ::error ("A(range) = X: where A is a column vector, X must also be a"); - ::error ("column vector with the same number of elements as range"); - } - else - panic_impossible (); - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int ilen = ri.nelem (); - check_vector_assign (rhs_nr, rhs_nc, ilen, "range"); - if (error_state) - return; - - force_orient f_orient = no_orient; - if (rhs_nr == 1 && rhs_nc != 1) - f_orient = row_orient; - else if (rhs_nc == 1 && rhs_nr != 1) - f_orient = column_orient; - - maybe_resize (tree_to_mat_idx (ri.max ()), f_orient); - if (error_state) - return; - - int nr = rows (); - int nc = columns (); - - double b = ri.base (); - double increment = ri.inc (); - - if (nr == 1) - { - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int col = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (0, col, rhs_m.elem (0, i), rhs_cm.elem (0, i), - rhs.is_real_type ()); - } - } - else if (nc == 1) - { - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, 0, rhs_m.elem (i, 0), rhs_cm.elem (i, 0), - rhs.is_real_type ()); - } - } - else - panic_impossible (); - } - else - panic_impossible (); -} - -// Matrix assignment indexed by two values. This function determines -// the type of the first arugment, checks as much as possible, and -// then calls one of a set of functions to handle the specific cases: -// -// M (integer, arg2) = RHS (MA1) -// M (vector, arg2) = RHS (MA2) -// M (range, arg2) = RHS (MA3) -// M (colon, arg2) = RHS (MA4) -// -// Each of those functions determines the type of the second argument -// and calls another function to handle the real work of doing the -// assignment. - -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant& i_arg, - tree_constant& j_arg) -{ - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type itype = tmp_i.const_type (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - if (index_check (i, "row") < 0) - return; - do_matrix_assignment (rhs, i, j_arg); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - idx_vector iv (mi, user_pref.do_fortran_indexing, "row", rows ()); - if (! iv) - return; - - do_matrix_assignment (rhs, iv, j_arg); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range ri = tmp_i.range_value (); - int nr = rows (); - if (nr == 2 && is_zero_one (ri)) - { - do_matrix_assignment (rhs, 1, j_arg); - } - else if (nr == 2 && is_one_zero (ri)) - { - do_matrix_assignment (rhs, 0, j_arg); - } - else - { - if (index_check (ri, "row") < 0) - return; - do_matrix_assignment (rhs, ri, j_arg); - } - } - break; - case magic_colon: - do_matrix_assignment (rhs, magic_colon, j_arg); - break; - default: - panic_impossible (); - break; - } -} - -// -*- MA1 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, - tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) - { - ::error ("A(int,int) = X, X must be a scalar"); - return; - } - maybe_resize (i, j); - if (error_state) - return; - - do_matrix_assignment (rhs, i, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - if (! indexed_assign_conforms (1, jv.capacity (), rhs_nr, rhs_nc)) - { - ::error ("A(int,matrix) = X: X must be a row vector with the same"); - ::error ("number of elements as matrix"); - return; - } - maybe_resize (i, jv.max ()); - if (error_state) - return; - - do_matrix_assignment (rhs, i, jv); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (! indexed_assign_conforms (1, rj.nelem (), rhs_nr, rhs_nc)) - { - ::error ("A(int,range) = X: X must be a row vector with the same"); - ::error ("number of elements as range"); - return; - } - - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, i, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, i, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - maybe_resize (i, tree_to_mat_idx (rj.max ())); - if (error_state) - return; - - do_matrix_assignment (rhs, i, rj); - } - } - break; - case magic_colon: - { - int nc = columns (); - int nr = rows (); - if (nc == 0 && nr == 0 && rhs_nr == 1) - { - if (rhs.is_complex_type ()) - { - complex_matrix = new ComplexMatrix (); - type_tag = complex_matrix_constant; - } - else - { - matrix = new Matrix (); - type_tag = matrix_constant; - } - maybe_resize (i, rhs_nc-1); - if (error_state) - return; - } - else if (indexed_assign_conforms (1, nc, rhs_nr, rhs_nc)) - { - maybe_resize (i, nc-1); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (i < 0 || i >= nr) - { - ::error ("A(int,:) = []: row index out of range"); - return; - } - } - else - { - ::error ("A(int,:) = X: X must be a row vector with the same"); - ::error ("number of columns as A"); - return; - } - - do_matrix_assignment (rhs, i, magic_colon); - } - break; - default: - panic_impossible (); - break; - } -} - -// -*- MA2 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, idx_vector& iv, - tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - if (! indexed_assign_conforms (iv.capacity (), 1, rhs_nr, rhs_nc)) - { - ::error ("A(matrix,int) = X: X must be a column vector with the"); - ::error ("same number of elements as matrix"); - return; - } - maybe_resize (iv.max (), j); - if (error_state) - return; - - do_matrix_assignment (rhs, iv, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - if (! indexed_assign_conforms (iv.capacity (), jv.capacity (), - rhs_nr, rhs_nc)) - { - ::error ("A(r_mat,c_mat) = X: the number of rows in X must match"); - ::error ("the number of elements in r_mat and the number of"); - ::error ("columns in X must match the number of elements in c_mat"); - return; - } - maybe_resize (iv.max (), jv.max ()); - if (error_state) - return; - - do_matrix_assignment (rhs, iv, jv); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (! indexed_assign_conforms (iv.capacity (), rj.nelem (), - rhs_nr, rhs_nc)) - { - ::error ("A(matrix,range) = X: the number of rows in X must match"); - ::error ("the number of elements in matrix and the number of"); - ::error ("columns in X must match the number of elements in range"); - return; - } - - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, iv, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, iv, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - maybe_resize (iv.max (), tree_to_mat_idx (rj.max ())); - if (error_state) - return; - - do_matrix_assignment (rhs, iv, rj); - } - } - break; - case magic_colon: - { - int nc = columns (); - int new_nc = nc; - if (nc == 0) - new_nc = rhs_nc; - - if (indexed_assign_conforms (iv.capacity (), new_nc, - rhs_nr, rhs_nc)) - { - maybe_resize (iv.max (), new_nc-1); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (iv.max () >= rows ()) - { - ::error ("A(matrix,:) = []: row index out of range"); - return; - } - } - else - { - ::error ("A(matrix,:) = X: the number of rows in X must match the"); - ::error ("number of elements in matrix, and the number of columns"); - ::error ("in X must match the number of columns in A"); - return; - } - - do_matrix_assignment (rhs, iv, magic_colon); - } - break; - default: - panic_impossible (); - break; - } -} - -// -*- MA3 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - Range& ri, tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - if (! indexed_assign_conforms (ri.nelem (), 1, rhs_nr, rhs_nc)) - { - ::error ("A(range,int) = X: X must be a column vector with the"); - ::error ("same number of elements as range"); - return; - } - maybe_resize (tree_to_mat_idx (ri.max ()), j); - if (error_state) - return; - - do_matrix_assignment (rhs, ri, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - if (! indexed_assign_conforms (ri.nelem (), jv.capacity (), - rhs_nr, rhs_nc)) - { - ::error ("A(range,matrix) = X: the number of rows in X must match"); - ::error ("the number of elements in range and the number of"); - ::error ("columns in X must match the number of elements in matrix"); - return; - } - maybe_resize (tree_to_mat_idx (ri.max ()), jv.max ()); - if (error_state) - return; - - do_matrix_assignment (rhs, ri, jv); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (! indexed_assign_conforms (ri.nelem (), rj.nelem (), - rhs_nr, rhs_nc)) - { - ::error ("A(r_range,c_range) = X: the number of rows in X must"); - ::error ("match the number of elements in r_range and the number"); - ::error ("of columns in X must match the number of elements in"); - ::error ("c_range"); - return; - } - - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, ri, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, ri, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - - maybe_resize (tree_to_mat_idx (ri.max ()), - tree_to_mat_idx (rj.max ())); - - if (error_state) - return; - - do_matrix_assignment (rhs, ri, rj); - } - } - break; - case magic_colon: - { - int nc = columns (); - int new_nc = nc; - if (nc == 0) - new_nc = rhs_nc; - - if (indexed_assign_conforms (ri.nelem (), new_nc, rhs_nr, rhs_nc)) - { - maybe_resize (tree_to_mat_idx (ri.max ()), new_nc-1); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - int b = tree_to_mat_idx (ri.min ()); - int l = tree_to_mat_idx (ri.max ()); - if (b < 0 || l >= rows ()) - { - ::error ("A(range,:) = []: row index out of range"); - return; - } - } - else - { - ::error ("A(range,:) = X: the number of rows in X must match the"); - ::error ("number of elements in range, and the number of columns"); - ::error ("in X must match the number of columns in A"); - return; - } - - do_matrix_assignment (rhs, ri, magic_colon); - } - break; - default: - panic_impossible (); - break; - } -} - -// -*- MA4 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant_rep::constant_type i, - tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - int nr = rows (); - int nc = columns (); - if (nr == 0 && nc == 0 && rhs_nc == 1) - { - if (rhs.is_complex_type ()) - { - complex_matrix = new ComplexMatrix (); - type_tag = complex_matrix_constant; - } - else - { - matrix = new Matrix (); - type_tag = matrix_constant; - } - maybe_resize (rhs_nr-1, j); - if (error_state) - return; - } - else if (indexed_assign_conforms (nr, 1, rhs_nr, rhs_nc)) - { - maybe_resize (nr-1, j); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (j < 0 || j >= nc) - { - ::error ("A(:,int) = []: column index out of range"); - return; - } - } - else - { - ::error ("A(:,int) = X: X must be a column vector with the same"); - ::error ("number of rows as A"); - return; - } - - do_matrix_assignment (rhs, magic_colon, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - int nr = rows (); - int new_nr = nr; - if (nr == 0) - new_nr = rhs_nr; - - if (indexed_assign_conforms (new_nr, jv.capacity (), - rhs_nr, rhs_nc)) - { - maybe_resize (new_nr-1, jv.max ()); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (jv.max () >= columns ()) - { - ::error ("A(:,matrix) = []: column index out of range"); - return; - } - } - else - { - ::error ("A(:,matrix) = X: the number of rows in X must match the"); - ::error ("number of rows in A, and the number of columns in X must"); - ::error ("match the number of elements in matrix"); - return; - } - - do_matrix_assignment (rhs, magic_colon, jv); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - int nr = rows (); - int new_nr = nr; - if (nr == 0) - new_nr = rhs_nr; - - if (indexed_assign_conforms (new_nr, rj.nelem (), rhs_nr, rhs_nc)) - { - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, magic_colon, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, magic_colon, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - maybe_resize (new_nr-1, tree_to_mat_idx (rj.max ())); - if (error_state) - return; - } - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - int b = tree_to_mat_idx (rj.min ()); - int l = tree_to_mat_idx (rj.max ()); - if (b < 0 || l >= columns ()) - { - ::error ("A(:,range) = []: column index out of range"); - return; - } - } - else - { - ::error ("A(:,range) = X: the number of rows in X must match the"); - ::error ("number of rows in A, and the number of columns in X"); - ::error ("must match the number of elements in range"); - return; - } - - do_matrix_assignment (rhs, magic_colon, rj); - } - break; - case magic_colon: -// a(:,:) = foo is equivalent to a = foo. - do_matrix_assignment (rhs, magic_colon, magic_colon); - break; - default: - panic_impossible (); - break; - } -} - -// Functions that actually handle assignment to a matrix using two -// index values. -// -// idx2 -// +---+---+----+----+ -// idx1 | i | v | r | c | -// ---------+---+---+----+----+ -// integer | 1 | 5 | 9 | 13 | -// ---------+---+---+----+----+ -// vector | 2 | 6 | 10 | 14 | -// ---------+---+---+----+----+ -// range | 3 | 7 | 11 | 15 | -// ---------+---+---+----+----+ -// colon | 4 | 8 | 12 | 16 | -// ---------+---+---+----+----+ - -// -*- 1 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, int j) -{ - REP_ELEM_ASSIGN (i, j, rhs.double_value (), rhs.complex_value (), - rhs.is_real_type ()); -} - -// -*- 2 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, - idx_vector& jv) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int j = 0; j < jv.capacity (); j++) - REP_ELEM_ASSIGN (i, jv.elem (j), rhs_m.elem (0, j), - rhs_cm.elem (0, j), rhs.is_real_type ()); -} - -// -*- 3 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, Range& rj) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = rj.base (); - double increment = rj.inc (); - - for (int j = 0; j < rj.nelem (); j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (i, col, rhs_m.elem (0, j), rhs_cm.elem (0, j), - rhs.is_real_type ()); - } -} - -// -*- 4 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, int i, - tree_constant_rep::constant_type mcj) -{ - assert (mcj == magic_colon); - - int nc = columns (); - - if (rhs.is_zero_by_zero ()) - { - delete_row (i); - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int j = 0; j < nc; j++) - REP_ELEM_ASSIGN (i, j, rhs_m.elem (0, j), rhs_cm.elem (0, j), - rhs.is_real_type ()); - } - else if (rhs.is_scalar_type () && nc == 1) - { - REP_ELEM_ASSIGN (i, 0, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else - panic_impossible (); -} - -// -*- 5 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - idx_vector& iv, int j) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } -} - -// -*- 6 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - idx_vector& iv, idx_vector& jv) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - for (int j = 0; j < jv.capacity (); j++) - { - int col = jv.elem (j); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -// -*- 7 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - idx_vector& iv, Range& rj) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = rj.base (); - double increment = rj.inc (); - - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - for (int j = 0; j < rj.nelem (); j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -// -*- 8 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, idx_vector& iv, - tree_constant_rep::constant_type mcj) -{ - assert (mcj == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_rows (iv); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int nc = columns (); - - for (int j = 0; j < nc; j++) - { - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } - } -} - -// -*- 9 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, int j) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = ri.base (); - double increment = ri.inc (); - - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } -} - -// -*- 10 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, - idx_vector& jv) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = ri.base (); - double increment = ri.inc (); - - for (int j = 0; j < jv.capacity (); j++) - { - int col = jv.elem (j); - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_m.elem (i, j), rhs.is_real_type ()); - } - } -} - -// -*- 11 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, - Range& rj) -{ - double ib = ri.base (); - double iinc = ri.inc (); - double jb = rj.base (); - double jinc = rj.inc (); - - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < ri.nelem (); i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < rj.nelem (); j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -// -*- 12 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, Range& ri, - tree_constant_rep::constant_type mcj) -{ - assert (mcj == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_rows (ri); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double ib = ri.base (); - double iinc = ri.inc (); - - int nc = columns (); - - for (int i = 0; i < ri.nelem (); i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < nc; j++) - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -// -*- 13 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant_rep::constant_type mci, - int j) -{ - assert (mci == magic_colon); - - int nr = rows (); - - if (rhs.is_zero_by_zero ()) - { - delete_column (j); - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < nr; i++) - REP_ELEM_ASSIGN (i, j, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } - else if (rhs.is_scalar_type () && nr == 1) - { - REP_ELEM_ASSIGN (0, j, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else - panic_impossible (); -} - -// -*- 14 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant_rep::constant_type mci, - idx_vector& jv) -{ - assert (mci == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_columns (jv); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int nr = rows (); - - for (int i = 0; i < nr; i++) - { - for (int j = 0; j < jv.capacity (); j++) - { - int col = jv.elem (j); - REP_ELEM_ASSIGN (i, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } - } -} - -// -*- 15 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant_rep::constant_type mci, - Range& rj) -{ - assert (mci == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_columns (rj); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int nr = rows (); - - double jb = rj.base (); - double jinc = rj.inc (); - - for (int j = 0; j < rj.nelem (); j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - for (int i = 0; i < nr; i++) - { - REP_ELEM_ASSIGN (i, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } - } -} - -// -*- 16 -*- -void -tree_constant_rep::do_matrix_assignment (tree_constant& rhs, - tree_constant_rep::constant_type mci, - tree_constant_rep::constant_type mcj) -{ - assert (mci == magic_colon && mcj == magic_colon); - - switch (type_tag) - { - case scalar_constant: - break; - case matrix_constant: - delete matrix; - break; - case complex_scalar_constant: - delete complex_scalar; - break; - case complex_matrix_constant: - delete complex_matrix; - break; - case string_constant: - delete [] string; - break; - case range_constant: - delete range; - break; - case magic_colon: - default: - panic_impossible (); - break; - } - - type_tag = rhs.const_type (); - - switch (type_tag) - { - case scalar_constant: - scalar = rhs.double_value (); - break; - case matrix_constant: - matrix = new Matrix (rhs.matrix_value ()); - break; - case string_constant: - string = strsave (rhs.string_value ()); - break; - case complex_matrix_constant: - complex_matrix = new ComplexMatrix (rhs.complex_matrix_value ()); - break; - case complex_scalar_constant: - complex_scalar = new Complex (rhs.complex_value ()); - break; - case range_constant: - range = new Range (rhs.range_value ()); - break; - case magic_colon: - default: - panic_impossible (); - break; - } -} - -// Functions for deleting rows or columns of a matrix. These are used -// to handle statements like -// -// M (i, j) = [] - -void -tree_constant_rep::delete_row (int idx) -{ - if (type_tag == matrix_constant) - { - int nr = matrix->rows (); - int nc = matrix->columns (); - Matrix *new_matrix = new Matrix (nr-1, nc); - int ii = 0; - for (int i = 0; i < nr; i++) - { - if (i != idx) - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = matrix->elem (i, j); - ii++; - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - int nr = complex_matrix->rows (); - int nc = complex_matrix->columns (); - ComplexMatrix *new_matrix = new ComplexMatrix (nr-1, nc); - int ii = 0; - for (int i = 0; i < nr; i++) - { - if (i != idx) - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = complex_matrix->elem (i, j); - ii++; - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -tree_constant_rep::delete_rows (idx_vector& iv) -{ - iv.sort_uniq (); - int num_to_delete = iv.length (); - - int nr = rows (); - int nc = columns (); - -// If deleting all rows of a column vector, make result 0x0. - if (nc == 1 && num_to_delete == nr) - nc = 0; - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - if (i == iv.elem (idx)) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = matrix->elem (i, j); - ii++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - if (i == iv.elem (idx)) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = complex_matrix->elem (i, j); - ii++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -tree_constant_rep::delete_rows (Range& ri) -{ - ri.sort (); - int num_to_delete = ri.nelem (); - - int nr = rows (); - int nc = columns (); - -// If deleting all rows of a column vector, make result 0x0. - if (nc == 1 && num_to_delete == nr) - nc = 0; - - double ib = ri.base (); - double iinc = ri.inc (); - - int max_idx = tree_to_mat_idx (ri.max ()); - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - double itmp = ib + idx * iinc; - int row = tree_to_mat_idx (itmp); - - if (i == row && row <= max_idx) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = matrix->elem (i, j); - ii++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - double itmp = ib + idx * iinc; - int row = tree_to_mat_idx (itmp); - - if (i == row && row <= max_idx) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = complex_matrix->elem (i, j); - ii++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -tree_constant_rep::delete_column (int idx) -{ - if (type_tag == matrix_constant) - { - int nr = matrix->rows (); - int nc = matrix->columns (); - Matrix *new_matrix = new Matrix (nr, nc-1); - int jj = 0; - for (int j = 0; j < nc; j++) - { - if (j != idx) - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = matrix->elem (i, j); - jj++; - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - int nr = complex_matrix->rows (); - int nc = complex_matrix->columns (); - ComplexMatrix *new_matrix = new ComplexMatrix (nr, nc-1); - int jj = 0; - for (int j = 0; j < nc; j++) - { - if (j != idx) - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = complex_matrix->elem (i, j); - jj++; - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -tree_constant_rep::delete_columns (idx_vector& jv) -{ - jv.sort_uniq (); - int num_to_delete = jv.length (); - - int nr = rows (); - int nc = columns (); - -// If deleting all columns of a row vector, make result 0x0. - if (nr == 1 && num_to_delete == nc) - nr = 0; - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - if (j == jv.elem (idx)) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = matrix->elem (i, j); - jj++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - if (j == jv.elem (idx)) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = complex_matrix->elem (i, j); - jj++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -tree_constant_rep::delete_columns (Range& rj) -{ - rj.sort (); - int num_to_delete = rj.nelem (); - - int nr = rows (); - int nc = columns (); - -// If deleting all columns of a row vector, make result 0x0. - if (nr == 1 && num_to_delete == nc) - nr = 0; - - double jb = rj.base (); - double jinc = rj.inc (); - - int max_idx = tree_to_mat_idx (rj.max ()); - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - double jtmp = jb + idx * jinc; - int col = tree_to_mat_idx (jtmp); - - if (j == col && col <= max_idx) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = matrix->elem (i, j); - jj++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - double jtmp = jb + idx * jinc; - int col = tree_to_mat_idx (jtmp); - - if (j == col && col <= max_idx) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = complex_matrix->elem (i, j); - jj++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/tc-extras.cc Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1387 +0,0 @@ -// Some extra friends of the tree constant class. -*- C++ -*- -// See also the other tc-*.cc files. -/* - -Copyright (C) 1992, 1993, 1994 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif - -#include <strstream.h> -#include <iostream.h> -#include <fstream.h> -#include <string.h> -#include <ctype.h> - -#include "EIG.h" - -#include "unwind-prot.h" -#include "tree-const.h" -#include "user-prefs.h" -#include "variables.h" -#include "octave.h" -#include "gripes.h" -#include "error.h" -#include "input.h" -#include "octave-hist.h" -#include "pager.h" -#include "utils.h" -#include "parse.h" -#include "lex.h" - -Matrix -max (const Matrix& a, const Matrix& b) -{ - int nr = a.rows (); - int nc = a.columns (); - if (nr != b.rows () || nc != b.columns ()) - { - error ("two-arg max expecting args of same size"); - return Matrix (); - } - - Matrix result (nr, nc); - - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - { - double a_elem = a.elem (i, j); - double b_elem = b.elem (i, j); - result.elem (i, j) = MAX (a_elem, b_elem); - } - - return result; -} - -ComplexMatrix -max (const ComplexMatrix& a, const ComplexMatrix& b) -{ - int nr = a.rows (); - int nc = a.columns (); - if (nr != b.rows () || nc != b.columns ()) - { - error ("two-arg max expecting args of same size"); - return ComplexMatrix (); - } - - ComplexMatrix result (nr, nc); - - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - { - double abs_a_elem = abs (a.elem (i, j)); - double abs_b_elem = abs (b.elem (i, j)); - if (abs_a_elem > abs_b_elem) - result.elem (i, j) = a.elem (i, j); - else - result.elem (i, j) = b.elem (i, j); - } - - return result; -} - -Matrix -min (const Matrix& a, const Matrix& b) -{ - int nr = a.rows (); - int nc = a.columns (); - if (nr != b.rows () || nc != b.columns ()) - { - error ("two-arg min expecting args of same size"); - return Matrix (); - } - - Matrix result (nr, nc); - - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - { - double a_elem = a.elem (i, j); - double b_elem = b.elem (i, j); - result.elem (i, j) = MIN (a_elem, b_elem); - } - - return result; -} - -ComplexMatrix -min (const ComplexMatrix& a, const ComplexMatrix& b) -{ - int nr = a.rows (); - int nc = a.columns (); - if (nr != b.rows () || nc != b.columns ()) - { - error ("two-arg min expecting args of same size"); - return ComplexMatrix (); - } - - ComplexMatrix result (nr, nc); - - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - { - double abs_a_elem = abs (a.elem (i, j)); - double abs_b_elem = abs (b.elem (i, j)); - if (abs_a_elem < abs_b_elem) - result.elem (i, j) = a.elem (i, j); - else - result.elem (i, j) = b.elem (i, j); - } - - return result; -} - -static void -get_dimensions (const tree_constant& a, const char *warn_for, - int& nr, int& nc) -{ - tree_constant tmpa = a.make_numeric (); - - if (tmpa.is_scalar_type ()) - { - double tmp = tmpa.double_value (); - nr = nc = NINT (tmp); - } - else - { - nr = tmpa.rows (); - nc = tmpa.columns (); - - if ((nr == 1 && nc == 2) || (nr == 2 && nc == 1)) - { - ColumnVector v = tmpa.to_vector (); - - nr = NINT (v.elem (0)); - nc = NINT (v.elem (1)); - } - else - warning ("%s (A): use %s (size (A)) instead", warn_for, warn_for); - } - - check_dimensions (nr, nc, warn_for); // May set error_state. -} - -static void -get_dimensions (const tree_constant& a, const tree_constant& b, - const char *warn_for, int& nr, int& nc) -{ - tree_constant tmpa = a.make_numeric (); - tree_constant tmpb = b.make_numeric (); - - if (tmpa.is_scalar_type () && tmpb.is_scalar_type ()) - { - nr = NINT (tmpa.double_value ()); - nc = NINT (tmpb.double_value ()); - - check_dimensions (nr, nc, warn_for); // May set error_state. - } - else - error ("%s: expecting two scalar arguments", warn_for); -} - -tree_constant -fill_matrix (const tree_constant& a, double val, const char *warn_for) -{ - int nr, nc; - get_dimensions (a, warn_for, nr, nc); - - if (error_state) - return tree_constant (); - - Matrix m (nr, nc, val); - - return tree_constant (m); -} - -tree_constant -fill_matrix (const tree_constant& a, const tree_constant& b, - double val, const char *warn_for) -{ - int nr, nc; - get_dimensions (a, b, warn_for, nr, nc); // May set error_state. - - if (error_state) - return tree_constant (); - - Matrix m (nr, nc, val); - - return tree_constant (m); -} - -tree_constant -identity_matrix (const tree_constant& a) -{ - int nr, nc; - get_dimensions (a, "eye", nr, nc); // May set error_state. - - if (error_state) - return tree_constant (); - - Matrix m (nr, nc, 0.0); - - if (nr > 0 && nc > 0) - { - int n = MIN (nr, nc); - for (int i = 0; i < n; i++) - m.elem (i, i) = 1.0; - } - - return tree_constant (m); -} - -tree_constant -identity_matrix (const tree_constant& a, const tree_constant& b) -{ - int nr, nc; - get_dimensions (a, b, "eye", nr, nc); // May set error_state. - - if (error_state) - return tree_constant (); - - Matrix m (nr, nc, 0.0); - - if (nr > 0 && nc > 0) - { - int n = MIN (nr, nc); - for (int i = 0; i < n; i++) - m.elem (i, i) = 1.0; - } - - return tree_constant (m); -} - -static tree_constant -find_nonzero_elem_idx (const Matrix& m) -{ - int count = 0; - int m_nr = m.rows (); - int m_nc = m.columns (); - - int i; - for (int j = 0; j < m_nc; j++) - for (i = 0; i < m_nr; i++) - if (m.elem (i, j) != 0) - count++; - - Matrix result; - - if (count == 0) - return result; - - if (m_nr == 1) - { - result.resize (1, count); - count = 0; - for (j = 0; j < m_nc; j++) - if (m.elem (0, j) != 0) - { - result (0, count) = j + 1; - count++; - } - return tree_constant (result); - } - else - { - ColumnVector v (count); - count = 0; - for (j = 0; j < m_nc; j++) - for (i = 0; i < m_nr; i++) - if (m.elem (i, j) != 0) - { - v.elem (count) = m_nr * j + i + 1; - count++; - } - return tree_constant (v, 1); // Always make a column vector. - } -} - -static tree_constant -find_nonzero_elem_idx (const ComplexMatrix& m) -{ - int count = 0; - int m_nr = m.rows (); - int m_nc = m.columns (); - - for (int j = 0; j < m_nc; j++) - { - for (int i = 0; i < m_nr; i++) - if (m.elem (i, j) != 0) - count++; - } - - Matrix result; - - if (count == 0) - return result; - - if (m_nr == 1) - { - result.resize (1, count); - count = 0; - for (j = 0; j < m_nc; j++) - if (m.elem (0, j) != 0) - { - result (0, count) = j + 1; - count++; - } - return tree_constant (result); - } - else - { - ColumnVector v (count); - count = 0; - for (j = 0; j < m_nc; j++) - { - for (int i = 0; i < m_nr; i++) - if (m.elem (i, j) != 0) - { - v.elem (count) = m_nr * j + i + 1; - count++; - } - } - return tree_constant (v, 1); // Always make a column vector. - } -} - -tree_constant -find_nonzero_elem_idx (const tree_constant& a) -{ - tree_constant retval; - - tree_constant tmp = a.make_numeric (); - - Matrix result; - - switch (tmp.const_type ()) - { - case tree_constant_rep::matrix_constant: - { - Matrix m = tmp.matrix_value (); - return find_nonzero_elem_idx (m); - } - break; - case tree_constant_rep::scalar_constant: - { - double d = tmp.double_value (); - if (d != 0.0) - return tree_constant (1.0); - else - return tree_constant (result); - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = tmp.complex_matrix_value (); - return find_nonzero_elem_idx (m); - } - break; - case tree_constant_rep::complex_scalar_constant: - { - Complex c = tmp.complex_value (); - if (c != 0.0) - return tree_constant (1.0); - else - return tree_constant (result); - } - break; - default: - break; - } - return retval; -} - -// XXX FIXME XXX -- the next two functions (and expm) should really be just -// one... - -tree_constant * -matrix_log (const tree_constant& a) -{ - tree_constant *retval = new tree_constant [2]; - - tree_constant tmp = a.make_numeric ();; - - if (tmp.rows () == 0 || tmp.columns () == 0) - { - int flag = user_pref.propagate_empty_matrices; - if (flag != 0) - { - if (flag < 0) - gripe_empty_arg ("logm", 0); - Matrix m; - retval = new tree_constant [2]; - retval[0] = tree_constant (m); - return retval; - } - else - gripe_empty_arg ("logm", 1); - } - - switch (tmp.const_type ()) - { - case tree_constant_rep::matrix_constant: - { - Matrix m = tmp.matrix_value (); - - int nr = m.rows (); - int nc = m.columns (); - - if (nr == 0 || nc == 0 || nr != nc) - gripe_square_matrix_required ("logm"); - else - { - EIG m_eig (m); - ComplexColumnVector lambda (m_eig.eigenvalues ()); - ComplexMatrix Q (m_eig.eigenvectors ()); - - for (int i = 0; i < nr; i++) - { - Complex elt = lambda.elem (i); - if (imag (elt) == 0.0 && real (elt) > 0.0) - lambda.elem (i) = log (real (elt)); - else - lambda.elem (i) = log (elt); - } - - ComplexDiagMatrix D (lambda); - ComplexMatrix result = Q * D * Q.inverse (); - - retval[0] = tree_constant (result); - } - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = tmp.complex_matrix_value (); - - int nr = m.rows (); - int nc = m.columns (); - - if (nr == 0 || nc == 0 || nr != nc) - gripe_square_matrix_required ("logm"); - else - { - EIG m_eig (m); - ComplexColumnVector lambda (m_eig.eigenvalues ()); - ComplexMatrix Q (m_eig.eigenvectors ()); - - for (int i = 0; i < nr; i++) - { - Complex elt = lambda.elem (i); - if (imag (elt) == 0.0 && real (elt) > 0.0) - lambda.elem (i) = log (real (elt)); - else - lambda.elem (i) = log (elt); - } - - ComplexDiagMatrix D (lambda); - ComplexMatrix result = Q * D * Q.inverse (); - - retval[0] = tree_constant (result); - } - } - break; - case tree_constant_rep::scalar_constant: - { - double d = tmp.double_value (); - if (d > 0.0) - retval[0] = tree_constant (log (d)); - else - { - Complex dtmp (d); - retval[0] = tree_constant (log (dtmp)); - } - } - break; - case tree_constant_rep::complex_scalar_constant: - { - Complex c = tmp.complex_value (); - retval[0] = tree_constant (log (c)); - } - break; - default: - break; - } - return retval; -} - -tree_constant * -matrix_sqrt (const tree_constant& a) -{ - tree_constant *retval = new tree_constant [2]; - - tree_constant tmp = a.make_numeric ();; - - if (tmp.rows () == 0 || tmp.columns () == 0) - { - int flag = user_pref.propagate_empty_matrices; - if (flag != 0) - { - if (flag < 0) - gripe_empty_arg ("sqrtm", 0); - Matrix m; - retval = new tree_constant [2]; - retval[0] = tree_constant (m); - return retval; - } - else - gripe_empty_arg ("sqrtm", 1); - } - - switch (tmp.const_type ()) - { - case tree_constant_rep::matrix_constant: - { - Matrix m = tmp.matrix_value (); - - int nr = m.rows (); - int nc = m.columns (); - - if (nr == 0 || nc == 0 || nr != nc) - gripe_square_matrix_required ("sqrtm"); - else - { - EIG m_eig (m); - ComplexColumnVector lambda (m_eig.eigenvalues ()); - ComplexMatrix Q (m_eig.eigenvectors ()); - - for (int i = 0; i < nr; i++) - { - Complex elt = lambda.elem (i); - if (imag (elt) == 0.0 && real (elt) > 0.0) - lambda.elem (i) = sqrt (real (elt)); - else - lambda.elem (i) = sqrt (elt); - } - - ComplexDiagMatrix D (lambda); - ComplexMatrix result = Q * D * Q.inverse (); - - retval[0] = tree_constant (result); - } - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = tmp.complex_matrix_value (); - - int nr = m.rows (); - int nc = m.columns (); - - if (nr == 0 || nc == 0 || nr != nc) - gripe_square_matrix_required ("sqrtm"); - else - { - EIG m_eig (m); - ComplexColumnVector lambda (m_eig.eigenvalues ()); - ComplexMatrix Q (m_eig.eigenvectors ()); - - for (int i = 0; i < nr; i++) - { - Complex elt = lambda.elem (i); - if (imag (elt) == 0.0 && real (elt) > 0.0) - lambda.elem (i) = sqrt (real (elt)); - else - lambda.elem (i) = sqrt (elt); - } - - ComplexDiagMatrix D (lambda); - ComplexMatrix result = Q * D * Q.inverse (); - - retval[0] = tree_constant (result); - } - } - break; - case tree_constant_rep::scalar_constant: - { - double d = tmp.double_value (); - if (d > 0.0) - retval[0] = tree_constant (sqrt (d)); - else - { - Complex dtmp (d); - retval[0] = tree_constant (sqrt (dtmp)); - } - } - break; - case tree_constant_rep::complex_scalar_constant: - { - Complex c = tmp.complex_value (); - retval[0] = tree_constant (log (c)); - } - break; - default: - break; - } - return retval; -} - -tree_constant * -column_max (const tree_constant *args, int nargin, int nargout) -{ - tree_constant *retval = NULL_TREE_CONST; - - tree_constant arg1; - tree_constant arg2; - tree_constant_rep::constant_type arg1_type = - tree_constant_rep::unknown_constant; - tree_constant_rep::constant_type arg2_type = - tree_constant_rep::unknown_constant; - - switch (nargin) - { - case 3: - arg2 = args[2].make_numeric (); - arg2_type = arg2.const_type (); -// Fall through... - case 2: - arg1 = args[1].make_numeric (); - arg1_type = arg1.const_type (); - break; - default: - panic_impossible (); - break; - } - - if (nargin == 2 && nargout == 1) - { - retval = new tree_constant [2]; - switch (arg1_type) - { - case tree_constant_rep::scalar_constant: - retval[0] = tree_constant (arg1.double_value ()); - break; - case tree_constant_rep::complex_scalar_constant: - retval[0] = tree_constant (arg1.complex_value ()); - break; - case tree_constant_rep::matrix_constant: - { - Matrix m = arg1.matrix_value (); - if (m.rows () == 1) - retval[0] = tree_constant (m.row_max ()); - else - retval[0] = tree_constant (m.column_max (), 0); - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = arg1.complex_matrix_value (); - if (m.rows () == 1) - retval[0] = tree_constant (m.row_max ()); - else - retval[0] = tree_constant (m.column_max (), 0); - } - break; - default: - panic_impossible (); - break; - } - } - else if (nargin == 2 && nargout == 2) - { - retval = new tree_constant [2]; - switch (arg1_type) - { - case tree_constant_rep::scalar_constant: - { - retval[0] = tree_constant (arg1.double_value ()); - retval[1] = tree_constant (1); - } - break; - case tree_constant_rep::complex_scalar_constant: - { - retval[0] = tree_constant (arg1.complex_value ()); - retval[1] = tree_constant (1); - } - break; - case tree_constant_rep::matrix_constant: - { - Matrix m = arg1.matrix_value (); - if (m.rows () == 1) - { - retval[0] = tree_constant (m.row_max ()); - retval[1] = tree_constant (m.row_max_loc ()); - } - else - { - retval[0] = tree_constant (m.column_max (), 0); - retval[1] = tree_constant (m.column_max_loc (), 0); - } - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = arg1.complex_matrix_value (); - if (m.rows () == 1) - { - retval[0] = tree_constant (m.row_max ()); - retval[1] = tree_constant (m.row_max_loc ()); - } - else - { - retval[0] = tree_constant (m.column_max (), 0); - retval[1] = tree_constant (m.column_max_loc (), 0); - } - } - break; - default: - panic_impossible (); - break; - } - } - else if (nargin == 3) - { - if (arg1.rows () == arg2.rows () - && arg1.columns () == arg2.columns ()) - { - retval = new tree_constant [2]; - switch (arg1_type) - { - case tree_constant_rep::scalar_constant: - { - double result; - double a_elem = arg1.double_value (); - double b_elem = arg2.double_value (); - result = MAX (a_elem, b_elem); - retval[0] = tree_constant (result); - } - break; - case tree_constant_rep::complex_scalar_constant: - { - Complex result; - Complex a_elem = arg1.complex_value (); - Complex b_elem = arg2.complex_value (); - if (abs (a_elem) > abs (b_elem)) - result = a_elem; - else - result = b_elem; - retval[0] = tree_constant (result); - } - break; - case tree_constant_rep::matrix_constant: - { - Matrix result; - result = max (arg1.matrix_value (), arg2.matrix_value ()); - retval[0] = tree_constant (result); - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix result; - result = max (arg1.complex_matrix_value (), - arg2.complex_matrix_value ()); - retval[0] = tree_constant (result); - } - break; - default: - panic_impossible (); - break; - } - } - else - error ("max: nonconformant matrices"); - } - else - panic_impossible (); - - return retval; -} - -tree_constant * -column_min (const tree_constant *args, int nargin, int nargout) -{ - tree_constant *retval = NULL_TREE_CONST; - - tree_constant arg1; - tree_constant arg2; - tree_constant_rep::constant_type arg1_type = - tree_constant_rep::unknown_constant; - tree_constant_rep::constant_type arg2_type = - tree_constant_rep::unknown_constant; - - switch (nargin) - { - case 3: - arg2 = args[2].make_numeric (); - arg2_type = arg2.const_type (); -// Fall through... - case 2: - arg1 = args[1].make_numeric (); - arg1_type = arg1.const_type (); - break; - default: - panic_impossible (); - break; - } - - if (nargin == 2 && nargout == 1) - { - retval = new tree_constant [2]; - switch (arg1_type) - { - case tree_constant_rep::scalar_constant: - retval[0] = tree_constant (arg1.double_value ()); - break; - case tree_constant_rep::complex_scalar_constant: - retval[0] = tree_constant (arg1.complex_value ()); - break; - case tree_constant_rep::matrix_constant: - { - Matrix m = arg1.matrix_value (); - if (m.rows () == 1) - retval[0] = tree_constant (m.row_min ()); - else - retval[0] = tree_constant (m.column_min (), 0); - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = arg1.complex_matrix_value (); - if (m.rows () == 1) - retval[0] = tree_constant (m.row_min ()); - else - retval[0] = tree_constant (m.column_min (), 0); - } - break; - default: - panic_impossible (); - break; - } - } - else if (nargin == 2 && nargout == 2) - { - retval = new tree_constant [2]; - switch (arg1_type) - { - case tree_constant_rep::scalar_constant: - { - retval[0] = tree_constant (arg1.double_value ()); - retval[1] = tree_constant (1); - } - break; - case tree_constant_rep::complex_scalar_constant: - { - retval[0] = tree_constant (arg1.complex_value ()); - retval[1] = tree_constant (1); - } - break; - case tree_constant_rep::matrix_constant: - { - Matrix m = arg1.matrix_value (); - if (m.rows () == 1) - { - retval[0] = tree_constant (m.row_min ()); - retval[1] = tree_constant (m.row_min_loc ()); - } - else - { - retval[0] = tree_constant (m.column_min (), 0); - retval[1] = tree_constant (m.column_min_loc (), 0); - } - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix m = arg1.complex_matrix_value (); - if (m.rows () == 1) - { - retval[0] = tree_constant (m.row_min ()); - retval[1] = tree_constant (m.row_min_loc ()); - } - else - { - retval[0] = tree_constant (m.column_min (), 0); - retval[1] = tree_constant (m.column_min_loc (), 0); - } - } - break; - default: - panic_impossible (); - break; - } - } - else if (nargin == 3) - { - if (arg1.rows () == arg2.rows () - && arg1.columns () == arg2.columns ()) - { - retval = new tree_constant [2]; - switch (arg1_type) - { - case tree_constant_rep::scalar_constant: - { - double result; - double a_elem = arg1.double_value (); - double b_elem = arg2.double_value (); - result = MIN (a_elem, b_elem); - retval[0] = tree_constant (result); - } - break; - case tree_constant_rep::complex_scalar_constant: - { - Complex result; - Complex a_elem = arg1.complex_value (); - Complex b_elem = arg2.complex_value (); - if (abs (a_elem) < abs (b_elem)) - result = a_elem; - else - result = b_elem; - retval[0] = tree_constant (result); - } - break; - case tree_constant_rep::matrix_constant: - { - Matrix result; - result = min (arg1.matrix_value (), arg2.matrix_value ()); - retval[0] = tree_constant (result); - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix result; - result = min (arg1.complex_matrix_value (), - arg2.complex_matrix_value ()); - retval[0] = tree_constant (result); - } - break; - default: - panic_impossible (); - break; - } - } - else - error ("min: nonconformant matrices"); - } - else - panic_impossible (); - - return retval; -} - -static void -mx_sort (Matrix& m, Matrix& idx, int return_idx) -{ - int nr = m.rows (); - int nc = m.columns (); - idx.resize (nr, nc); - int i, j; - - if (return_idx) - { - for (j = 0; j < nc; j++) - for (i = 0; i < nr; i++) - idx.elem (i, j) = i+1; - } - - for (j = 0; j < nc; j++) - { - for (int gap = nr/2; gap > 0; gap /= 2) - for (i = gap; i < nr; i++) - for (int k = i - gap; - k >= 0 && m.elem (k, j) > m.elem (k+gap, j); - k -= gap) - { - double tmp = m.elem (k, j); - m.elem (k, j) = m.elem (k+gap, j); - m.elem (k+gap, j) = tmp; - - if (return_idx) - { - double tmp = idx.elem (k, j); - idx.elem (k, j) = idx.elem (k+gap, j); - idx.elem (k+gap, j) = tmp; - } - } - } -} - -static void -mx_sort (RowVector& v, RowVector& idx, int return_idx) -{ - int n = v.capacity (); - idx.resize (n); - int i; - - if (return_idx) - for (i = 0; i < n; i++) - idx.elem (i) = i+1; - - for (int gap = n/2; gap > 0; gap /= 2) - for (i = gap; i < n; i++) - for (int k = i - gap; - k >= 0 && v.elem (k) > v.elem (k+gap); - k -= gap) - { - double tmp = v.elem (k); - v.elem (k) = v.elem (k+gap); - v.elem (k+gap) = tmp; - - if (return_idx) - { - double tmp = idx.elem (k); - idx.elem (k) = idx.elem (k+gap); - idx.elem (k+gap) = tmp; - } - } -} - -static void -mx_sort (ComplexMatrix& cm, Matrix& idx, int return_idx) -{ - int nr = cm.rows (); - int nc = cm.columns (); - idx.resize (nr, nc); - int i, j; - - if (return_idx) - { - for (j = 0; j < nc; j++) - for (i = 0; i < nr; i++) - idx.elem (i, j) = i+1; - } - - for (j = 0; j < nc; j++) - { - for (int gap = nr/2; gap > 0; gap /= 2) - for (i = gap; i < nr; i++) - for (int k = i - gap; - k >= 0 && abs (cm.elem (k, j)) > abs (cm.elem (k+gap, j)); - k -= gap) - { - Complex ctmp = cm.elem (k, j); - cm.elem (k, j) = cm.elem (k+gap, j); - cm.elem (k+gap, j) = ctmp; - - if (return_idx) - { - double tmp = idx.elem (k, j); - idx.elem (k, j) = idx.elem (k+gap, j); - idx.elem (k+gap, j) = tmp; - } - } - } -} - -static void -mx_sort (ComplexRowVector& cv, RowVector& idx, int return_idx) -{ - int n = cv.capacity (); - idx.resize (n); - int i; - - if (return_idx) - for (i = 0; i < n; i++) - idx.elem (i) = i+1; - - for (int gap = n/2; gap > 0; gap /= 2) - for (i = gap; i < n; i++) - for (int k = i - gap; - k >= 0 && abs (cv.elem (k)) > abs (cv.elem (k+gap)); - k -= gap) - { - Complex tmp = cv.elem (k); - cv.elem (k) = cv.elem (k+gap); - cv.elem (k+gap) = tmp; - - if (return_idx) - { - double tmp = idx.elem (k); - idx.elem (k) = idx.elem (k+gap); - idx.elem (k+gap) = tmp; - } - } -} - -tree_constant * -sort (const tree_constant *args, int nargin, int nargout) -{ -// Assumes that we have been given the correct number of arguments. - - tree_constant *retval = NULL_TREE_CONST; - - int return_idx = nargout > 1; - if (return_idx) - retval = new tree_constant [3]; - else - retval = new tree_constant [2]; - - switch (args[1].const_type ()) - { - case tree_constant_rep::scalar_constant: - { - retval [0] = tree_constant (args[1].double_value ()); - if (return_idx) - retval [1] = tree_constant (1.0); - } - break; - case tree_constant_rep::complex_scalar_constant: - { - retval [0] = tree_constant (args[1].complex_value ()); - if (return_idx) - retval [1] = tree_constant (1.0); - } - break; - case tree_constant_rep::string_constant: - case tree_constant_rep::range_constant: - case tree_constant_rep::matrix_constant: - { - Matrix m = args[1].to_matrix (); - if (m.rows () == 1) - { - int nc = m.columns (); - RowVector v (nc); - for (int i = 0; i < nc; i++) - v.elem (i) = m.elem (0, i); - RowVector idx; - mx_sort (v, idx, return_idx); - - retval [0] = tree_constant (v, 0); - if (return_idx) - retval [1] = tree_constant (idx, 0); - } - else - { -// Sorts m in place, optionally computes index Matrix. - Matrix idx; - mx_sort (m, idx, return_idx); - - retval [0] = tree_constant (m); - if (return_idx) - retval [1] = tree_constant (idx); - } - } - break; - case tree_constant_rep::complex_matrix_constant: - { - ComplexMatrix cm = args[1].complex_matrix_value (); - if (cm.rows () == 1) - { - int nc = cm.columns (); - ComplexRowVector cv (nc); - for (int i = 0; i < nc; i++) - cv.elem (i) = cm.elem (0, i); - RowVector idx; - mx_sort (cv, idx, return_idx); - - retval [0] = tree_constant (cv, 0); - if (return_idx) - retval [1] = tree_constant (idx, 0); - } - else - { -// Sorts cm in place, optionally computes index Matrix. - Matrix idx; - mx_sort (cm, idx, return_idx); - - retval [0] = tree_constant (cm); - if (return_idx) - retval [1] = tree_constant (idx); - } - } - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant * -feval (const tree_constant *args, int nargin, int nargout) -{ -// Assumes that we have been given the correct number of arguments. - - tree_constant *retval = NULL_TREE_CONST; - - tree *fcn = is_valid_function (args[1], "feval", 1); - if (fcn != NULL_TREE) - { - args++; - nargin--; - if (nargin > 1) - retval = fcn->eval (args, nargin, nargout, 0); - else - retval = fcn->eval (0, nargout); - } - - return retval; -} - -tree_constant -eval_string (const char *string, int print, int ans_assign, - int& parse_status) -{ - begin_unwind_frame ("eval_string"); - - unwind_protect_int (get_input_from_eval_string); - unwind_protect_ptr (global_command); - unwind_protect_ptr (current_eval_string); - - get_input_from_eval_string = 1; - current_eval_string = string; - - YY_BUFFER_STATE old_buf = current_buffer (); - YY_BUFFER_STATE new_buf = create_buffer ((FILE *) NULL); - - add_unwind_protect (restore_input_buffer, (void *) old_buf); - add_unwind_protect (delete_input_buffer, (void *) new_buf); - - switch_to_buffer (new_buf); - - unwind_protect_ptr (curr_sym_tab); - - reset_parser (); - - parse_status = yyparse (); - -// Important to reset the idea of where input is coming from before -// trying to eval the command we just parsed -- it might contain the -// name of an function file that still needs to be parsed! - - tree *command = global_command; - - run_unwind_frame ("eval_string"); - - tree_constant retval; - - if (parse_status == 0 && command != NULL_TREE) - { - retval = command->eval (print); - delete command; - } - - return retval; -} - -tree_constant -eval_string (const tree_constant& arg, int& parse_status) -{ - if (! arg.is_string_type ()) - { - error ("eval: expecting string argument"); - return -1; - } - - char *string = arg.string_value (); - -// Yes Virginia, we always print here... - - return eval_string (string, 1, 1, parse_status); -} - -static int -match_sans_spaces (const char *standard, const char *test) -{ - const char *tp = test; - while (*tp == ' ' || *tp == '\t') - tp++; - - const char *ep = test + strlen (test) - 1; - while (*ep == ' ' || *ep == '\t') - ep--; - - int len = ep - tp + 1; - - return (strncmp (standard, tp, len) == 0); -} - -tree_constant -get_user_input (const tree_constant *args, int nargin, int nargout, - int debug = 0) -{ - tree_constant retval; - - int read_as_string = 0; - if (nargin == 3) - { - if (args[2].is_string_type () - && strcmp ("s", args[2].string_value ()) == 0) - read_as_string++; - else - { - error ("input: unrecognized second argument"); - return retval; - } - } - - char *prompt = "debug> "; - if (nargin > 1) - { - if (args[1].is_string_type ()) - prompt = args[1].string_value (); - else - { - error ("input: unrecognized argument"); - return retval; - } - } - - again: - - flush_output_to_pager (); - - char *input_buf = gnu_readline (prompt); - - if (input_buf != (char *) NULL) - { - if (input_buf) - maybe_save_history (input_buf); - - int len = strlen (input_buf); - - if (len < 1) - { - if (debug) - goto again; - else - return retval; - } - - if (match_sans_spaces ("exit", input_buf) - || match_sans_spaces ("quit", input_buf) - || match_sans_spaces ("return", input_buf)) - return tree_constant (); - else if (read_as_string) - retval = tree_constant (input_buf); - else - { - int parse_status; - retval = eval_string (input_buf, 0, 0, parse_status); - if (debug && retval.is_defined ()) - retval.eval (1); - } - } - else - error ("input: reading user-input failed!"); - - if (debug) - goto again; - - return retval; -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/tc-index.cc Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1306 +0,0 @@ -// tc-index.cc -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif - -#include "idx-vector.h" -#include "user-prefs.h" -#include "tree-const.h" -#include "utils.h" -#include "gripes.h" -#include "error.h" - -#include "tc-inlines.cc" - -int -tree_constant_rep::valid_as_scalar_index (void) const -{ - int valid = type_tag == magic_colon - || (type_tag == scalar_constant && NINT (scalar) == 1) - || (type_tag == range_constant - && range->nelem () == 1 && NINT (range->base ()) == 1); - - return valid; -} - -tree_constant -tree_constant_rep::do_scalar_index (const tree_constant *args, - int nargs) const -{ - if (valid_scalar_indices (args, nargs)) - { - if (type_tag == scalar_constant) - return tree_constant (scalar); - else if (type_tag == complex_scalar_constant) - return tree_constant (*complex_scalar); - else - panic_impossible (); - } - else - { - int rows = 0; - int cols = 0; - - switch (nargs) - { - case 3: - { - if (args[2].is_matrix_type ()) - { - Matrix mj = args[2].matrix_value (); - - idx_vector j (mj, user_pref.do_fortran_indexing, ""); - if (! j) - return tree_constant (); - - int len = j.length (); - if (len == j.ones_count ()) - cols = len; - } - else if (args[2].const_type () == magic_colon - || (args[2].is_scalar_type () - && NINT (args[2].double_value ()) == 1)) - { - cols = 1; - } - else - break; - } -// Fall through... - case 2: - { - if (args[1].is_matrix_type ()) - { - Matrix mi = args[1].matrix_value (); - - idx_vector i (mi, user_pref.do_fortran_indexing, ""); - if (! i) - return tree_constant (); - - int len = i.length (); - if (len == i.ones_count ()) - rows = len; - } - else if (args[1].const_type () == magic_colon - || (args[1].is_scalar_type () - && NINT (args[1].double_value ()) == 1)) - { - rows = 1; - } - else if (args[1].is_scalar_type () - && NINT (args[1].double_value ()) == 0) - { - Matrix m (0, 0); - return tree_constant (m); - } - else - break; - - if (cols == 0) - { - if (user_pref.prefer_column_vectors) - cols = 1; - else - { - cols = rows; - rows = 1; - } - } - - if (type_tag == scalar_constant) - { - Matrix m (rows, cols, scalar); - return tree_constant (m); - } - else if (type_tag == complex_scalar_constant) - { - ComplexMatrix cm (rows, cols, *complex_scalar); - return tree_constant (cm); - } - else - panic_impossible (); - } - break; - default: - ::error ("illegal number of arguments for scalar type"); - return tree_constant (); - break; - } - } - - ::error ("index invalid or out of range for scalar type"); - return tree_constant (); -} - -tree_constant -tree_constant_rep::do_matrix_index (const tree_constant *args, - int nargin) const -{ - tree_constant retval; - - switch (nargin) - { - case 2: - if (args == NULL_TREE_CONST) - ::error ("matrix index is null"); - else if (args[1].is_undefined ()) - ::error ("matrix index is a null expression"); - else - retval = do_matrix_index (args[1]); - break; - case 3: - if (args == NULL_TREE_CONST) - ::error ("matrix indices are null"); - else if (args[1].is_undefined ()) - ::error ("first matrix index is a null expression"); - else if (args[2].is_undefined ()) - ::error ("second matrix index is a null expression"); - else - retval = do_matrix_index (args[1], args[2]); - break; - default: - ::error ("too many indices for matrix expression"); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const tree_constant& i_arg) const -{ - tree_constant retval; - - int nr = rows (); - int nc = columns (); - - if (user_pref.do_fortran_indexing) - retval = fortran_style_matrix_index (i_arg); - else if (nr <= 1 || nc <= 1) - retval = do_vector_index (i_arg); - else - ::error ("single index only valid for row or column vector"); - - return retval; -} - -tree_constant -tree_constant_rep::fortran_style_matrix_index - (const tree_constant& i_arg) const -{ - tree_constant retval; - - tree_constant tmp_i = i_arg.make_numeric_or_magic (); - - tree_constant_rep::constant_type itype = tmp_i.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = NINT (tmp_i.double_value ()); - int ii = fortran_row (i, nr) - 1; - int jj = fortran_column (i, nr) - 1; - if (index_check (i-1, "") < 0) - return tree_constant (); - if (range_max_check (i-1, nr * nc) < 0) - return tree_constant (); - retval = do_matrix_index (ii, jj); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - if (mi.rows () == 0 || mi.columns () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { -// Yes, we really do want to call this with mi. - retval = fortran_style_matrix_index (mi); - } - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - gripe_range_invalid (); - break; - case magic_colon: - retval = do_matrix_index (magic_colon); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::fortran_style_matrix_index (const Matrix& mi) const -{ - assert (is_matrix_type ()); - - tree_constant retval; - - int nr = rows (); - int nc = columns (); - - int len = nr * nc; - - int index_nr = mi.rows (); - int index_nc = mi.columns (); - - if (index_nr >= 1 && index_nc >= 1) - { - const double *cop_out = (const double *) NULL; - const Complex *c_cop_out = (const Complex *) NULL; - int real_type = type_tag == matrix_constant; - if (real_type) - cop_out = matrix->data (); - else - c_cop_out = complex_matrix->data (); - - const double *cop_out_index = mi.data (); - - idx_vector iv (mi, 1, "", len); - if (! iv) - return tree_constant (); - - int result_size = iv.length (); - - if (nc == 1 || (nr != 1 && iv.one_zero_only ())) - { - CRMATRIX (m, cm, result_size, 1); - - for (int i = 0; i < result_size; i++) - { - int idx = iv.elem (i); - CRMATRIX_ASSIGN_ELEM (m, cm, i, 0, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - else if (nr == 1) - { - CRMATRIX (m, cm, 1, result_size); - - for (int i = 0; i < result_size; i++) - { - int idx = iv.elem (i); - CRMATRIX_ASSIGN_ELEM (m, cm, 0, i, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - else - { - CRMATRIX (m, cm, index_nr, index_nc); - - for (int j = 0; j < index_nc; j++) - for (int i = 0; i < index_nr; i++) - { - double tmp = *cop_out_index++; - int idx = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_ELEM (m, cm, i, j, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - } - else - { - if (index_nr == 0 || index_nc == 0) - ::error ("empty matrix invalid as index"); - else - ::error ("invalid matrix index"); - return tree_constant (); - } - - return retval; -} - -tree_constant -tree_constant_rep::do_vector_index (const tree_constant& i_arg) const -{ - tree_constant retval; - - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type itype = tmp_i.const_type (); - - int nr = rows (); - int nc = columns (); - - int len = nr > nc ? nr : nc; - - if (nr == 0 || nc == 0) - { - ::error ("attempt to index empty matrix"); - return retval; - } - - assert ((nr == 1 || nc == 1) && ! user_pref.do_fortran_indexing); - - int swap_indices = (nr == 1); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - if (index_check (i, "") < 0) - return tree_constant (); - if (swap_indices) - { - if (range_max_check (i, nc) < 0) - return tree_constant (); - retval = do_matrix_index (0, i); - } - else - { - if (range_max_check (i, nr) < 0) - return tree_constant (); - retval = do_matrix_index (i, 0); - } - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - if (mi.rows () == 0 || mi.columns () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - idx_vector iv (mi, user_pref.do_fortran_indexing, "", len); - if (! iv) - return tree_constant (); - - if (swap_indices) - { - if (range_max_check (iv.max (), nc) < 0) - return tree_constant (); - retval = do_matrix_index (0, iv); - } - else - { - if (range_max_check (iv.max (), nr) < 0) - return tree_constant (); - retval = do_matrix_index (iv, 0); - } - } - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range ri = tmp_i.range_value (); - if (len == 2 && is_zero_one (ri)) - { - if (swap_indices) - retval = do_matrix_index (0, 1); - else - retval = do_matrix_index (1, 0); - } - else if (len == 2 && is_one_zero (ri)) - { - retval = do_matrix_index (0, 0); - } - else - { - if (index_check (ri, "") < 0) - return tree_constant (); - if (swap_indices) - { - if (range_max_check (tree_to_mat_idx (ri.max ()), nc) < 0) - return tree_constant (); - retval = do_matrix_index (0, ri); - } - else - { - if (range_max_check (tree_to_mat_idx (ri.max ()), nr) < 0) - return tree_constant (); - retval = do_matrix_index (ri, 0); - } - } - } - break; - case magic_colon: - if (swap_indices) - retval = do_matrix_index (0, magic_colon); - else - retval = do_matrix_index (magic_colon, 0); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const tree_constant& i_arg, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type itype = tmp_i.const_type (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - if (index_check (i, "row") < 0) - return tree_constant (); - retval = do_matrix_index (i, j_arg); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - idx_vector iv (mi, user_pref.do_fortran_indexing, "row", rows ()); - if (! iv) - return tree_constant (); - - if (iv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - retval = do_matrix_index (iv, j_arg); - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range ri = tmp_i.range_value (); - int nr = rows (); - if (nr == 2 && is_zero_one (ri)) - { - retval = do_matrix_index (1, j_arg); - } - else if (nr == 2 && is_one_zero (ri)) - { - retval = do_matrix_index (0, j_arg); - } - else - { - if (index_check (ri, "row") < 0) - return tree_constant (); - retval = do_matrix_index (ri, j_arg); - } - } - break; - case magic_colon: - retval = do_matrix_index (magic_colon, j_arg); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (int i, const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (i, j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (i, jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, jv); - } - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (i, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (i, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (i, tree_to_mat_idx (rj.max ()), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, rj); - } - } - break; - case magic_colon: - if (range_max_check (i, 0, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, magic_colon); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const idx_vector& iv, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (iv.max (), j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (iv.max (), jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, jv); - } - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (iv, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (iv, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (iv.max (), tree_to_mat_idx (rj.max ()), - nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, rj); - } - } - break; - case magic_colon: - if (range_max_check (iv.max (), 0, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, magic_colon); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const Range& ri, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (tree_to_mat_idx (ri.max ()), j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (tree_to_mat_idx (ri.max ()), - jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, jv); - } - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (ri, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (ri, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (tree_to_mat_idx (ri.max ()), - tree_to_mat_idx (rj.max ()), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, rj); - } - } - break; - case magic_colon: - retval = do_matrix_index (ri, magic_colon); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - tree_constant_rep::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (0, j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (magic_colon, j); - } - break; - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (0, jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (magic_colon, jv); - } - } - break; - case string_constant: - gripe_string_invalid (); - break; - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (magic_colon, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (magic_colon, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (0, tree_to_mat_idx (rj.max ()), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (magic_colon, rj); - } - } - break; - case magic_colon: - retval = do_matrix_index (magic_colon, magic_colon); - break; - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (int i, int j) const -{ - tree_constant retval; - - if (type_tag == matrix_constant) - retval = tree_constant (matrix->elem (i, j)); - else - retval = tree_constant (complex_matrix->elem (i, j)); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (int i, const idx_vector& jv) const -{ - tree_constant retval; - - int jlen = jv.capacity (); - - CRMATRIX (m, cm, 1, jlen); - - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, col); - } - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (int i, const Range& rj) const -{ - tree_constant retval; - - int jlen = rj.nelem (); - - CRMATRIX (m, cm, 1, jlen); - - double b = rj.base (); - double increment = rj.inc (); - for (int j = 0; j < jlen; j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, col); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index - (int i, tree_constant_rep::constant_type mcj) const -{ - assert (mcj == magic_colon); - - tree_constant retval; - - int nc = columns (); - - CRMATRIX (m, cm, 1, nc); - - for (int j = 0; j < nc; j++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const idx_vector& iv, int j) const -{ - tree_constant retval; - - int ilen = iv.capacity (); - - CRMATRIX (m, cm, ilen, 1); - - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, row, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const idx_vector& iv, - const idx_vector& jv) const -{ - tree_constant retval; - - int ilen = iv.capacity (); - int jlen = jv.capacity (); - - CRMATRIX (m, cm, ilen, jlen); - - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const idx_vector& iv, - const Range& rj) const -{ - tree_constant retval; - - int ilen = iv.capacity (); - int jlen = rj.nelem (); - - CRMATRIX (m, cm, ilen, jlen); - - double b = rj.base (); - double increment = rj.inc (); - - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - for (int j = 0; j < jlen; j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index - (const idx_vector& iv, tree_constant_rep::constant_type mcj) const -{ - assert (mcj == magic_colon); - - tree_constant retval; - - int nc = columns (); - int ilen = iv.capacity (); - - CRMATRIX (m, cm, ilen, nc); - - for (int j = 0; j < nc; j++) - { - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, j); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const Range& ri, int j) const -{ - tree_constant retval; - - int ilen = ri.nelem (); - - CRMATRIX (m, cm, ilen, 1); - - double b = ri.base (); - double increment = ri.inc (); - for (int i = 0; i < ilen; i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, row, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const Range& ri, - const idx_vector& jv) const -{ - tree_constant retval; - - int ilen = ri.nelem (); - int jlen = jv.capacity (); - - CRMATRIX (m, cm, ilen, jlen); - - double b = ri.base (); - double increment = ri.inc (); - for (int i = 0; i < ilen; i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (const Range& ri, const Range& rj) const -{ - tree_constant retval; - - int ilen = ri.nelem (); - int jlen = rj.nelem (); - - CRMATRIX (m, cm, ilen, jlen); - - double ib = ri.base (); - double iinc = ri.inc (); - double jb = rj.base (); - double jinc = rj.inc (); - - for (int i = 0; i < ilen; i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < jlen; j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index - (const Range& ri, tree_constant_rep::constant_type mcj) const -{ - assert (mcj == magic_colon); - - tree_constant retval; - - int nc = columns (); - - int ilen = ri.nelem (); - - CRMATRIX (m, cm, ilen, nc); - - double ib = ri.base (); - double iinc = ri.inc (); - - for (int i = 0; i < ilen; i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < nc; j++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, j); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, - int j) const -{ - assert (mci == magic_colon); - - tree_constant retval; - - int nr = rows (); - - CRMATRIX (m, cm, nr, 1); - - for (int i = 0; i < nr; i++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, i, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, - const idx_vector& jv) const -{ - assert (mci == magic_colon); - - tree_constant retval; - - int nr = rows (); - int jlen = jv.capacity (); - - CRMATRIX (m, cm, nr, jlen); - - for (int i = 0; i < nr; i++) - { - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, i, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, - const Range& rj) const -{ - assert (mci == magic_colon); - - tree_constant retval; - - int nr = rows (); - int jlen = rj.nelem (); - - CRMATRIX (m, cm, nr, jlen); - - double jb = rj.base (); - double jinc = rj.inc (); - - for (int j = 0; j < jlen; j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - for (int i = 0; i < nr; i++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, i, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -tree_constant_rep::do_matrix_index (tree_constant_rep::constant_type mci, - tree_constant_rep::constant_type mcj) const -{ - assert (mci == magic_colon && mcj == magic_colon); - - return tree_constant (*this); -} - -tree_constant -tree_constant_rep::do_matrix_index - (tree_constant_rep::constant_type mci) const -{ - assert (mci == magic_colon); - - tree_constant retval; - int nr = rows (); - int nc = columns (); - int size = nr * nc; - if (size > 0) - { - CRMATRIX (m, cm, size, 1); - int idx = 0; - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, idx, 0, i, j); - idx++; - } - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - return retval; -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/ -
--- a/src/tc-inlines.h Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,319 +0,0 @@ -// tc-inlines.h -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994, 1995 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. - -*/ - -// Just a coupla more helper functions. - -static inline int -tree_to_mat_idx (double x) -{ - if (x > 0) - return ((int) (x + 0.5) - 1); - else - return ((int) (x - 0.5) - 1); -} - -static inline int -range_max_check (int i, int imax) -{ - i++; - if (i > imax) - { - error ("matrix index = %d exceeds maximum dimension = %d", i, imax); - return -1; - } - return 0; -} - -static inline int -range_max_check (int i, int j, int nr, int nc) -{ - int status = 0; - i++; - if (i > nr) - { - error ("matrix row index = %d exceeds maximum row dimension = %d", - i, nr); - status = -1; - } - - j++; - if (j > nc) - { - error ("matrix column index = %d exceeds maximum column dimension = %d", - j, nc); - status = -1; - } - return status; -} - -static inline int -indexed_assign_conforms (int lhs_nr, int lhs_nc, int rhs_nr, int rhs_nc) -{ - return (lhs_nr == rhs_nr && lhs_nc == rhs_nc); -} - -static inline int -is_one_zero (const Range& r) -{ - double b = r.base (); - double l = r.limit (); - return (r.nelem () == 2 && NINT (b) == 1 && NINT (l) == 0); -} - -static inline int -is_zero_one (const Range& r) -{ - double b = r.base (); - double l = r.limit (); - return (r.nelem () == 2 && NINT (b) == 0 && NINT (l) == 1); -} - -static inline int -index_check (int i, char *rc) -{ - if (i < 0) - { - error ("invalid %s index = %d", rc, i+1); - return -1; - } - return 0; -} - -static inline int -index_check (const Range& r, char *rc) -{ - if (r.nelem () < 1) - { - error ("range invalid as %s index", rc); - return -1; - } - - int imin = tree_to_mat_idx (r.min ()); - - if (imin < 0) - { - error ("invalid %s index = %d", rc, imin+1); - return -1; - } - - return 0; -} - -static inline int -fortran_row (int i, int nr) -{ - int r; - r = i % nr; - if (r == 0) - r = nr; - return r; -} - -static inline int -fortran_column (int i, int nr) -{ - int c; - int r; - r = fortran_row (i, nr); - c = (i - r) / nr + 1; - return c; -} - -// How about a few macros? - -#ifndef TC_REP -#define TC_REP tree_constant::tree_constant_rep -#endif - -#ifndef MAX -#define MAX(a,b) ((a) > (b) ? (a) : (b)) -#endif - -#ifndef MIN -#define MIN(a,b) ((a) < (b) ? (a) : (b)) -#endif - -#ifndef ABS -#define ABS(x) (((x) < 0) ? (-x) : (x)) -#endif - -// The following are used by some of the functions in the -// tree_constant_rep class that must deal with real and complex -// matrices. This was not done with overloaded or virtual functions -// from the Matrix class because there is no clean way to do that -- -// the necessary functions (like elem) need to return values of -// different types... - -// Given a tree_constant, and the names to be used for the real and -// complex matrix and their dimensions, declare a real or complex -// matrix, and initialize it from the tree_constant. Note that m, cm, -// nr, and nc must not be previously declared, and they must not be -// expressions. Since only one of the matrices will be defined after -// this macro is used, only one set of dimesions is declared. - -// This macro only makes sense inside a friend or member function of -// the tree_constant_rep class - -#define REP_RHS_MATRIX(tc,m,cm,nr,nc) \ - int nr = 0; \ - int nc = 0; \ - Matrix m; \ - ComplexMatrix cm; \ - if ((tc).is_real_type ()) \ - { \ - m = (tc).matrix_value (); \ - nr = (m).rows (); \ - nc = (m).columns (); \ - } \ - else if ((tc).is_complex_type ()) \ - { \ - cm = (tc).complex_matrix_value (); \ - nr = (cm).rows (); \ - nc = (cm).columns (); \ - } \ - else \ - { \ - panic_impossible (); \ - } \ - if (error_state) \ - return; - -// Assign a real or complex value to a tree_constant. -// -// This macro only makes sense inside a friend or member function of -// the tree_constant_rep class. - -#define REP_ELEM_ASSIGN(i,j,rval,cval,real_type) \ - do \ - { \ - if (type_tag == TC_REP::matrix_constant) \ - { \ - if (real_type) \ - matrix->elem ((i), (j)) = (rval); \ - else \ - panic_impossible (); \ - } \ - else \ - { \ - if (real_type) \ - complex_matrix->elem ((i), (j)) = (rval); \ - else \ - complex_matrix->elem ((i), (j)) = (cval); \ - } \ - } \ - while (0) - -// Given a real and complex matrix and row and column dimensions, -// declare both and size one of them. Only one of the matrices should -// be used after this macro has been used. - -// This macro only makes sense inside a friend or member function of -// the tree_constant_rep class. - -#define CRMATRIX(m,cm,nr,nc) \ - Matrix m; \ - ComplexMatrix cm; \ - if (type_tag == TC_REP::matrix_constant) \ - (m).resize ((nr), (nc)); \ - else if (type_tag == complex_matrix_constant) \ - (cm).resize ((nr), (nc)); \ - else \ - panic_impossible (); \ - -// Assign a real or complex matrix to a tree constant. - -// This macro only makes sense inside a friend or member function of -// the tree_constant_rep class. - -#define ASSIGN_CRMATRIX_TO(tc,m,cm) \ - do \ - { \ - if (type_tag == matrix_constant) \ - tc = tree_constant (m); \ - else \ - tc = tree_constant (cm); \ - } \ - while (0) - -// Assign an element of this tree_constant_rep's real or complex -// matrix to another real or complex matrix. - -// This macro only makes sense inside a friend or member function of -// the tree_constant_rep class. - -#define CRMATRIX_ASSIGN_REP_ELEM(m,cm,i1,j1,i2,j2) \ - do \ - { \ - if (type_tag == matrix_constant) \ - (m).elem ((i1), (j1)) = matrix->elem ((i2), (j2)); \ - else \ - (cm).elem ((i1), (j1)) = complex_matrix->elem ((i2), (j2)); \ - } \ - while (0) - -// Assign a value to an element of a real or complex matrix. Assumes -// that the lhs and rhs are either both real or both complex types. - -#define CRMATRIX_ASSIGN_ELEM(m,cm,i,j,rval,cval,real_type) \ - do \ - { \ - if (real_type) \ - (m).elem ((i), (j)) = (rval); \ - else \ - (cm).elem ((i), (j)) = (cval); \ - } \ - while (0) - - -// One more... - -static inline int -valid_scalar_indices (const Octave_object& args) -{ - int nargin = args.length (); - - return ((nargin == 2 - && args(1).valid_as_scalar_index () - && args(0).valid_as_scalar_index ()) - || (nargin == 1 - && args(0).valid_as_scalar_index ())); -} - -static inline int -valid_zero_index (const Octave_object& args) -{ - int nargin = args.length (); - - return ((nargin == 2 - && args(1).valid_as_zero_index () - && args(0).valid_as_zero_index ()) - || (nargin == 1 - && args(0).valid_as_zero_index ())); -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/tc-rep-ass.cc Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2503 +0,0 @@ -// tc-rep-ass.cc -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <ctype.h> -#include <string.h> -#include <fstream.h> -#include <iostream.h> -#include <strstream.h> - -#include "mx-base.h" -#include "Range.h" - -#include "arith-ops.h" -#include "variables.h" -#include "sysdep.h" -#include "error.h" -#include "gripes.h" -#include "user-prefs.h" -#include "utils.h" -#include "pager.h" -#include "pr-output.h" -#include "tree-const.h" -#include "idx-vector.h" -#include "oct-map.h" - -#include "tc-inlines.h" - -// Top-level tree-constant function that handles assignments. Only -// decide if the left-hand side is currently a scalar or a matrix and -// hand off to other functions to do the real work. - -void -TC_REP::assign (tree_constant& rhs, const Octave_object& args) -{ - tree_constant rhs_tmp = rhs.make_numeric (); - - if (error_state) - return; - -// This is easier than actually handling assignments to strings. -// An assignment to a range will normally require a conversion to a -// vector since it will normally destroy the equally-spaced property -// of the range elements. - - if (is_defined () && ! is_numeric_type ()) - force_numeric (); - - if (error_state) - return; - - switch (type_tag) - { - case complex_scalar_constant: - case scalar_constant: - case unknown_constant: - do_scalar_assignment (rhs_tmp, args); - break; - - case complex_matrix_constant: - case matrix_constant: - do_matrix_assignment (rhs_tmp, args); - break; - - default: - ::error ("invalid assignment to %s", type_as_string ()); - break; - } -} - -// Assignments to scalars. If resize_on_range_error is true, -// this can convert the left-hand side to a matrix. - -void -TC_REP::do_scalar_assignment (const tree_constant& rhs, - const Octave_object& args) -{ - assert (type_tag == unknown_constant - || type_tag == scalar_constant - || type_tag == complex_scalar_constant); - - int nargin = args.length (); - - if (rhs.is_zero_by_zero ()) - { - if (valid_scalar_indices (args)) - { - if (type_tag == complex_scalar_constant) - delete complex_scalar; - - matrix = new Matrix (0, 0); - type_tag = matrix_constant; - } - else if (! valid_zero_index (args)) - { - ::error ("invalid assigment of empty matrix to scalar"); - return; - } - } - else if (rhs.is_scalar_type () && valid_scalar_indices (args)) - { - if (type_tag == unknown_constant || type_tag == scalar_constant) - { - if (rhs.const_type () == scalar_constant) - { - scalar = rhs.double_value (); - type_tag = scalar_constant; - } - else if (rhs.const_type () == complex_scalar_constant) - { - complex_scalar = new Complex (rhs.complex_value ()); - type_tag = complex_scalar_constant; - } - else - { - ::error ("invalid assignment to scalar"); - return; - } - } - else - { - if (rhs.const_type () == scalar_constant) - { - delete complex_scalar; - scalar = rhs.double_value (); - type_tag = scalar_constant; - } - else if (rhs.const_type () == complex_scalar_constant) - { - *complex_scalar = rhs.complex_value (); - type_tag = complex_scalar_constant; - } - else - { - ::error ("invalid assignment to scalar"); - return; - } - } - } - else if (user_pref.resize_on_range_error) - { - TC_REP::constant_type old_type_tag = type_tag; - - if (type_tag == complex_scalar_constant) - { - Complex *old_complex = complex_scalar; - complex_matrix = new ComplexMatrix (1, 1, *complex_scalar); - type_tag = complex_matrix_constant; - delete old_complex; - } - else if (type_tag == scalar_constant) - { - matrix = new Matrix (1, 1, scalar); - type_tag = matrix_constant; - } - -// If there is an error, the call to do_matrix_assignment should not -// destroy the current value. -// TC_REP::eval(int) will take -// care of converting single element matrices back to scalars. - - do_matrix_assignment (rhs, args); - -// I don't think there's any other way to revert back to unknown -// constant types, so here it is. - - if (old_type_tag == unknown_constant && error_state) - { - if (type_tag == matrix_constant) - delete matrix; - else if (type_tag == complex_matrix_constant) - delete complex_matrix; - - type_tag = unknown_constant; - } - } - else if (nargin > 2 || nargin < 1) - ::error ("invalid index expression for scalar type"); - else - ::error ("index invalid or out of range for scalar type"); -} - -// Assignments to matrices (and vectors). -// -// For compatibility with Matlab, we allow assignment of an empty -// matrix to an expression with empty indices to do nothing. - -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - const Octave_object& args) -{ - assert (type_tag == unknown_constant - || type_tag == matrix_constant - || type_tag == complex_matrix_constant); - - if (type_tag == matrix_constant && rhs.is_complex_type ()) - { - Matrix *old_matrix = matrix; - complex_matrix = new ComplexMatrix (*matrix); - type_tag = complex_matrix_constant; - delete old_matrix; - } - else if (type_tag == unknown_constant) - { - if (rhs.is_complex_type ()) - { - complex_matrix = new ComplexMatrix (); - type_tag = complex_matrix_constant; - } - else - { - matrix = new Matrix (); - type_tag = matrix_constant; - } - } - - int nargin = args.length (); - -// The do_matrix_assignment functions can't handle empty matrices, so -// don't let any pass through here. - switch (nargin) - { - case 1: - { - tree_constant arg = args(0); - - if (arg.is_undefined ()) - ::error ("matrix index is undefined"); - else - do_matrix_assignment (rhs, arg); - } - break; - - case 2: - { - tree_constant arg_a = args(0); - tree_constant arg_b = args(1); - - if (arg_a.is_undefined ()) - ::error ("first matrix index is undefined"); - else if (arg_b.is_undefined ()) - ::error ("second matrix index is undefined"); - else if (arg_a.is_empty () || arg_b.is_empty ()) - { - if (! rhs.is_empty ()) - { - ::error ("in assignment expression, a matrix index is empty"); - ::error ("but the right hand side is not an empty matrix"); - } -// XXX FIXME XXX -- to really be correct here, we should probably -// check to see if the assignment conforms, but that seems like more -// work than it's worth right now... - } - else - do_matrix_assignment (rhs, arg_a, arg_b); - } - break; - - default: - if (nargin == 0) - ::error ("matrix indices expected, but none provided"); - else - ::error ("too many indices for matrix expression"); - break; - } -} - -// Matrix assignments indexed by a single value. - -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - const tree_constant& i_arg) -{ - int nr = rows (); - int nc = columns (); - - if (user_pref.do_fortran_indexing || nr <= 1 || nc <= 1) - { - if (i_arg.is_empty ()) - { - if (! rhs.is_empty ()) - { - ::error ("in assignment expression, matrix index is empty but"); - ::error ("right hand side is not an empty matrix"); - } -// XXX FIXME XXX -- to really be correct here, we should probably -// check to see if the assignment conforms, but that seems like more -// work than it's worth right now... - -// The assignment functions can't handle empty matrices, so don't let -// any pass through here. - return; - } - -// We can't handle the case of assigning to a vector first, since even -// then, the two operations are not equivalent. For example, the -// expression V(:) = M is handled differently depending on whether the -// user specified do_fortran_indexing = "true". - - if (user_pref.do_fortran_indexing) - fortran_style_matrix_assignment (rhs, i_arg); - else if (nr <= 1 || nc <= 1) - vector_assignment (rhs, i_arg); - else - panic_impossible (); - } - else - ::error ("single index only valid for row or column vector"); -} - -// Fortran-style assignments. Matrices are assumed to be stored in -// column-major order and it is ok to use a single index for -// multi-dimensional matrices. - -void -TC_REP::fortran_style_matrix_assignment (const tree_constant& rhs, - const tree_constant& i_arg) -{ - tree_constant tmp_i = i_arg.make_numeric_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type itype = tmp_i.const_type (); - - int nr = rows (); - int nc = columns (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - double dval = tmp_i.double_value (); - - if (xisnan (dval)) - { - error ("NaN is invalid as a matrix index"); - return; - } - - int i = NINT (dval); - int idx = i - 1; - - if (rhs_nr == 0 && rhs_nc == 0) - { - int len = nr * nc; - - if (idx < len && len > 0) - { - convert_to_row_or_column_vector (); - - nr = rows (); - nc = columns (); - - if (nr == 1) - delete_column (idx); - else if (nc == 1) - delete_row (idx); - else - panic_impossible (); - } - else if (idx < 0) - { - error ("invalid index = %d", idx+1); - } - - return; - } - - if (index_check (idx, "") < 0) - return; - - if (nr <= 1 || nc <= 1) - { - maybe_resize (idx); - if (error_state) - return; - } - else if (range_max_check (idx, nr * nc) < 0) - return; - - nr = rows (); - nc = columns (); - - if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) - { - ::error ("for A(int) = X: X must be a scalar"); - return; - } - int ii = fortran_row (i, nr) - 1; - int jj = fortran_column (i, nr) - 1; - do_matrix_assignment (rhs, ii, jj); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - int len = nr * nc; - idx_vector ii (mi, 1, "", len); // Always do fortran indexing here... - if (! ii) - return; - - if (rhs_nr == 0 && rhs_nc == 0) - { - ii.sort_uniq (); - int num_to_delete = 0; - for (int i = 0; i < ii.length (); i++) - { - if (ii.elem (i) < len) - num_to_delete++; - else - break; - } - - if (num_to_delete > 0) - { - if (num_to_delete != ii.length ()) - ii.shorten (num_to_delete); - - convert_to_row_or_column_vector (); - - nr = rows (); - nc = columns (); - - if (nr == 1) - delete_columns (ii); - else if (nc == 1) - delete_rows (ii); - else - panic_impossible (); - } - return; - } - - if (nr <= 1 || nc <= 1) - { - maybe_resize (ii.max ()); - if (error_state) - return; - } - else if (range_max_check (ii.max (), len) < 0) - return; - - int ilen = ii.capacity (); - - if (ilen != rhs_nr * rhs_nc) - { - ::error ("A(matrix) = X: X and matrix must have the same number"); - ::error ("of elements"); - } - else if (ilen == 1 && rhs.is_scalar_type ()) - { - int nr = rows (); - int idx = ii.elem (0); - int ii = fortran_row (idx + 1, nr) - 1; - int jj = fortran_column (idx + 1, nr) - 1; - - if (rhs.const_type () == scalar_constant) - matrix->elem (ii, jj) = rhs.double_value (); - else if (rhs.const_type () == complex_scalar_constant) - complex_matrix->elem (ii, jj) = rhs.complex_value (); - else - panic_impossible (); - } - else - fortran_style_matrix_assignment (rhs, ii); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - gripe_range_invalid (); - break; - - case magic_colon: -// a(:) = [] is equivalent to a(:,:) = []. - if (rhs_nr == 0 && rhs_nc == 0) - do_matrix_assignment (rhs, magic_colon, magic_colon); - else - fortran_style_matrix_assignment (rhs, magic_colon); - break; - - default: - panic_impossible (); - break; - } -} - -// Fortran-style assignment for vector index. - -void -TC_REP::fortran_style_matrix_assignment (const tree_constant& rhs, - idx_vector& i) -{ - assert (rhs.is_matrix_type ()); - - int ilen = i.capacity (); - - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int len = rhs_nr * rhs_nc; - - if (len == ilen) - { - int nr = rows (); - if (rhs.const_type () == matrix_constant) - { - double *cop_out = rhs_m.fortran_vec (); - for (int k = 0; k < len; k++) - { - int ii = fortran_row (i.elem (k) + 1, nr) - 1; - int jj = fortran_column (i.elem (k) + 1, nr) - 1; - - matrix->elem (ii, jj) = *cop_out++; - } - } - else - { - Complex *cop_out = rhs_cm.fortran_vec (); - for (int k = 0; k < len; k++) - { - int ii = fortran_row (i.elem (k) + 1, nr) - 1; - int jj = fortran_column (i.elem (k) + 1, nr) - 1; - - complex_matrix->elem (ii, jj) = *cop_out++; - } - } - } - else - ::error ("number of rows and columns must match for indexed assignment"); -} - -// Fortran-style assignment for colon index. - -void -TC_REP::fortran_style_matrix_assignment (const tree_constant& rhs, - TC_REP::constant_type mci) -{ - assert (rhs.is_matrix_type () && mci == TC_REP::magic_colon); - - int nr = rows (); - int nc = columns (); - - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int rhs_size = rhs_nr * rhs_nc; - if (rhs_size == 0) - { - if (rhs.const_type () == matrix_constant) - { - delete matrix; - matrix = new Matrix (0, 0); - return; - } - else - panic_impossible (); - } - else if (nr*nc != rhs_size) - { - ::error ("A(:) = X: X and A must have the same number of elements"); - return; - } - - if (rhs.const_type () == matrix_constant) - { - double *cop_out = rhs_m.fortran_vec (); - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - matrix->elem (i, j) = *cop_out++; - } - else - { - Complex *cop_out = rhs_cm.fortran_vec (); - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - complex_matrix->elem (i, j) = *cop_out++; - } -} - -// Assignments to vectors. Hand off to other functions once we know -// what kind of index we have. For a colon, it is the same as -// assignment to a matrix indexed by two colons. - -void -TC_REP::vector_assignment (const tree_constant& rhs, - const tree_constant& i_arg) -{ - int nr = rows (); - int nc = columns (); - - assert ((nr <= 1 || nc <= 1) && ! user_pref.do_fortran_indexing); - - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type itype = tmp_i.const_type (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - if (index_check (i, "") < 0) - return; - do_vector_assign (rhs, i); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - int len = nr * nc; - idx_vector iv (mi, user_pref.do_fortran_indexing, "", len); - if (! iv) - return; - - do_vector_assign (rhs, iv); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range ri = tmp_i.range_value (); - int len = nr * nc; - if (len == 2 && is_zero_one (ri)) - { - do_vector_assign (rhs, 1); - } - else if (len == 2 && is_one_zero (ri)) - { - do_vector_assign (rhs, 0); - } - else - { - if (index_check (ri, "") < 0) - return; - do_vector_assign (rhs, ri); - } - } - break; - - case magic_colon: - { - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - if (! indexed_assign_conforms (nr, nc, rhs_nr, rhs_nc)) - { - ::error ("A(:) = X: X and A must have the same dimensions"); - return; - } - do_matrix_assignment (rhs, magic_colon, magic_colon); - } - break; - - default: - panic_impossible (); - break; - } -} - -// Check whether an indexed assignment to a vector is valid. - -void -TC_REP::check_vector_assign (int rhs_nr, int rhs_nc, int ilen, const char *rm) -{ - int nr = rows (); - int nc = columns (); - - if ((nr == 1 && nc == 1) || nr == 0 || nc == 0) // No orientation. - { - if (! (ilen == rhs_nr || ilen == rhs_nc)) - { - ::error ("A(%s) = X: X and %s must have the same number of elements", - rm, rm); - } - } - else if (nr == 1) // Preserve current row orientation. - { - if (! (rhs_nr == 1 && rhs_nc == ilen)) - { - ::error ("A(%s) = X: where A is a row vector, X must also be a", rm); - ::error ("row vector with the same number of elements as %s", rm); - } - } - else if (nc == 1) // Preserve current column orientation. - { - if (! (rhs_nc == 1 && rhs_nr == ilen)) - { - ::error ("A(%s) = X: where A is a column vector, X must also be", rm); - ::error ("a column vector with the same number of elements as %s", rm); - } - } - else - panic_impossible (); -} - -// Assignment to a vector with an integer index. - -void -TC_REP::do_vector_assign (const tree_constant& rhs, int i) -{ - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - if (indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) - { - maybe_resize (i); - if (error_state) - return; - - int nr = rows (); - int nc = columns (); - - if (nr == 1) - { - REP_ELEM_ASSIGN (0, i, rhs.double_value (), rhs.complex_value (), - rhs.is_real_type ()); - } - else if (nc == 1) - { - REP_ELEM_ASSIGN (i, 0, rhs.double_value (), rhs.complex_value (), - rhs.is_real_type ()); - } - else - panic_impossible (); - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - int nr = rows (); - int nc = columns (); - - int len = MAX (nr, nc); - - if (i < 0 || i >= len || (nr == 0 && nc == 0)) - { - ::error ("A(int) = []: index out of range"); - return; - } - - if (nr == 0 && nc > 0) - resize (0, nc - 1); - else if (nc == 0 && nr > 0) - resize (nr - 1, 0); - else if (nr == 1) - delete_column (i); - else if (nc == 1) - delete_row (i); - else - panic_impossible (); - } - else - { - ::error ("for A(int) = X: X must be a scalar"); - return; - } -} - -// Assignment to a vector with a vector index. - -void -TC_REP::do_vector_assign (const tree_constant& rhs, idx_vector& iv) -{ - if (rhs.is_zero_by_zero ()) - { - int nr = rows (); - int nc = columns (); - - int len = MAX (nr, nc); - - if (iv.max () >= len) - { - ::error ("A(matrix) = []: index out of range"); - return; - } - - if (nr == 1) - delete_columns (iv); - else if (nc == 1) - delete_rows (iv); - else - panic_impossible (); - } - else if (rhs.is_scalar_type ()) - { - int nr = rows (); - int nc = columns (); - - if (iv.capacity () == 1) - { - int idx = iv.elem (0); - - if (nr == 1) - { - REP_ELEM_ASSIGN (0, idx, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else if (nc == 1) - { - REP_ELEM_ASSIGN (idx, 0, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else - panic_impossible (); - } - else - { - if (nr == 1) - { - ::error ("A(matrix) = X: where A is a row vector, X must also be a"); - ::error ("row vector with the same number of elements as matrix"); - } - else if (nc == 1) - { - ::error ("A(matrix) = X: where A is a column vector, X must also be a"); - ::error ("column vector with the same number of elements as matrix"); - } - else - panic_impossible (); - } - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int ilen = iv.capacity (); - check_vector_assign (rhs_nr, rhs_nc, ilen, "matrix"); - if (error_state) - return; - - force_orient f_orient = no_orient; - if (rhs_nr == 1 && rhs_nc != 1) - f_orient = row_orient; - else if (rhs_nc == 1 && rhs_nr != 1) - f_orient = column_orient; - - maybe_resize (iv.max (), f_orient); - if (error_state) - return; - - int nr = rows (); - int nc = columns (); - - if (nr == 1 && rhs_nr == 1) - { - for (int i = 0; i < iv.capacity (); i++) - REP_ELEM_ASSIGN (0, iv.elem (i), rhs_m.elem (0, i), - rhs_cm.elem (0, i), rhs.is_real_type ()); - } - else if (nc == 1 && rhs_nc == 1) - { - for (int i = 0; i < iv.capacity (); i++) - REP_ELEM_ASSIGN (iv.elem (i), 0, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } - else - ::error ("A(vector) = X: X must be the same size as vector"); - } - else - panic_impossible (); -} - -// Assignment to a vector with a range index. - -void -TC_REP::do_vector_assign (const tree_constant& rhs, Range& ri) -{ - if (rhs.is_zero_by_zero ()) - { - int nr = rows (); - int nc = columns (); - - int len = MAX (nr, nc); - - int b = tree_to_mat_idx (ri.min ()); - int l = tree_to_mat_idx (ri.max ()); - if (b < 0 || l >= len) - { - ::error ("A(range) = []: index out of range"); - return; - } - - if (nr == 1) - delete_columns (ri); - else if (nc == 1) - delete_rows (ri); - else - panic_impossible (); - } - else if (rhs.is_scalar_type ()) - { - int nr = rows (); - int nc = columns (); - - if (nr == 1) - { - ::error ("A(range) = X: where A is a row vector, X must also be a"); - ::error ("row vector with the same number of elements as range"); - } - else if (nc == 1) - { - ::error ("A(range) = X: where A is a column vector, X must also be a"); - ::error ("column vector with the same number of elements as range"); - } - else - panic_impossible (); - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int ilen = ri.nelem (); - check_vector_assign (rhs_nr, rhs_nc, ilen, "range"); - if (error_state) - return; - - force_orient f_orient = no_orient; - if (rhs_nr == 1 && rhs_nc != 1) - f_orient = row_orient; - else if (rhs_nc == 1 && rhs_nr != 1) - f_orient = column_orient; - - maybe_resize (tree_to_mat_idx (ri.max ()), f_orient); - if (error_state) - return; - - int nr = rows (); - int nc = columns (); - - double b = ri.base (); - double increment = ri.inc (); - - if (nr == 1) - { - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int col = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (0, col, rhs_m.elem (0, i), rhs_cm.elem (0, i), - rhs.is_real_type ()); - } - } - else if (nc == 1) - { - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, 0, rhs_m.elem (i, 0), rhs_cm.elem (i, 0), - rhs.is_real_type ()); - } - } - else - panic_impossible (); - } - else - panic_impossible (); -} - -// Matrix assignment indexed by two values. This function determines -// the type of the first arugment, checks as much as possible, and -// then calls one of a set of functions to handle the specific cases: -// -// M (integer, arg2) = RHS (MA1) -// M (vector, arg2) = RHS (MA2) -// M (range, arg2) = RHS (MA3) -// M (colon, arg2) = RHS (MA4) -// -// Each of those functions determines the type of the second argument -// and calls another function to handle the real work of doing the -// assignment. - -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - const tree_constant& i_arg, - const tree_constant& j_arg) -{ - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type itype = tmp_i.const_type (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - do_matrix_assignment (rhs, i, j_arg); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - idx_vector iv (mi, user_pref.do_fortran_indexing, "row", rows ()); - if (! iv) - return; - - do_matrix_assignment (rhs, iv, j_arg); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range ri = tmp_i.range_value (); - int nr = rows (); - if (nr == 2 && is_zero_one (ri)) - { - do_matrix_assignment (rhs, 1, j_arg); - } - else if (nr == 2 && is_one_zero (ri)) - { - do_matrix_assignment (rhs, 0, j_arg); - } - else - { - if (index_check (ri, "row") < 0) - return; - do_matrix_assignment (rhs, ri, j_arg); - } - } - break; - - case magic_colon: - do_matrix_assignment (rhs, magic_colon, j_arg); - break; - - default: - panic_impossible (); - break; - } -} - -/* MA1 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, int i, - const tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - if (index_check (i, "row") < 0) - return; - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - if (! indexed_assign_conforms (1, 1, rhs_nr, rhs_nc)) - { - ::error ("A(int,int) = X, X must be a scalar"); - return; - } - maybe_resize (i, j); - if (error_state) - return; - - do_matrix_assignment (rhs, i, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - if (index_check (i, "row") < 0) - return; - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - if (! indexed_assign_conforms (1, jv.capacity (), rhs_nr, rhs_nc)) - { - ::error ("A(int,matrix) = X: X must be a row vector with the same"); - ::error ("number of elements as matrix"); - return; - } - maybe_resize (i, jv.max ()); - if (error_state) - return; - - do_matrix_assignment (rhs, i, jv); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - if (index_check (i, "row") < 0) - return; - Range rj = tmp_j.range_value (); - if (! indexed_assign_conforms (1, rj.nelem (), rhs_nr, rhs_nc)) - { - ::error ("A(int,range) = X: X must be a row vector with the same"); - ::error ("number of elements as range"); - return; - } - - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, i, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, i, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - maybe_resize (i, tree_to_mat_idx (rj.max ())); - if (error_state) - return; - - do_matrix_assignment (rhs, i, rj); - } - } - break; - - case magic_colon: - { - int nc = columns (); - int nr = rows (); - if (i == -1 && nr == 1 && rhs_nr == 0 && rhs_nc == 0 - || index_check (i, "row") < 0) - return; - else if (nc == 0 && nr == 0 && rhs_nr == 1) - { - if (rhs.is_complex_type ()) - { - complex_matrix = new ComplexMatrix (); - type_tag = complex_matrix_constant; - } - else - { - matrix = new Matrix (); - type_tag = matrix_constant; - } - maybe_resize (i, rhs_nc-1); - if (error_state) - return; - } - else if (indexed_assign_conforms (1, nc, rhs_nr, rhs_nc)) - { - maybe_resize (i, nc-1); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (i < 0 || i >= nr) - { - ::error ("A(int,:) = []: row index out of range"); - return; - } - } - else - { - ::error ("A(int,:) = X: X must be a row vector with the same"); - ::error ("number of columns as A"); - return; - } - - do_matrix_assignment (rhs, i, magic_colon); - } - break; - - default: - panic_impossible (); - break; - } -} - -/* MA2 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - idx_vector& iv, const tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - if (! indexed_assign_conforms (iv.capacity (), 1, rhs_nr, rhs_nc)) - { - ::error ("A(matrix,int) = X: X must be a column vector with the"); - ::error ("same number of elements as matrix"); - return; - } - maybe_resize (iv.max (), j); - if (error_state) - return; - - do_matrix_assignment (rhs, iv, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - if (! indexed_assign_conforms (iv.capacity (), jv.capacity (), - rhs_nr, rhs_nc)) - { - ::error ("A(r_mat,c_mat) = X: the number of rows in X must match"); - ::error ("the number of elements in r_mat and the number of"); - ::error ("columns in X must match the number of elements in c_mat"); - return; - } - maybe_resize (iv.max (), jv.max ()); - if (error_state) - return; - - do_matrix_assignment (rhs, iv, jv); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range rj = tmp_j.range_value (); - if (! indexed_assign_conforms (iv.capacity (), rj.nelem (), - rhs_nr, rhs_nc)) - { - ::error ("A(matrix,range) = X: the number of rows in X must match"); - ::error ("the number of elements in matrix and the number of"); - ::error ("columns in X must match the number of elements in range"); - return; - } - - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, iv, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, iv, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - maybe_resize (iv.max (), tree_to_mat_idx (rj.max ())); - if (error_state) - return; - - do_matrix_assignment (rhs, iv, rj); - } - } - break; - - case magic_colon: - { - int nc = columns (); - int new_nc = nc; - if (nc == 0) - new_nc = rhs_nc; - - if (indexed_assign_conforms (iv.capacity (), new_nc, - rhs_nr, rhs_nc)) - { - maybe_resize (iv.max (), new_nc-1); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (iv.max () >= rows ()) - { - ::error ("A(matrix,:) = []: row index out of range"); - return; - } - } - else - { - ::error ("A(matrix,:) = X: the number of rows in X must match the"); - ::error ("number of elements in matrix, and the number of columns"); - ::error ("in X must match the number of columns in A"); - return; - } - - do_matrix_assignment (rhs, iv, magic_colon); - } - break; - - default: - panic_impossible (); - break; - } -} - -/* MA3 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, Range& ri, - const tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return; - if (! indexed_assign_conforms (ri.nelem (), 1, rhs_nr, rhs_nc)) - { - ::error ("A(range,int) = X: X must be a column vector with the"); - ::error ("same number of elements as range"); - return; - } - maybe_resize (tree_to_mat_idx (ri.max ()), j); - if (error_state) - return; - - do_matrix_assignment (rhs, ri, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - if (! indexed_assign_conforms (ri.nelem (), jv.capacity (), - rhs_nr, rhs_nc)) - { - ::error ("A(range,matrix) = X: the number of rows in X must match"); - ::error ("the number of elements in range and the number of"); - ::error ("columns in X must match the number of elements in matrix"); - return; - } - maybe_resize (tree_to_mat_idx (ri.max ()), jv.max ()); - if (error_state) - return; - - do_matrix_assignment (rhs, ri, jv); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range rj = tmp_j.range_value (); - if (! indexed_assign_conforms (ri.nelem (), rj.nelem (), - rhs_nr, rhs_nc)) - { - ::error ("A(r_range,c_range) = X: the number of rows in X must"); - ::error ("match the number of elements in r_range and the number"); - ::error ("of columns in X must match the number of elements in"); - ::error ("c_range"); - return; - } - - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, ri, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, ri, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - - maybe_resize (tree_to_mat_idx (ri.max ()), - tree_to_mat_idx (rj.max ())); - - if (error_state) - return; - - do_matrix_assignment (rhs, ri, rj); - } - } - break; - - case magic_colon: - { - int nc = columns (); - int new_nc = nc; - if (nc == 0) - new_nc = rhs_nc; - - if (indexed_assign_conforms (ri.nelem (), new_nc, rhs_nr, rhs_nc)) - { - maybe_resize (tree_to_mat_idx (ri.max ()), new_nc-1); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - int b = tree_to_mat_idx (ri.min ()); - int l = tree_to_mat_idx (ri.max ()); - if (b < 0 || l >= rows ()) - { - ::error ("A(range,:) = []: row index out of range"); - return; - } - } - else - { - ::error ("A(range,:) = X: the number of rows in X must match the"); - ::error ("number of elements in range, and the number of columns"); - ::error ("in X must match the number of columns in A"); - return; - } - - do_matrix_assignment (rhs, ri, magic_colon); - } - break; - - default: - panic_impossible (); - break; - } -} - -/* MA4 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - TC_REP::constant_type i, - const tree_constant& j_arg) -{ - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int rhs_nr = rhs.rows (); - int rhs_nc = rhs.columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - int nr = rows (); - int nc = columns (); - if (j == -1 && nc == 1 && rhs_nr == 0 && rhs_nc == 0 - || index_check (j, "column") < 0) - return; - if (nr == 0 && nc == 0 && rhs_nc == 1) - { - if (rhs.is_complex_type ()) - { - complex_matrix = new ComplexMatrix (); - type_tag = complex_matrix_constant; - } - else - { - matrix = new Matrix (); - type_tag = matrix_constant; - } - maybe_resize (rhs_nr-1, j); - if (error_state) - return; - } - else if (indexed_assign_conforms (nr, 1, rhs_nr, rhs_nc)) - { - maybe_resize (nr-1, j); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (j < 0 || j >= nc) - { - ::error ("A(:,int) = []: column index out of range"); - return; - } - } - else - { - ::error ("A(:,int) = X: X must be a column vector with the same"); - ::error ("number of rows as A"); - return; - } - - do_matrix_assignment (rhs, magic_colon, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", - columns ()); - if (! jv) - return; - - int nr = rows (); - int new_nr = nr; - if (nr == 0) - new_nr = rhs_nr; - - if (indexed_assign_conforms (new_nr, jv.capacity (), - rhs_nr, rhs_nc)) - { - maybe_resize (new_nr-1, jv.max ()); - if (error_state) - return; - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - if (jv.max () >= columns ()) - { - ::error ("A(:,matrix) = []: column index out of range"); - return; - } - } - else - { - ::error ("A(:,matrix) = X: the number of rows in X must match the"); - ::error ("number of rows in A, and the number of columns in X must"); - ::error ("match the number of elements in matrix"); - return; - } - - do_matrix_assignment (rhs, magic_colon, jv); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range rj = tmp_j.range_value (); - int nr = rows (); - int new_nr = nr; - if (nr == 0) - new_nr = rhs_nr; - - if (indexed_assign_conforms (new_nr, rj.nelem (), rhs_nr, rhs_nc)) - { - int nc = columns (); - if (nc == 2 && is_zero_one (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, magic_colon, 1); - } - else if (nc == 2 && is_one_zero (rj) && rhs_nc == 1) - { - do_matrix_assignment (rhs, magic_colon, 0); - } - else - { - if (index_check (rj, "column") < 0) - return; - maybe_resize (new_nr-1, tree_to_mat_idx (rj.max ())); - if (error_state) - return; - } - } - else if (rhs_nr == 0 && rhs_nc == 0) - { - int b = tree_to_mat_idx (rj.min ()); - int l = tree_to_mat_idx (rj.max ()); - if (b < 0 || l >= columns ()) - { - ::error ("A(:,range) = []: column index out of range"); - return; - } - } - else - { - ::error ("A(:,range) = X: the number of rows in X must match the"); - ::error ("number of rows in A, and the number of columns in X"); - ::error ("must match the number of elements in range"); - return; - } - - do_matrix_assignment (rhs, magic_colon, rj); - } - break; - - case magic_colon: -// a(:,:) = foo is equivalent to a = foo. - do_matrix_assignment (rhs, magic_colon, magic_colon); - break; - - default: - panic_impossible (); - break; - } -} - -// Functions that actually handle assignment to a matrix using two -// index values. -// -// idx2 -// +---+---+----+----+ -// idx1 | i | v | r | c | -// ---------+---+---+----+----+ -// integer | 1 | 5 | 9 | 13 | -// ---------+---+---+----+----+ -// vector | 2 | 6 | 10 | 14 | -// ---------+---+---+----+----+ -// range | 3 | 7 | 11 | 15 | -// ---------+---+---+----+----+ -// colon | 4 | 8 | 12 | 16 | -// ---------+---+---+----+----+ - -/* 1 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, int i, int j) -{ - REP_ELEM_ASSIGN (i, j, rhs.double_value (), rhs.complex_value (), - rhs.is_real_type ()); -} - -/* 2 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, int i, idx_vector& jv) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int j = 0; j < jv.capacity (); j++) - REP_ELEM_ASSIGN (i, jv.elem (j), rhs_m.elem (0, j), - rhs_cm.elem (0, j), rhs.is_real_type ()); -} - -/* 3 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, int i, Range& rj) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = rj.base (); - double increment = rj.inc (); - - for (int j = 0; j < rj.nelem (); j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (i, col, rhs_m.elem (0, j), rhs_cm.elem (0, j), - rhs.is_real_type ()); - } -} - -/* 4 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, int i, - TC_REP::constant_type mcj) -{ - assert (mcj == magic_colon); - - int nc = columns (); - - if (rhs.is_zero_by_zero ()) - { - delete_row (i); - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int j = 0; j < nc; j++) - REP_ELEM_ASSIGN (i, j, rhs_m.elem (0, j), rhs_cm.elem (0, j), - rhs.is_real_type ()); - } - else if (rhs.is_scalar_type () && nc == 1) - { - REP_ELEM_ASSIGN (i, 0, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else - panic_impossible (); -} - -/* 5 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - idx_vector& iv, int j) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } -} - -/* 6 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - idx_vector& iv, idx_vector& jv) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - for (int j = 0; j < jv.capacity (); j++) - { - int col = jv.elem (j); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -/* 7 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - idx_vector& iv, Range& rj) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = rj.base (); - double increment = rj.inc (); - - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - for (int j = 0; j < rj.nelem (); j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -/* 8 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - idx_vector& iv, TC_REP::constant_type mcj) -{ - assert (mcj == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_rows (iv); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int nc = columns (); - - for (int j = 0; j < nc; j++) - { - for (int i = 0; i < iv.capacity (); i++) - { - int row = iv.elem (i); - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } - } -} - -/* 9 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, Range& ri, int j) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = ri.base (); - double increment = ri.inc (); - - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } -} - -/* 10 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - Range& ri, idx_vector& jv) -{ - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double b = ri.base (); - double increment = ri.inc (); - - for (int j = 0; j < jv.capacity (); j++) - { - int col = jv.elem (j); - for (int i = 0; i < ri.nelem (); i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_m.elem (i, j), rhs.is_real_type ()); - } - } -} - -/* 11 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - Range& ri, Range& rj) -{ - double ib = ri.base (); - double iinc = ri.inc (); - double jb = rj.base (); - double jinc = rj.inc (); - - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < ri.nelem (); i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < rj.nelem (); j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - REP_ELEM_ASSIGN (row, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -/* 12 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - Range& ri, TC_REP::constant_type mcj) -{ - assert (mcj == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_rows (ri); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - double ib = ri.base (); - double iinc = ri.inc (); - - int nc = columns (); - - for (int i = 0; i < ri.nelem (); i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < nc; j++) - REP_ELEM_ASSIGN (row, j, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } -} - -/* 13 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - TC_REP::constant_type mci, int j) -{ - assert (mci == magic_colon); - - int nr = rows (); - - if (rhs.is_zero_by_zero ()) - { - delete_column (j); - } - else if (rhs.is_matrix_type ()) - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - for (int i = 0; i < nr; i++) - REP_ELEM_ASSIGN (i, j, rhs_m.elem (i, 0), - rhs_cm.elem (i, 0), rhs.is_real_type ()); - } - else if (rhs.is_scalar_type () && nr == 1) - { - REP_ELEM_ASSIGN (0, j, rhs.double_value (), - rhs.complex_value (), rhs.is_real_type ()); - } - else - panic_impossible (); -} - -/* 14 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - TC_REP::constant_type mci, idx_vector& jv) -{ - assert (mci == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_columns (jv); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int nr = rows (); - - for (int i = 0; i < nr; i++) - { - for (int j = 0; j < jv.capacity (); j++) - { - int col = jv.elem (j); - REP_ELEM_ASSIGN (i, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } - } -} - -/* 15 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - TC_REP::constant_type mci, Range& rj) -{ - assert (mci == magic_colon); - - if (rhs.is_zero_by_zero ()) - { - delete_columns (rj); - } - else - { - REP_RHS_MATRIX (rhs, rhs_m, rhs_cm, rhs_nr, rhs_nc); - - int nr = rows (); - - double jb = rj.base (); - double jinc = rj.inc (); - - for (int j = 0; j < rj.nelem (); j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - for (int i = 0; i < nr; i++) - { - REP_ELEM_ASSIGN (i, col, rhs_m.elem (i, j), - rhs_cm.elem (i, j), rhs.is_real_type ()); - } - } - } -} - -/* 16 */ -void -TC_REP::do_matrix_assignment (const tree_constant& rhs, - TC_REP::constant_type mci, - TC_REP::constant_type mcj) -{ - assert (mci == magic_colon && mcj == magic_colon); - - switch (type_tag) - { - case scalar_constant: - break; - - case matrix_constant: - delete matrix; - break; - - case complex_scalar_constant: - delete complex_scalar; - break; - - case complex_matrix_constant: - delete complex_matrix; - break; - - case string_constant: - delete [] string; - break; - - case range_constant: - delete range; - break; - - case magic_colon: - default: - panic_impossible (); - break; - } - - type_tag = rhs.const_type (); - - switch (type_tag) - { - case scalar_constant: - scalar = rhs.double_value (); - break; - - case matrix_constant: - matrix = new Matrix (rhs.matrix_value ()); - break; - - case string_constant: - string = strsave (rhs.string_value ()); - break; - - case complex_matrix_constant: - complex_matrix = new ComplexMatrix (rhs.complex_matrix_value ()); - break; - - case complex_scalar_constant: - complex_scalar = new Complex (rhs.complex_value ()); - break; - - case range_constant: - range = new Range (rhs.range_value ()); - break; - - case magic_colon: - default: - panic_impossible (); - break; - } -} - -// Functions for deleting rows or columns of a matrix. These are used -// to handle statements like -// -// M (i, j) = [] - -void -TC_REP::delete_row (int idx) -{ - if (type_tag == matrix_constant) - { - int nr = matrix->rows (); - int nc = matrix->columns (); - Matrix *new_matrix = new Matrix (nr-1, nc); - int ii = 0; - for (int i = 0; i < nr; i++) - { - if (i != idx) - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = matrix->elem (i, j); - ii++; - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - int nr = complex_matrix->rows (); - int nc = complex_matrix->columns (); - ComplexMatrix *new_matrix = new ComplexMatrix (nr-1, nc); - int ii = 0; - for (int i = 0; i < nr; i++) - { - if (i != idx) - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = complex_matrix->elem (i, j); - ii++; - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -TC_REP::delete_rows (idx_vector& iv) -{ - iv.sort_uniq (); - int num_to_delete = iv.length (); - - if (num_to_delete == 0) - return; - - int nr = rows (); - int nc = columns (); - -// If deleting all rows of a column vector, make result 0x0. - if (nc == 1 && num_to_delete == nr) - nc = 0; - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - if (i == iv.elem (idx)) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = matrix->elem (i, j); - ii++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - if (i == iv.elem (idx)) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = complex_matrix->elem (i, j); - ii++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -TC_REP::delete_rows (Range& ri) -{ - ri.sort (); - int num_to_delete = ri.nelem (); - - if (num_to_delete == 0) - return; - - int nr = rows (); - int nc = columns (); - -// If deleting all rows of a column vector, make result 0x0. - if (nc == 1 && num_to_delete == nr) - nc = 0; - - double ib = ri.base (); - double iinc = ri.inc (); - - int max_idx = tree_to_mat_idx (ri.max ()); - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - double itmp = ib + idx * iinc; - int row = tree_to_mat_idx (itmp); - - if (i == row && row <= max_idx) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = matrix->elem (i, j); - ii++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr-num_to_delete, nc); - if (nr > num_to_delete) - { - int ii = 0; - int idx = 0; - for (int i = 0; i < nr; i++) - { - double itmp = ib + idx * iinc; - int row = tree_to_mat_idx (itmp); - - if (i == row && row <= max_idx) - idx++; - else - { - for (int j = 0; j < nc; j++) - new_matrix->elem (ii, j) = complex_matrix->elem (i, j); - ii++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -TC_REP::delete_column (int idx) -{ - if (type_tag == matrix_constant) - { - int nr = matrix->rows (); - int nc = matrix->columns (); - Matrix *new_matrix = new Matrix (nr, nc-1); - int jj = 0; - for (int j = 0; j < nc; j++) - { - if (j != idx) - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = matrix->elem (i, j); - jj++; - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - int nr = complex_matrix->rows (); - int nc = complex_matrix->columns (); - ComplexMatrix *new_matrix = new ComplexMatrix (nr, nc-1); - int jj = 0; - for (int j = 0; j < nc; j++) - { - if (j != idx) - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = complex_matrix->elem (i, j); - jj++; - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -TC_REP::delete_columns (idx_vector& jv) -{ - jv.sort_uniq (); - int num_to_delete = jv.length (); - - if (num_to_delete == 0) - return; - - int nr = rows (); - int nc = columns (); - -// If deleting all columns of a row vector, make result 0x0. - if (nr == 1 && num_to_delete == nc) - nr = 0; - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - if (j == jv.elem (idx)) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = matrix->elem (i, j); - jj++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - if (j == jv.elem (idx)) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = complex_matrix->elem (i, j); - jj++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -void -TC_REP::delete_columns (Range& rj) -{ - rj.sort (); - int num_to_delete = rj.nelem (); - - if (num_to_delete == 0) - return; - - int nr = rows (); - int nc = columns (); - -// If deleting all columns of a row vector, make result 0x0. - if (nr == 1 && num_to_delete == nc) - nr = 0; - - double jb = rj.base (); - double jinc = rj.inc (); - - int max_idx = tree_to_mat_idx (rj.max ()); - - if (type_tag == matrix_constant) - { - Matrix *new_matrix = new Matrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - double jtmp = jb + idx * jinc; - int col = tree_to_mat_idx (jtmp); - - if (j == col && col <= max_idx) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = matrix->elem (i, j); - jj++; - } - } - } - delete matrix; - matrix = new_matrix; - } - else if (type_tag == complex_matrix_constant) - { - ComplexMatrix *new_matrix = new ComplexMatrix (nr, nc-num_to_delete); - if (nc > num_to_delete) - { - int jj = 0; - int idx = 0; - for (int j = 0; j < nc; j++) - { - double jtmp = jb + idx * jinc; - int col = tree_to_mat_idx (jtmp); - - if (j == col && col <= max_idx) - idx++; - else - { - for (int i = 0; i < nr; i++) - new_matrix->elem (i, jj) = complex_matrix->elem (i, j); - jj++; - } - } - } - delete complex_matrix; - complex_matrix = new_matrix; - } - else - panic_impossible (); -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/tc-rep-idx.cc Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1581 +0,0 @@ -// tc-rep-idx.cc -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994, 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <ctype.h> -#include <string.h> -#include <fstream.h> -#include <iostream.h> -#include <strstream.h> - -#include "mx-base.h" -#include "Range.h" - -#include "arith-ops.h" -#include "variables.h" -#include "sysdep.h" -#include "error.h" -#include "gripes.h" -#include "user-prefs.h" -#include "utils.h" -#include "pager.h" -#include "pr-output.h" -#include "tree-const.h" -#include "idx-vector.h" -#include "oct-map.h" - -#include "tc-inlines.h" - -// Indexing functions. - -// This is the top-level indexing function. - -tree_constant -TC_REP::do_index (const Octave_object& args) -{ - tree_constant retval; - - if (error_state) - return retval; - - if (rows () == 0 || columns () == 0) - { - switch (args.length ()) - { - case 2: - if (! args(1).is_magic_colon () - && args(1).rows () != 0 && args(1).columns () != 0) - goto index_error; - - case 1: - if (! args(0).is_magic_colon () - && args(0).rows () != 0 && args(0).columns () != 0) - goto index_error; - - return Matrix (); - - default: - index_error: - ::error ("attempt to index empty matrix"); - return retval; - } - } - - switch (type_tag) - { - case complex_scalar_constant: - case scalar_constant: - retval = do_scalar_index (args); - break; - - case complex_matrix_constant: - case matrix_constant: - retval = do_matrix_index (args); - break; - - case string_constant: - gripe_string_invalid (); -// retval = do_string_index (args); - break; - - default: - -// This isn\'t great, but it\'s easier than implementing a lot of -// other special indexing functions. - - force_numeric (); - - if (! error_state && is_numeric_type ()) - retval = do_index (args); - - break; - } - - return retval; -} - -tree_constant -TC_REP::do_scalar_index (const Octave_object& args) const -{ - tree_constant retval; - - if (valid_scalar_indices (args)) - { - if (type_tag == scalar_constant) - retval = scalar; - else if (type_tag == complex_scalar_constant) - retval = *complex_scalar; - else - panic_impossible (); - - return retval; - } - else - { - int rows = -1; - int cols = -1; - - int nargin = args.length (); - - switch (nargin) - { - case 2: - { - tree_constant arg = args(1); - - if (arg.is_matrix_type ()) - { - Matrix mj = arg.matrix_value (); - - idx_vector j (mj, user_pref.do_fortran_indexing, "", 1); - if (! j) - return retval; - - int jmax = j.max (); - int len = j.length (); - if (len == j.ones_count ()) - cols = len; - else if (jmax > 0) - { - error ("invalid scalar index = %d", jmax+1); - return retval; - } - } - else if (arg.const_type () == magic_colon) - { - cols = 1; - } - else if (arg.is_scalar_type ()) - { - double dval = arg.double_value (); - if (! xisnan (dval)) - { - int ival = NINT (dval); - if (ival == 1) - cols = 1; - else if (ival == 0) - cols = 0; - else - break;; - } - else - break; - } - else - break; - } - -// Fall through... - - case 1: - { - tree_constant arg = args(0); - - if (arg.is_matrix_type ()) - { - Matrix mi = arg.matrix_value (); - - idx_vector i (mi, user_pref.do_fortran_indexing, "", 1); - if (! i) - return retval; - - int imax = i.max (); - int len = i.length (); - if (len == i.ones_count ()) - rows = len; - else if (imax > 0) - { - error ("invalid scalar index = %d", imax+1); - return retval; - } - } - else if (arg.const_type () == magic_colon) - { - rows = 1; - } - else if (arg.is_scalar_type ()) - { - double dval = arg.double_value (); - - if (! xisnan (dval)) - { - int ival = NINT (dval); - if (ival == 1) - rows = 1; - else if (ival == 0) - rows = 0; - else - break; - } - else - break; - } - else - break; - -// If only one index, cols will not be set, so we set it. -// If single index is [], rows will be zero, and we should set cols to -// zero too. - - if (cols < 0) - { - if (rows == 0) - cols = 0; - else - { - if (user_pref.prefer_column_vectors) - cols = 1; - else - { - cols = rows; - rows = 1; - } - } - } - - if (type_tag == scalar_constant) - { - return Matrix (rows, cols, scalar); - } - else if (type_tag == complex_scalar_constant) - { - return ComplexMatrix (rows, cols, *complex_scalar); - } - else - panic_impossible (); - } - break; - - default: - ::error ("invalid number of arguments for scalar type"); - return tree_constant (); - break; - } - } - - ::error ("index invalid or out of range for scalar type"); - return tree_constant (); -} - -tree_constant -TC_REP::do_matrix_index (const Octave_object& args) const -{ - tree_constant retval; - - int nargin = args.length (); - - switch (nargin) - { - case 1: - { - tree_constant arg = args(0); - - if (arg.is_undefined ()) - ::error ("matrix index is a null expression"); - else - retval = do_matrix_index (arg); - } - break; - - case 2: - { - tree_constant arg_a = args(0); - tree_constant arg_b = args(1); - - if (arg_a.is_undefined ()) - ::error ("first matrix index is a null expression"); - else if (arg_b.is_undefined ()) - ::error ("second matrix index is a null expression"); - else - retval = do_matrix_index (arg_a, arg_b); - } - break; - - default: - if (nargin == 0) - ::error ("matrix indices expected, but none provided"); - else - ::error ("too many indices for matrix expression"); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const tree_constant& i_arg) const -{ - tree_constant retval; - - int nr = rows (); - int nc = columns (); - - if (user_pref.do_fortran_indexing) - retval = fortran_style_matrix_index (i_arg); - else if (nr <= 1 || nc <= 1) - retval = do_vector_index (i_arg); - else - ::error ("single index only valid for row or column vector"); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const tree_constant& i_arg, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type itype = tmp_i.const_type (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - retval = do_matrix_index (i, j_arg); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - idx_vector iv (mi, user_pref.do_fortran_indexing, "row", rows ()); - if (! iv) - return tree_constant (); - - if (iv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - retval = do_matrix_index (iv, j_arg); - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range ri = tmp_i.range_value (); - int nr = rows (); - if (nr == 2 && is_zero_one (ri)) - { - retval = do_matrix_index (1, j_arg); - } - else if (nr == 2 && is_one_zero (ri)) - { - retval = do_matrix_index (0, j_arg); - } - else - { - if (index_check (ri, "row") < 0) - return tree_constant (); - retval = do_matrix_index (ri, j_arg); - } - } - break; - - case magic_colon: - retval = do_matrix_index (magic_colon, j_arg); - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (TC_REP::constant_type mci) const -{ - assert (mci == magic_colon); - - tree_constant retval; - int nr = rows (); - int nc = columns (); - int size = nr * nc; - if (size > 0) - { - CRMATRIX (m, cm, size, 1); - int idx = 0; - for (int j = 0; j < nc; j++) - for (int i = 0; i < nr; i++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, idx, 0, i, j); - idx++; - } - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - return retval; -} - -tree_constant -TC_REP::fortran_style_matrix_index (const tree_constant& i_arg) const -{ - tree_constant retval; - - tree_constant tmp_i = i_arg.make_numeric_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type itype = tmp_i.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - double dval = tmp_i.double_value (); - - if (xisnan (dval)) - { - ::error ("NaN is invalid as a matrix index"); - return tree_constant (); - } - else - { - int i = NINT (dval); - int ii = fortran_row (i, nr) - 1; - int jj = fortran_column (i, nr) - 1; - if (index_check (i-1, "") < 0) - return tree_constant (); - if (range_max_check (i-1, nr * nc) < 0) - return tree_constant (); - retval = do_matrix_index (ii, jj); - } - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - if (mi.rows () == 0 || mi.columns () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { -// Yes, we really do want to call this with mi. - retval = fortran_style_matrix_index (mi); - } - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - gripe_range_invalid (); - break; - - case magic_colon: - retval = do_matrix_index (magic_colon); - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::fortran_style_matrix_index (const Matrix& mi) const -{ - assert (is_matrix_type ()); - - tree_constant retval; - - int nr = rows (); - int nc = columns (); - - int len = nr * nc; - - int index_nr = mi.rows (); - int index_nc = mi.columns (); - - if (index_nr >= 1 && index_nc >= 1) - { - const double *cop_out = 0; - const Complex *c_cop_out = 0; - int real_type = type_tag == matrix_constant; - if (real_type) - cop_out = matrix->data (); - else - c_cop_out = complex_matrix->data (); - - const double *cop_out_index = mi.data (); - - idx_vector iv (mi, 1, "", len); - if (! iv || range_max_check (iv.max (), len) < 0) - return retval; - - int result_size = iv.length (); - -// XXX FIXME XXX -- there is way too much duplicate code here... - - if (iv.one_zero_only ()) - { - if (iv.ones_count () == 0) - { - retval = Matrix (); - } - else - { - if (nr == 1) - { - CRMATRIX (m, cm, 1, result_size); - - for (int i = 0; i < result_size; i++) - { - int idx = iv.elem (i); - CRMATRIX_ASSIGN_ELEM (m, cm, 0, i, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - else - { - CRMATRIX (m, cm, result_size, 1); - - for (int i = 0; i < result_size; i++) - { - int idx = iv.elem (i); - CRMATRIX_ASSIGN_ELEM (m, cm, i, 0, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - } - } - else if (nc == 1) - { - CRMATRIX (m, cm, result_size, 1); - - for (int i = 0; i < result_size; i++) - { - int idx = iv.elem (i); - CRMATRIX_ASSIGN_ELEM (m, cm, i, 0, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - else if (nr == 1) - { - CRMATRIX (m, cm, 1, result_size); - - for (int i = 0; i < result_size; i++) - { - int idx = iv.elem (i); - CRMATRIX_ASSIGN_ELEM (m, cm, 0, i, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - else - { - CRMATRIX (m, cm, index_nr, index_nc); - - for (int j = 0; j < index_nc; j++) - for (int i = 0; i < index_nr; i++) - { - double tmp = *cop_out_index++; - int idx = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_ELEM (m, cm, i, j, cop_out [idx], - c_cop_out [idx], real_type); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - } - } - else - { - if (index_nr == 0 || index_nc == 0) - ::error ("empty matrix invalid as index"); - else - ::error ("invalid matrix index"); - return tree_constant (); - } - - return retval; -} - -tree_constant -TC_REP::do_vector_index (const tree_constant& i_arg) const -{ - tree_constant retval; - - tree_constant tmp_i = i_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type itype = tmp_i.const_type (); - - int nr = rows (); - int nc = columns (); - - int len = MAX (nr, nc); - - assert ((nr == 1 || nc == 1) && ! user_pref.do_fortran_indexing); - - int swap_indices = (nr == 1); - - switch (itype) - { - case complex_scalar_constant: - case scalar_constant: - { - int i = tree_to_mat_idx (tmp_i.double_value ()); - if (index_check (i, "") < 0) - return tree_constant (); - if (swap_indices) - { - if (range_max_check (i, nc) < 0) - return tree_constant (); - retval = do_matrix_index (0, i); - } - else - { - if (range_max_check (i, nr) < 0) - return tree_constant (); - retval = do_matrix_index (i, 0); - } - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mi = tmp_i.matrix_value (); - if (mi.rows () == 0 || mi.columns () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - idx_vector iv (mi, user_pref.do_fortran_indexing, "", len); - if (! iv) - return tree_constant (); - - if (swap_indices) - { - if (range_max_check (iv.max (), nc) < 0) - return tree_constant (); - retval = do_matrix_index (0, iv); - } - else - { - if (range_max_check (iv.max (), nr) < 0) - return tree_constant (); - retval = do_matrix_index (iv, 0); - } - } - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range ri = tmp_i.range_value (); - if (len == 2 && is_zero_one (ri)) - { - if (swap_indices) - retval = do_matrix_index (0, 1); - else - retval = do_matrix_index (1, 0); - } - else if (len == 2 && is_one_zero (ri)) - { - retval = do_matrix_index (0, 0); - } - else - { - if (index_check (ri, "") < 0) - return tree_constant (); - if (swap_indices) - { - if (range_max_check (tree_to_mat_idx (ri.max ()), nc) < 0) - return tree_constant (); - retval = do_matrix_index (0, ri); - } - else - { - if (range_max_check (tree_to_mat_idx (ri.max ()), nr) < 0) - return tree_constant (); - retval = do_matrix_index (ri, 0); - } - } - } - break; - - case magic_colon: - if (swap_indices) - retval = do_matrix_index (0, magic_colon); - else - retval = do_matrix_index (magic_colon, 0); - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (int i, const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - if (index_check (i, "row") < 0) - return tree_constant (); - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (i, j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - if (index_check (i, "row") < 0) - return tree_constant (); - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (i, jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, jv); - } - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - if (index_check (i, "row") < 0) - return tree_constant (); - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (i, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (i, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (i, tree_to_mat_idx (rj.max ()), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, rj); - } - } - break; - - case magic_colon: - if (i == -1 && nr == 1) - return Matrix (); - if (index_check (i, "row") < 0 - || range_max_check (i, 0, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (i, magic_colon); - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const idx_vector& iv, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (iv.max (), j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (iv.max (), jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, jv); - } - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (iv, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (iv, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (iv.max (), tree_to_mat_idx (rj.max ()), - nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, rj); - } - } - break; - - case magic_colon: - if (range_max_check (iv.max (), 0, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (iv, magic_colon); - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const Range& ri, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (tree_to_mat_idx (ri.max ()), j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (tree_to_mat_idx (ri.max ()), - jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, jv); - } - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (ri, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (ri, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (tree_to_mat_idx (ri.max ()), - tree_to_mat_idx (rj.max ()), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, rj); - } - } - break; - - case magic_colon: - { - if (index_check (ri, "row") < 0) - return tree_constant (); - if (range_max_check (tree_to_mat_idx (ri.max ()), 0, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (ri, magic_colon); - } - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (TC_REP::constant_type mci, - const tree_constant& j_arg) const -{ - tree_constant retval; - - tree_constant tmp_j = j_arg.make_numeric_or_range_or_magic (); - - if (error_state) - return retval; - - TC_REP::constant_type jtype = tmp_j.const_type (); - - int nr = rows (); - int nc = columns (); - - switch (jtype) - { - case complex_scalar_constant: - case scalar_constant: - { - int j = tree_to_mat_idx (tmp_j.double_value ()); - if (j == -1 && nc == 1) - return Matrix (); - if (index_check (j, "column") < 0) - return tree_constant (); - if (range_max_check (0, j, nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (magic_colon, j); - } - break; - - case complex_matrix_constant: - case matrix_constant: - { - Matrix mj = tmp_j.matrix_value (); - idx_vector jv (mj, user_pref.do_fortran_indexing, "column", nc); - if (! jv) - return tree_constant (); - - if (jv.length () == 0) - { - Matrix mtmp; - retval = tree_constant (mtmp); - } - else - { - if (range_max_check (0, jv.max (), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (magic_colon, jv); - } - } - break; - - case string_constant: - gripe_string_invalid (); - break; - - case range_constant: - { - Range rj = tmp_j.range_value (); - if (nc == 2 && is_zero_one (rj)) - { - retval = do_matrix_index (magic_colon, 1); - } - else if (nc == 2 && is_one_zero (rj)) - { - retval = do_matrix_index (magic_colon, 0); - } - else - { - if (index_check (rj, "column") < 0) - return tree_constant (); - if (range_max_check (0, tree_to_mat_idx (rj.max ()), nr, nc) < 0) - return tree_constant (); - retval = do_matrix_index (magic_colon, rj); - } - } - break; - - case magic_colon: - retval = do_matrix_index (magic_colon, magic_colon); - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (int i, int j) const -{ - tree_constant retval; - - if (type_tag == matrix_constant) - retval = tree_constant (matrix->elem (i, j)); - else - retval = tree_constant (complex_matrix->elem (i, j)); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (int i, const idx_vector& jv) const -{ - tree_constant retval; - - int jlen = jv.capacity (); - - CRMATRIX (m, cm, 1, jlen); - - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, col); - } - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (int i, const Range& rj) const -{ - tree_constant retval; - - int jlen = rj.nelem (); - - CRMATRIX (m, cm, 1, jlen); - - double b = rj.base (); - double increment = rj.inc (); - for (int j = 0; j < jlen; j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, col); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (int i, TC_REP::constant_type mcj) const -{ - assert (mcj == magic_colon); - - tree_constant retval; - - int nc = columns (); - - CRMATRIX (m, cm, 1, nc); - - for (int j = 0; j < nc; j++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, 0, j, i, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const idx_vector& iv, int j) const -{ - tree_constant retval; - - int ilen = iv.capacity (); - - CRMATRIX (m, cm, ilen, 1); - - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, row, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const idx_vector& iv, const idx_vector& jv) const -{ - tree_constant retval; - - int ilen = iv.capacity (); - int jlen = jv.capacity (); - - CRMATRIX (m, cm, ilen, jlen); - - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const idx_vector& iv, const Range& rj) const -{ - tree_constant retval; - - int ilen = iv.capacity (); - int jlen = rj.nelem (); - - CRMATRIX (m, cm, ilen, jlen); - - double b = rj.base (); - double increment = rj.inc (); - - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - for (int j = 0; j < jlen; j++) - { - double tmp = b + j * increment; - int col = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const idx_vector& iv, - TC_REP::constant_type mcj) const -{ - assert (mcj == magic_colon); - - tree_constant retval; - - int nc = columns (); - int ilen = iv.capacity (); - - CRMATRIX (m, cm, ilen, nc); - - for (int j = 0; j < nc; j++) - { - for (int i = 0; i < ilen; i++) - { - int row = iv.elem (i); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, j); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const Range& ri, int j) const -{ - tree_constant retval; - - int ilen = ri.nelem (); - - CRMATRIX (m, cm, ilen, 1); - - double b = ri.base (); - double increment = ri.inc (); - for (int i = 0; i < ilen; i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, row, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const Range& ri, - const idx_vector& jv) const -{ - tree_constant retval; - - int ilen = ri.nelem (); - int jlen = jv.capacity (); - - CRMATRIX (m, cm, ilen, jlen); - - double b = ri.base (); - double increment = ri.inc (); - for (int i = 0; i < ilen; i++) - { - double tmp = b + i * increment; - int row = tree_to_mat_idx (tmp); - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const Range& ri, const Range& rj) const -{ - tree_constant retval; - - int ilen = ri.nelem (); - int jlen = rj.nelem (); - - CRMATRIX (m, cm, ilen, jlen); - - double ib = ri.base (); - double iinc = ri.inc (); - double jb = rj.base (); - double jinc = rj.inc (); - - for (int i = 0; i < ilen; i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < jlen; j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (const Range& ri, TC_REP::constant_type mcj) const -{ - assert (mcj == magic_colon); - - tree_constant retval; - - int nc = columns (); - - int ilen = ri.nelem (); - - CRMATRIX (m, cm, ilen, nc); - - double ib = ri.base (); - double iinc = ri.inc (); - - for (int i = 0; i < ilen; i++) - { - double itmp = ib + i * iinc; - int row = tree_to_mat_idx (itmp); - for (int j = 0; j < nc; j++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, row, j); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (TC_REP::constant_type mci, int j) const -{ - assert (mci == magic_colon); - - tree_constant retval; - - int nr = rows (); - - CRMATRIX (m, cm, nr, 1); - - for (int i = 0; i < nr; i++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, 0, i, j); - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (TC_REP::constant_type mci, - const idx_vector& jv) const -{ - assert (mci == magic_colon); - - tree_constant retval; - - int nr = rows (); - int jlen = jv.capacity (); - - CRMATRIX (m, cm, nr, jlen); - - for (int i = 0; i < nr; i++) - { - for (int j = 0; j < jlen; j++) - { - int col = jv.elem (j); - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, i, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (TC_REP::constant_type mci, const Range& rj) const -{ - assert (mci == magic_colon); - - tree_constant retval; - - int nr = rows (); - int jlen = rj.nelem (); - - CRMATRIX (m, cm, nr, jlen); - - double jb = rj.base (); - double jinc = rj.inc (); - - for (int j = 0; j < jlen; j++) - { - double jtmp = jb + j * jinc; - int col = tree_to_mat_idx (jtmp); - for (int i = 0; i < nr; i++) - { - CRMATRIX_ASSIGN_REP_ELEM (m, cm, i, j, i, col); - } - } - - ASSIGN_CRMATRIX_TO (retval, m, cm); - - return retval; -} - -tree_constant -TC_REP::do_matrix_index (TC_REP::constant_type mci, - TC_REP::constant_type mcj) const -{ - tree_constant retval; - - assert (mci == magic_colon && mcj == magic_colon); - - switch (type_tag) - { - case complex_scalar_constant: - retval = *complex_scalar; - break; - - case scalar_constant: - retval = scalar; - break; - - case complex_matrix_constant: - retval = *complex_matrix; - break; - - case matrix_constant: - retval = *matrix; - break; - - case range_constant: - retval = *range; - break; - - case string_constant: - retval = string; - break; - - case magic_colon: - default: - panic_impossible (); - break; - } - - return retval; -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/
--- a/src/tc-rep.h Fri Oct 11 21:45:26 1996 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,411 +0,0 @@ -// tc-rep.h -*- C++ -*- -/* - -Copyright (C) 1992, 1993, 1994, 1995 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_const_rep_h) -#define octave_tree_const_rep_h 1 - -// The actual representation of the tree_constant. - -class -tree_constant_rep -{ -friend class tree_constant; - -private: - - enum constant_type - { - unknown_constant, - scalar_constant, - matrix_constant, - complex_scalar_constant, - complex_matrix_constant, - string_constant, - range_constant, - map_constant, - magic_colon, - all_va_args, - }; - - enum force_orient - { - no_orient, - row_orient, - column_orient, - }; - - tree_constant_rep (void); - - tree_constant_rep (double d); - tree_constant_rep (const Matrix& m); - tree_constant_rep (const DiagMatrix& d); - tree_constant_rep (const RowVector& v, int pcv); - tree_constant_rep (const ColumnVector& v, int pcv); - - tree_constant_rep (const Complex& c); - tree_constant_rep (const ComplexMatrix& m); - tree_constant_rep (const ComplexDiagMatrix& d); - tree_constant_rep (const ComplexRowVector& v, int pcv); - tree_constant_rep (const ComplexColumnVector& v, int pcv); - - tree_constant_rep (const char *s); - tree_constant_rep (const Octave_str_obj& s); - - tree_constant_rep (double base, double limit, double inc); - tree_constant_rep (const Range& r); - - tree_constant_rep (const Octave_map& m); - - tree_constant_rep (tree_constant_rep::constant_type t); - - tree_constant_rep (const tree_constant_rep& t); - - ~tree_constant_rep (void); - - void *operator new (size_t size); - void operator delete (void *p, size_t size); - - int rows (void) const; - int columns (void) const; - - int is_defined (void) const - { return type_tag != tree_constant_rep::unknown_constant; } - - int is_undefined (void) const - { return type_tag == tree_constant_rep::unknown_constant; } - - int is_unknown (void) const - { return type_tag == tree_constant_rep::unknown_constant; } - - int is_real_scalar (void) const - { return type_tag == tree_constant_rep::scalar_constant; } - - int is_real_matrix (void) const - { return type_tag == tree_constant_rep::matrix_constant; } - - int is_complex_scalar (void) const - { return type_tag == tree_constant_rep::complex_scalar_constant; } - - int is_complex_matrix (void) const - { return type_tag == tree_constant_rep::complex_matrix_constant; } - - int is_string (void) const - { return type_tag == tree_constant_rep::string_constant; } - - int is_range (void) const - { return type_tag == tree_constant_rep::range_constant; } - - int is_map (void) const - { return type_tag == tree_constant_rep::map_constant; } - - int is_magic_colon (void) const - { return type_tag == tree_constant_rep::magic_colon; } - - int is_all_va_args (void) const - { return type_tag == tree_constant_rep::all_va_args; } - - tree_constant all (void) const; - tree_constant any (void) const; - - int is_real_type (void) const - { - return (type_tag == scalar_constant - || type_tag == matrix_constant - || type_tag == range_constant - || type_tag == string_constant); - } - - int is_complex_type (void) const - { - return (type_tag == complex_matrix_constant - || type_tag == complex_scalar_constant); - } - -// Would be nice to get rid of the next four functions: - - int is_scalar_type (void) const - { - return (type_tag == scalar_constant - || type_tag == complex_scalar_constant); - } - - int is_matrix_type (void) const - { - return (type_tag == matrix_constant - || type_tag == complex_matrix_constant); - } - - int is_numeric_type (void) const - { - return (type_tag == scalar_constant - || type_tag == matrix_constant - || type_tag == complex_matrix_constant - || type_tag == complex_scalar_constant); - } - - int is_numeric_or_range_type (void) const - { - return (type_tag == scalar_constant - || type_tag == matrix_constant - || type_tag == complex_matrix_constant - || type_tag == complex_scalar_constant - || type_tag == range_constant); - } - - int valid_as_scalar_index (void) const; - int valid_as_zero_index (void) const; - - int is_true (void) const; - - int is_empty (void) const - { - return ((! (is_magic_colon () || is_all_va_args () || is_unknown ())) - && (rows () == 0 || columns () == 0)); - } - - double double_value (int force_string_conversion = 0) const; - Matrix matrix_value (int force_string_conversion = 0) const; - Complex complex_value (int force_string_conversion = 0) const; - ComplexMatrix complex_matrix_value (int force_string_conversion = 0) const; - Octave_str_obj all_strings (void) const; - const char *string_value (void) const; - Range range_value (void) const; - Octave_map map_value (void) const; - - tree_constant& lookup_map_element (const char *name, int insert = 0, - int silent = 0); - - ColumnVector vector_value (int force_string_conversion = 0, - int force_vector_conversion = 0) const; - - ComplexColumnVector complex_vector_value (int force_string_conv = 0, - int force_vec_conv = 0) const; - - tree_constant convert_to_str (void) const; - - void convert_to_row_or_column_vector (void); - - void bump_value (tree_expression::type); - - void resize (int i, int j); - void resize (int i, int j, double val); - - void maybe_resize (int imax, force_orient fo = no_orient); - void maybe_resize (int imax, int jmax); - - void stash_original_text (char *s); - - void maybe_mutate (void); - - void print (void); - void print (ostream& os); - - void print_code (ostream& os); - - void gripe_wrong_type_arg (const char *name, - const tree_constant_rep& tcr) const; - - char *type_as_string (void) const; - -// Binary and unary operations. - - friend tree_constant do_binary_op (tree_constant& a, tree_constant& b, - tree_expression::type t); - - friend tree_constant do_unary_op (tree_constant& a, - tree_expression::type t); - -// ------------------------------------------------------------------- - -// We want to eliminate this. - - constant_type const_type (void) const { return type_tag; } - -// We want to get rid of these too: - - void force_numeric (int force_str_conv = 0); - tree_constant make_numeric (int force_str_conv = 0) const; - -// Indexing. - - tree_constant do_index (const Octave_object& args); - - tree_constant do_scalar_index (const Octave_object& args) const; - - tree_constant do_matrix_index (const Octave_object& args) const; - - tree_constant do_matrix_index (const tree_constant& i_arg) const; - - tree_constant do_matrix_index (const tree_constant& i_arg, - const tree_constant& j_arg) const; - - tree_constant do_matrix_index (constant_type i) const; - - tree_constant fortran_style_matrix_index (const tree_constant& i_arg) const; - tree_constant fortran_style_matrix_index (const Matrix& mi) const; - - tree_constant do_vector_index (const tree_constant& i_arg) const; - - tree_constant do_matrix_index (int i, const tree_constant& i_arg) const; - tree_constant do_matrix_index (const idx_vector& i, - const tree_constant& i_arg) const; - tree_constant do_matrix_index (const Range& i, - const tree_constant& i_arg) const; - tree_constant do_matrix_index (constant_type i, - const tree_constant& i_arg) const; - - tree_constant do_matrix_index (int i, int j) const; - tree_constant do_matrix_index (int i, const idx_vector& j) const; - tree_constant do_matrix_index (int i, const Range& j) const; - tree_constant do_matrix_index (int i, constant_type cj) const; - - tree_constant do_matrix_index (const idx_vector& i, int j) const; - tree_constant do_matrix_index (const idx_vector& i, - const idx_vector& j) const; - tree_constant do_matrix_index (const idx_vector& i, const Range& j) const; - tree_constant do_matrix_index (const idx_vector& i, constant_type j) const; - - tree_constant do_matrix_index (const Range& i, int j) const; - tree_constant do_matrix_index (const Range& i, const idx_vector& j) const; - tree_constant do_matrix_index (const Range& i, const Range& j) const; - tree_constant do_matrix_index (const Range& i, constant_type j) const; - - tree_constant do_matrix_index (constant_type i, int j) const; - tree_constant do_matrix_index (constant_type i, const idx_vector& j) const; - tree_constant do_matrix_index (constant_type i, const Range& j) const; - tree_constant do_matrix_index (constant_type i, constant_type j) const; - -// Assignment. - - void assign (tree_constant& rhs, const Octave_object& args); - - void do_scalar_assignment (const tree_constant& rhs, - const Octave_object& args); - - void do_matrix_assignment (const tree_constant& rhs, - const Octave_object& args); - - void do_matrix_assignment (const tree_constant& rhs, - const tree_constant& i_arg); - - void fortran_style_matrix_assignment (const tree_constant& rhs, - const tree_constant& i_arg); - - void fortran_style_matrix_assignment (const tree_constant& rhs, - constant_type ci); - - void fortran_style_matrix_assignment (const tree_constant& rhs, - idx_vector& i); - - void vector_assignment (const tree_constant& rhs, - const tree_constant& i_arg); - - void check_vector_assign (int rhs_nr, int rhs_nc, int ilen, - const char *rm); - - void do_vector_assign (const tree_constant& rhs, int i); - void do_vector_assign (const tree_constant& rhs, idx_vector& i); - void do_vector_assign (const tree_constant& rhs, Range& i); - - void do_matrix_assignment (const tree_constant& rhs, - const tree_constant& i_arg, - const tree_constant& j_arg); - - void do_matrix_assignment (const tree_constant& rhs, int i, - const tree_constant& j_arg); - void do_matrix_assignment (const tree_constant& rhs, idx_vector& i, - const tree_constant& j_arg); - void do_matrix_assignment (const tree_constant& rhs, Range& i, - const tree_constant& j_arg); - void do_matrix_assignment (const tree_constant& rhs, constant_type i, - const tree_constant& j_arg); - - void do_matrix_assignment (const tree_constant& rhs, int i, int j); - void do_matrix_assignment (const tree_constant& rhs, int i, idx_vector& jv); - void do_matrix_assignment (const tree_constant& rhs, int i, Range& j); - void do_matrix_assignment (const tree_constant& rhs, int i, constant_type cj); - - void do_matrix_assignment (const tree_constant& rhs, idx_vector& iv, - int j); - void do_matrix_assignment (const tree_constant& rhs, idx_vector& iv, - idx_vector& jv); - void do_matrix_assignment (const tree_constant& rhs, idx_vector& iv, - Range& j); - void do_matrix_assignment (const tree_constant& rhs, idx_vector& iv, - constant_type j); - - void do_matrix_assignment (const tree_constant& rhs, Range& i, int j); - void do_matrix_assignment (const tree_constant& rhs, Range& i, - idx_vector& jv); - void do_matrix_assignment (const tree_constant& rhs, Range& i, - Range& j); - void do_matrix_assignment (const tree_constant& rhs, Range& i, - constant_type j); - - void do_matrix_assignment (const tree_constant& rhs, constant_type i, int j); - void do_matrix_assignment (const tree_constant& rhs, constant_type i, - idx_vector& jv); - void do_matrix_assignment (const tree_constant& rhs, constant_type i, - Range& j); - void do_matrix_assignment (const tree_constant& rhs, - const constant_type i, - constant_type j); - - void delete_row (int); - void delete_rows (idx_vector& i); - void delete_rows (Range& i); - - void delete_column (int); - void delete_columns (idx_vector& j); - void delete_columns (Range& j); - -// Data. - - union - { - double scalar; // A real scalar constant. - Matrix *matrix; // A real matrix constant. - Complex *complex_scalar; // A real scalar constant. - ComplexMatrix *complex_matrix; // A real matrix constant. - Octave_str_obj *str_obj; // A character string constant. - Range *range; // A set of evenly spaced values. - Octave_map *a_map; // An associative array. - - tree_constant_rep *freeptr; // For custom memory management. - }; - - constant_type type_tag; - - int count; - - char *orig_text; -}; - -#endif - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; page-delimiter: "^/\\*" *** -;;; End: *** -*/