Mercurial > octave-nkf
changeset 581:bc813f5eb025
[project @ 1994-08-07 01:02:15 by jwe]
| author | jwe |
|---|---|
| date | Sun, 07 Aug 1994 01:02:15 +0000 |
| parents | b0204e676508 |
| children | 129f0b19ab48 |
| files | src/error.cc src/help.cc src/input.cc src/lex.l src/oct-hist.cc src/octave.cc src/pager.cc src/pager.h src/parse.y src/pt-base.h src/pt-cmd.cc src/pt-cmd.h src/pt-const.cc src/pt-const.h src/pt-exp-base.cc src/pt-exp-base.h src/pt-misc.cc src/pt-misc.h src/pt-plot.cc src/pt-plot.h src/tc-inlines.h src/tc-rep.cc src/tc-rep.h src/token.cc src/token.h src/utils.cc src/variables.cc src/variables.h |
| diffstat | 28 files changed, 2926 insertions(+), 1678 deletions(-) [+] |
line wrap: on
line diff
--- a/src/error.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/error.cc Sun Aug 07 01:02:15 1994 +0000 @@ -25,8 +25,7 @@ #include "config.h" #endif -#include <stdio.h> -#include <stdlib.h> +#include <strstream.h> #include <stdarg.h> #include "utils.h" @@ -42,12 +41,21 @@ static void verror (const char *name, const char *fmt, va_list args) { - if (name) - fprintf (stderr, "%s: ", name); + cerr << name << ": "; + cerr.vform (fmt, args); + cerr << endl; + + ostrstream output_buf; - vfprintf (stderr, fmt, args); - fprintf (stderr, "\n"); - fflush (stderr); + output_buf << name << ": "; + output_buf.vform (fmt, args); + output_buf << endl; + + char *msg = output_buf.str (); + + maybe_write_to_diary_file (msg); + + delete [] msg; } void
--- a/src/help.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/help.cc Sun Aug 07 01:02:15 1994 +0000 @@ -30,7 +30,8 @@ #include <iostream.h> #include <strstream.h> -#include "tree.h" +#include "tree-expr.h" +#include "tree-const.h" #include "sighandlers.h" #include "user-prefs.h" #include "tree-expr.h" @@ -249,9 +250,8 @@ { 0, 0, }, }; -/* - * Return a copy of the operator or keyword names. - */ +// Return a copy of the operator or keyword names. + char ** names (help_list *lst, int& count) { @@ -556,8 +556,6 @@ { ostrstream output_buf; - char *fcn_file_name = 0; - symbol_record *sym_rec; help_list *op_help_list = operator_help (); help_list *kw_help_list = keyword_help (); @@ -574,7 +572,8 @@ if (help_from_list (output_buf, kw_help_list, *argv, 0)) continue; - sym_rec = curr_sym_tab->lookup (*argv, 0, 0); + symbol_record *sym_rec = lookup_by_name (*argv); + if (sym_rec) { char *h = sym_rec->help (); @@ -586,43 +585,8 @@ } } - sym_rec = global_sym_tab->lookup (*argv, 0, 0); - if (sym_rec && ! symbol_out_of_date (sym_rec)) - { - char *h = sym_rec->help (); - if (h && *h) - { - 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) - { - sym_rec = global_sym_tab->lookup (*argv, 1, 0); - if (sym_rec) - { - tree_identifier tmp (sym_rec); - tmp.load_fcn_from_file (0); - char *h = sym_rec->help (); - if (h && *h) - { - output_buf << "\n*** " << *argv << ":\n\n" - << h << "\n"; - continue; - } - } - } - delete [] fcn_file_name; - output_buf << "\nhelp: sorry, `" << *argv - << "' is not documented\n"; + << "' is not documented\n"; } additional_help_message (output_buf); @@ -636,6 +600,193 @@ return retval; } +DEFUN_TEXT ("type", Ftype, Stype, -1, 1, + "type NAME ...]\n\ +\n\ +display the definition of each NAME that refers to a function") +{ + Octave_object retval; + + DEFINE_ARGV("type"); + + if (argc > 1) + { +// XXX FIXME XXX -- we should really use getopt () + int quiet = 0; + if (argv[1] && strcmp (argv[1], "-q") == 0) + { + quiet = 1; + argc--; + argv++; + } + + ostrstream output_buf; + + while (--argc > 0) + { + argv++; + + if (! *argv || ! **argv) + continue; + + symbol_record *sym_rec = lookup_by_name (*argv); + + if (sym_rec) + { + if (sym_rec->is_user_function ()) + { + tree_fvc *defn = sym_rec->def (); + + if (nargout == 0 && ! quiet) + output_buf << *argv << " is a user-defined function\n"; + + defn->print_code (output_buf); + } + +// XXX FIXME XXX -- this code should be shared with Fwhich + + else if (sym_rec->is_text_function ()) + output_buf << *argv << " is a builtin text-function\n"; + else if (sym_rec->is_builtin_function ()) + output_buf << *argv << " is a builtin function\n"; + else if (sym_rec->is_user_variable ()) + output_buf << *argv << " is a user-defined variable\n"; + else if (sym_rec->is_builtin_variable ()) + output_buf << *argv << " is a builtin variable\n"; + else + output_buf << "type: `" << *argv << "' has unknown type!\n"; + } + else + output_buf << "type: `" << *argv << "' undefined\n"; + } + + output_buf << ends; + + if (nargout == 0) + maybe_page_output (output_buf); + else + { + char *s = output_buf.str (); + retval = s; + delete s; + } + } + else + print_usage ("type"); + + DELETE_ARGV; + + return retval; +} + +DEFUN_TEXT ("which", Fwhich, Swhich, -1, 1, + "which NAME ...]\n\ +\n\ +display the type of each NAME. If NAME is defined from an function\n\ +file, print the full name of the file.") +{ + Octave_object retval; + + DEFINE_ARGV("which"); + + if (argc > 1) + { + if (nargout > 0) + retval.resize (argc-1, Matrix ()); + + ostrstream output_buf; + + for (int i = 0; i < argc-1; i++) + { + argv++; + + if (! *argv || ! **argv) + continue; + + symbol_record *sym_rec = lookup_by_name (*argv); + + if (sym_rec) + { + if (sym_rec->is_user_function ()) + { + tree_fvc *defn = sym_rec->def (); + char *fn = defn->fcn_file_name (); + if (fn) + { + char *ff = fcn_file_in_path (fn); + ff = ff ? ff : fn; + + if (nargout == 0) + output_buf << *argv + << " is the function defined from:\n" + << ff << "\n"; + else + retval(i) = ff; + } + else + { + if (nargout == 0) + output_buf << *argv << " is a user-defined function\n"; + else + retval(i) = "user-defined function"; + } + } + else if (sym_rec->is_text_function ()) + { + if (nargout == 0) + output_buf << *argv << " is a builtin text-function\n"; + else + retval(i) = "builtin text-function"; + } + else if (sym_rec->is_builtin_function ()) + { + if (nargout == 0) + output_buf << *argv << " is a builtin function\n"; + else + retval(i) = "builtin function"; + } + else if (sym_rec->is_user_variable ()) + { + if (nargout == 0) + output_buf << *argv << " is a user-defined variable\n"; + else + retval(i) = "user-defined variable"; + } + else if (sym_rec->is_builtin_variable ()) + { + if (nargout == 0) + output_buf << *argv << " is a builtin variable\n"; + else + retval(i) = "builtin variable"; + } + else + { + if (nargout == 0) + output_buf << "which: `" << *argv + << "' has unknown type\n"; + else + retval(i) = "unknown type"; + } + } + else + { + if (nargout == 0) + output_buf << "which: `" << *argv << "' is undefined\n"; + else + retval(i) = "undefined"; + } + } + output_buf << ends; + maybe_page_output (output_buf); + } + else + print_usage ("which"); + + DELETE_ARGV; + + return retval; +} + /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/input.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/input.cc Sun Aug 07 01:02:15 1994 +0000 @@ -48,10 +48,9 @@ extern char *xmalloc (); -/* - * Yes, this sucks, but it avoids a conflict with another readline - * function declared in iostream.h. - */ +// Yes, this sucks, but it avoids a conflict with another readline +// function declared in iostream.h. + #if 0 #define LINE_SIZE 8192 static int no_line_editing = 0; @@ -152,12 +151,11 @@ extern tree_constant eval_string (const char *string, int print, int ans_assign, int& parse_status); -/* - * Append SOURCE to TARGET at INDEX. SIZE is the current amount of - * space allocated to TARGET. SOURCE can be NULL, in which case - * nothing happens. Gets rid of SOURCE by free ()ing it. Returns - * TARGET in case the location has changed. - */ +// Append SOURCE to TARGET at INDEX. SIZE is the current amount of +// space allocated to TARGET. SOURCE can be NULL, in which case +// nothing happens. Gets rid of SOURCE by free ()ing it. Returns +// TARGET in case the location has changed. + static char * sub_append_string (char *source, char *target, int *index, int *size) { @@ -179,10 +177,9 @@ return target; } -/* - * Return the octal number parsed from STRING, or -1 to indicate that - * the string contained a bad number. - */ +// Return the octal number parsed from STRING, or -1 to indicate that +// the string contained a bad number. + int read_octal (const char *string) { @@ -201,24 +198,23 @@ return result; } -/* - * Return a string which will be printed as a prompt. The string may - * contain special characters which are decoded as follows: - * - * \t the time - * \d the date - * \n CRLF - * \s the name of the shell (program) - * \w the current working directory - * \W the last element of PWD - * \u your username - * \h the hostname - * \# the command number of this command - * \! the history number of this command - * \$ a $ or a # if you are root - * \<octal> character code in octal - * \\ a backslash - */ +// Return a string which will be printed as a prompt. The string may +// contain special characters which are decoded as follows: +// +// \t the time +// \d the date +// \n CRLF +// \s the name of the shell (program) +// \w the current working directory +// \W the last element of PWD +// \u your username +// \h the hostname +// \# the command number of this command +// \! the history number of this command +// \$ a $ or a # if you are root +// \<octal> character code in octal +// \\ a backslash + static char * decode_prompt_string (const char *string) { @@ -385,7 +381,7 @@ result = (char *)sub_append_string (temp, result, &result_index, &result_size); - temp = 0; /* Free ()'ed in sub_append_string (). */ + temp = 0; // Free ()'ed in sub_append_string (). result[result_index] = '\0'; break; } @@ -405,7 +401,7 @@ } #if 0 - /* I don't really think that this is a good idea. Do you? */ +// I don't really think that this is a good idea. Do you? if (! find_variable ("NO_PROMPT_VARS")) { WORD_LIST *expand_string (), *list; @@ -420,10 +416,10 @@ return result; } -/* - * Use GNU readline to get an input line and store it in the history - * list. - */ + +// Use GNU readline to get an input line and store it in the history +// list. + static char * octave_gets (void) { @@ -444,7 +440,10 @@ flush_output_to_pager (); } + maybe_write_to_diary_file (prompt); + octave_gets_line = gnu_readline (prompt); + delete [] prompt; } else @@ -456,6 +455,8 @@ { maybe_save_history (octave_gets_line); + maybe_write_to_diary_file (octave_gets_line); + if (echo_input) { if (! forced_interactive) @@ -464,12 +465,14 @@ cout << octave_gets_line << "\n"; } } + + maybe_write_to_diary_file ("\n"); + return octave_gets_line; } -/* - * Read a line from the input stream. - */ +// Read a line from the input stream. + int octave_read (char *buf, int max_size) { @@ -561,10 +564,9 @@ return status; } -/* - * Fix things up so that input can come from file `name', printing a - * warning if the file doesn't exist. - */ +// Fix things up so that input can come from file `name', printing a +// warning if the file doesn't exist. + FILE * get_input_from_file (char *name, int warn) { @@ -584,11 +586,10 @@ return instream; } -/* - * Fix things up so that input can come from the standard input. This - * may need to become much more complicated, which is why it's in a - * separate function. - */ +// Fix things up so that input can come from the standard input. This +// may need to become much more complicated, which is why it's in a +// separate function. + FILE * get_input_from_stdin (void) { @@ -643,11 +644,9 @@ return matches; } -/* - * The next two functions implement the equivalent of the K*rn shell - * C-o operate-and-get-next-history-line editing command. Stolen from - * the GNU Bourne Again SHell. - */ +// The next two functions implement the equivalent of the K*rn shell +// C-o operate-and-get-next-history-line editing command. Stolen from +// the GNU Bourne Again SHell. // ?? static int saved_history_line_to_use = 0; @@ -691,10 +690,10 @@ int where; extern int history_stifled, history_length, max_input_history; - /* Accept the current line. */ +// Accept the current line. rl_newline (); - /* Find the current line, and find the next line to use. */ +// Find the current line, and find the next line to use. where = where_history (); if (history_stifled && (history_length >= max_input_history)) @@ -736,6 +735,8 @@ return (strncmp (standard, tp, len) == 0); } +// If the user simply hits return, this will produce an empty matrix. + static Octave_object get_user_input (const Octave_object& args, int nargout, int debug = 0) { @@ -790,8 +791,13 @@ { int parse_status = 0; retval = eval_string (input_buf, 0, 0, parse_status); - if (debug && retval.is_defined ()) - retval.eval (1); + if (retval.is_defined ()) + { + if (debug) + retval.eval (1); + } + else + retval = tree_constant (Matrix ()); } } else
--- a/src/lex.l Sun Aug 07 01:02:15 1994 +0000 +++ b/src/lex.l Sun Aug 07 01:02:15 1994 +0000 @@ -423,7 +423,7 @@ convert_spaces_to_comma = 1; if (plotting && ! in_plot_range) past_plot_range = 1; - yylval.tok_val = new token (value, + yylval.tok_val = new token (value, yytext, input_line_number, current_input_column); token_stack.push (yylval.tok_val); @@ -444,7 +444,7 @@ convert_spaces_to_comma = 1; if (plotting && ! in_plot_range) past_plot_range = 1; - yylval.tok_val = new token (value, + yylval.tok_val = new token (value, yytext, input_line_number, current_input_column); token_stack.push (yylval.tok_val);
--- a/src/oct-hist.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/oct-hist.cc Sun Aug 07 01:02:15 1994 +0000 @@ -38,7 +38,6 @@ #endif #include <fcntl.h> #include <stdlib.h> -#include <stdio.h> #include <string.h> #include <signal.h> #include <fstream.h> @@ -48,6 +47,7 @@ #include "utils.h" #include "error.h" #include "input.h" +#include "pager.h" #include "octave.h" #include "oct-obj.h" #include "user-prefs.h" @@ -79,10 +79,9 @@ // The number of history lines we've saved so far. static int history_lines_this_session = 0; -/* - * Get some default values, possibly reading them from the - * environment. - */ +// Get some default values, possibly reading them from the +// environment. + static int default_history_size (void) { @@ -119,9 +118,8 @@ return file; } -/* - * Prime the history list. - */ +// Prime the history list. + void initialize_history (void) { @@ -150,13 +148,12 @@ } } -/* - * Display, save, or load history. Stolen and modified from bash. - * - * Arg of -w FILENAME means write file, arg of -r FILENAME - * means read file, arg of -q means don't number lines. Arg of N - * means only display that many items. - */ +// Display, save, or load history. Stolen and modified from bash. +// +// Arg of -w FILENAME means write file, arg of -r FILENAME +// means read file, arg of -q means don't number lines. Arg of N +// means only display that many items. + void do_history (int argc, char **argv) { @@ -271,23 +268,28 @@ if ((i -= limit) < 0) i = 0; + ostrstream output_buf; + while (hlist[i]) { // QUIT; // in bash: (interrupt_state) throw_to_top_level (); if (numbered_output) - cerr.form ("%5d%c", i + history_base, hlist[i]->data ? '*' : ' '); - cerr << hlist[i]->line << "\n"; + output_buf.form ("%5d%c", i + history_base, + hlist[i]->data ? '*' : ' '); + output_buf << hlist[i]->line << "\n"; i++; } + + output_buf << ends; + maybe_page_output (output_buf); } } -/* - * Read the edited history lines from STREAM and return them - * one at a time. This can read unlimited length lines. The - * caller should free the storage. - */ +// Read the edited history lines from STREAM and return them +// one at a time. This can read unlimited length lines. The +// caller should free the storage. + static char * edit_history_readline (fstream& stream) { @@ -343,13 +345,12 @@ HIST_ENTRY *history_get (); } -/* - * Use `command' to replace the last entry in the history list, which, - * by this time, is `run_history blah...'. The intent is that the - * new command become the history entry, and that `fc' should never - * appear in the history list. This way you can do `run_history' to - * your heart's content. - */ +// Use `command' to replace the last entry in the history list, which, +// by this time, is `run_history blah...'. The intent is that the +// new command become the history entry, and that `fc' should never +// appear in the history list. This way you can do `run_history' to +// your heart's content. + static void edit_history_repl_hist (char *command) { @@ -365,8 +366,7 @@ ; // Count 'em. i--; - /* History_get () takes a parameter that should be - offset by history_base. */ +// History_get () takes a parameter that should be offset by history_base. // Don't free this. HIST_ENTRY *histent = history_get (history_base + i);
--- a/src/octave.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/octave.cc Sun Aug 07 01:02:15 1994 +0000 @@ -171,9 +171,8 @@ { 0, 0, 0, 0 } }; -/* - * Initialize some global variables for later use. - */ +// Initialize some global variables for later use. + static void initialize_globals (char *name) { @@ -281,9 +280,8 @@ run_unwind_frame ("parse_and_execute_2"); } -/* - * Initialize by reading startup files. - */ +// Initialize by reading startup files. + static void execute_startup_files (void) { @@ -324,9 +322,8 @@ run_unwind_frame ("execute_startup_files"); } -/* - * Usage message with extra help. - */ +// Usage message with extra help. + static void verbose_usage (void) { @@ -351,9 +348,8 @@ exit (1); } -/* - * Terse usage messsage. - */ +// Terse usage messsage. + static void usage (void) { @@ -361,9 +357,8 @@ exit (1); } -/* - * Fix up things before exiting. - */ +// Fix up things before exiting. + void clean_up_and_exit (int retval) { @@ -373,6 +368,8 @@ close_plot_stream (); + close_diary_file (); + close_files (); cleanup_tmp_files (); @@ -398,9 +395,8 @@ exit (0); } -/* - * You guessed it. - */ +// You guessed it. + int main (int argc, char **argv) { @@ -466,18 +462,18 @@ atexit (cleanup_tmp_files); #endif + initialize_pager (); + initialize_history (); initialize_file_io (); - initialize_symbol_tables (); + initialize_symbol_tables (); install_builtins (); initialize_readline (); - initialize_pager (); - install_signal_handlers (); if (! inhibit_startup_message) @@ -768,9 +764,8 @@ return retval; } -/* - * Execute a shell command. - */ +// Execute a shell command. + DEFUN ("shell_cmd", Fshell_cmd, Sshell_cmd, 2, 1, "shell_cmd (string [, return_output]): execute shell commands") {
--- a/src/pager.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pager.cc Sun Aug 07 01:02:15 1994 +0000 @@ -27,17 +27,32 @@ #include <iostream.h> #include <strstream.h> +#include <fstream.h> #include <stdlib.h> #include "procstream.h" #include "user-prefs.h" +#include "oct-obj.h" +#include "error.h" +#include "defun.h" #include "input.h" #include "pager.h" +#include "utils.h" +#include "help.h" // Where we stash output headed for the screen. static ostrstream *pager_buf = 0; +// Nonzero means we write to the diary file. +static int write_to_diary_file = 0; + +// The name of the current diary file. +static char *diary_file = "diary"; + +// The diary file. +static ofstream diary_stream; + static int line_count (char *s) { @@ -52,13 +67,12 @@ return count; } -/* - * For now, use the variables from readline. It already handles - * SIGWINCH, so these values have a good chance of being correct even - * if the window changes size (they will be wrong if, for example, the - * luser changes the window size while the pager is running, and the - * signal is handled by the pager instead of us. - */ +// For now, use the variables from readline. It already handles +// SIGWINCH, so these values have a good chance of being correct even +// if the window changes size (they will be wrong if, for example, the +// luser changes the window size while the pager is running, and the +// signal is handled by the pager instead of us. + int terminal_columns (void) { @@ -116,6 +130,8 @@ return; } + maybe_write_to_diary_file (message); + int nlines = line_count (message); if (nlines > terminal_rows () - 2) @@ -142,6 +158,76 @@ initialize_pager (); } +static void +open_diary_file (void) +{ + if (diary_stream.is_open ()) + diary_stream.close (); + + diary_stream.open (diary_file, ios::app); + + if (! diary_stream) + error ("diary: can't open diary file `%s'", diary_file); +} + +void +close_diary_file (void) +{ + if (diary_stream) + diary_stream.close (); +} + +void +maybe_write_to_diary_file (const char *s) +{ + if (write_to_diary_file && diary_stream) + diary_stream << s; +} + +DEFUN_TEXT ("diary", Fdiary, Sdiary, -1, 1, + "diary [on|off]\n\ +diary [file]\n\ +\n\ +redirect all input and screen output to a file.") +{ + Octave_object retval; + + DEFINE_ARGV("diary"); + + switch (argc) + { + case 1: + write_to_diary_file = ! write_to_diary_file; + open_diary_file (); + break; + case 2: + { + char *arg = argv[1]; + if (strcmp (arg, "on") == 0) + { + write_to_diary_file = 1; + open_diary_file (); + } + else if (strcmp (arg, "off") == 0) + write_to_diary_file = 0; + else + { + delete [] diary_file; + diary_file = strsave (arg); + open_diary_file (); + } + } + break; + default: + print_usage ("diary"); + break; + } + + DELETE_ARGV; + + return retval; +} + /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/pager.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pager.h Sun Aug 07 01:02:15 1994 +0000 @@ -33,6 +33,9 @@ extern void maybe_page_output (ostrstream& msg_buf); extern void flush_output_to_pager (void); +extern void close_diary_file (void); +extern void maybe_write_to_diary_file (const char *s); + #endif /*
--- a/src/parse.y Sun Aug 07 01:02:15 1994 +0000 +++ b/src/parse.y Sun Aug 07 01:02:15 1994 +0000 @@ -32,25 +32,28 @@ #include "config.h" #endif +#include <strstream.h> + #include "SLStack.h" #include "Matrix.h" -#include "error.h" -#include "octave.h" -#include "variables.h" #include "octave-hist.h" #include "user-prefs.h" +#include "tree-const.h" +#include "tree-misc.h" +#include "variables.h" +#include "tree-plot.h" +#include "octave.h" +#include "symtab.h" +#include "parse.h" +#include "token.h" +#include "error.h" +#include "pager.h" #include "input.h" #include "utils.h" #include "tree.h" -#include "tree-misc.h" -#include "tree-plot.h" -#include "tree-const.h" -#include "symtab.h" -#include "parse.h" #include "lex.h" -#include "token.h" // Nonzero means we're in the middle of defining a function. int defining_func = 0; @@ -563,7 +566,7 @@ { tree_simple_assignment_expression *tmp_ass; tmp_ass = new tree_simple_assignment_expression - ($1, $3, 0, $2->line (), $2->column ()); + ($1, $3, 0, 0, $2->line (), $2->column ()); $$ = new tree_global (tmp_ass); } ; @@ -693,7 +696,7 @@ expression : variable '=' expression { $$ = new tree_simple_assignment_expression - ($1, $3, 0, $2->line (), $2->column ()); } + ($1, $3, 0, 0, $2->line (), $2->column ()); } | '[' screwed_again matrix_row SCREW_TWO '=' expression { @@ -784,15 +787,23 @@ ; simple_expr1 : NUM - { $$ = new tree_constant ($1->number ()); } + { + tree_constant *tmp = new tree_constant ($1->number ()); + tmp->stash_original_text ($1->text_rep ()); + $$ = tmp; + } | IMAG_NUM - { $$ = new tree_constant (Complex (0.0, $1->number ())); } + { + Complex c (0.0, $1->number ()); + tree_constant *tmp = new tree_constant (c); + tmp->stash_original_text ($1->text_rep ()); + $$ = tmp; + } | TEXT { $$ = new tree_constant ($1->string ()); } | '(' expression ')' { - if ($2->is_assignment_expression ()) - ((tree_assignment_expression *) $2) -> in_parens++; + $2->in_parens++; $$ = $2; } | word_list_cmd @@ -1129,13 +1140,16 @@ if (err_col == 0 && line) err_col = strlen (line) + 1; -// Print a message like `parse error'. - fprintf (stderr, "\n%s", s); +// Print a message like `parse error', maybe printing the line number +// and file name. + + ostrstream output_buf; -// Maybe print the line number and file name. + output_buf.form ("\n%s", s); + if (reading_fcn_file || reading_script_file) - fprintf (stderr, " near line %d of file %s.m", input_line_number, - curr_fcn_file_name); + output_buf.form (" near line %d of file %s.m", input_line_number, + curr_fcn_file_name); if (line) { @@ -1147,12 +1161,14 @@ } // Print the line, maybe with a pointer near the error token. if (err_col > len) - fprintf (stderr, ":\n\n %s\n\n", line); + output_buf.form (":\n\n %s\n\n", line); else - fprintf (stderr, ":\n\n %s\n %*s\n\n", line, err_col, "^"); + output_buf.form (":\n\n %s\n %*s\n\n", line, err_col, "^"); } else - fprintf (stderr, "\n\n"); + output_buf << "\n\n"; + + maybe_page_output (output_buf); } static void @@ -1252,7 +1268,7 @@ tree_identifier *ans = new tree_identifier (sr); - return new tree_simple_assignment_expression (ans, expr); + return new tree_simple_assignment_expression (ans, expr, 0, 1); } } @@ -1261,7 +1277,7 @@ { if (user_pref.warn_assign_as_truth_value && expr->is_assignment_expression () - && ((tree_assignment_expression *) expr) -> in_parens < 2) + && expr->in_parens < 2) { warning ("suggest parenthesis around assignment used as truth value"); }
--- a/src/pt-base.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-base.h Sun Aug 07 01:02:15 1994 +0000 @@ -24,13 +24,42 @@ #if !defined (octave_tree_base_h) #define octave_tree_base_h 1 -class tree_constant; +class ostream; + +// How to print the code that the trees represent. + +class +tree_print_code +{ +public: + virtual ~tree_print_code (void) { } + + virtual void print_code (ostream& os) = 0; + + void reset_indent_level (void) + { curr_print_indent_level = 0; } + + void increment_indent_level (void) + { curr_print_indent_level += 2; } -/* - * Base class for the parse tree. - */ + void decrement_indent_level (void) + { curr_print_indent_level -= 2; } + + void print_code_new_line (ostream& os); + + void print_code_indent (ostream& os); + + void print_code_reset (void); + +private: + static int curr_print_indent_level; + static int beginning_of_line; +}; + +// Base class for the parse tree. + class -tree +tree : public tree_print_code { public: tree (int l = -1, int c = -1) @@ -39,11 +68,11 @@ column_num = c; } - virtual ~tree (void) { } + virtual int line (void) const + { return line_num; } - virtual int line (void) const { return line_num; } - - virtual int column (void) const { return column_num; } + virtual int column (void) const + { return column_num; } private: int line_num;
--- a/src/pt-cmd.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-cmd.cc Sun Aug 07 01:02:15 1994 +0000 @@ -114,6 +114,17 @@ line (), column ()); } +void +tree_global_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "global "; + + if (init_list) + init_list->print_code (os); +} + // While. tree_while_command::~tree_while_command (void) @@ -195,6 +206,30 @@ line (), column ()); } +void +tree_while_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "while "; + + if (expr) + expr->print_code (os); + + print_code_new_line (os); + + if (list) + { + increment_indent_level (); + list->print_code (os); + decrement_indent_level (); + } + + print_code_indent (os); + + os << "endwhile"; +} + // For. tree_for_command::~tree_for_command (void) @@ -342,6 +377,35 @@ quit = quit_loop_now (); } +void +tree_for_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "for "; + + if (id) + id->print_code (os); + + os << " = "; + + if (expr) + expr->print_code (os); + + print_code_new_line (os); + + if (list) + { + increment_indent_level (); + list->print_code (os); + decrement_indent_level (); + } + + print_code_indent (os); + + os << "endfor"; +} + // If. tree_if_command::~tree_if_command (void) @@ -360,6 +424,21 @@ line (), column ()); } +void +tree_if_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "if "; + + if (list) + list->print_code (os); + + print_code_indent (os); + + os << "endif"; +} + // Break. void @@ -369,6 +448,14 @@ breaking = 1; } +void +tree_break_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "break"; +} + // Continue. void @@ -378,6 +465,14 @@ continuing = 1; } +void +tree_continue_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "continue"; +} + // Return. void @@ -387,6 +482,14 @@ returning = 1; } +void +tree_return_command::print_code (ostream& os) +{ + print_code_indent (os); + + os << "return"; +} + /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/pt-cmd.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-cmd.h Sun Aug 07 01:02:15 1994 +0000 @@ -28,6 +28,8 @@ #pragma interface #endif +#include <iostream.h> + class tree_statement_list; class tree_global_init_list; class tree_if_command_list; @@ -73,6 +75,8 @@ void eval (void); + void print_code (ostream& os); + private: tree_global_init_list *init_list; }; @@ -110,6 +114,8 @@ void eval_error (void); + void print_code (ostream& os); + private: tree_expression *expr; // Expression to test. tree_statement_list *list; // List of commands to execute. @@ -143,6 +149,8 @@ void eval_error (void); + void print_code (ostream& os); + private: void do_for_loop_once (tree_constant *rhs, int& quit); @@ -170,6 +178,8 @@ void eval_error (void); + void print_code (ostream& os); + private: tree_if_command_list *list; }; @@ -185,6 +195,8 @@ ~tree_break_command (void) { } void eval (void); + + void print_code (ostream& os); }; // Continue. @@ -198,6 +210,8 @@ ~tree_continue_command (void) { } void eval (void); + + void print_code (ostream& os); }; // Return. @@ -211,6 +225,8 @@ ~tree_return_command (void) { } void eval (void); + + void print_code (ostream& os); }; #endif
--- a/src/pt-const.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-const.cc Sun Aug 07 01:02:15 1994 +0000 @@ -29,6 +29,8 @@ #pragma implementation #endif +#include <iostream.h> + #include "tree-const.h" #include "error.h" #include "gripes.h" @@ -65,10 +67,9 @@ } #endif -/* - * Construct return vector of empty matrices. Return empty matrices - * and/or gripe when appropriate. - */ +// Construct return vector of empty matrices. Return empty matrices +// and/or gripe when appropriate. + Octave_object vector_of_empties (int nargout, const char *fcn_name) { @@ -93,6 +94,21 @@ return retval; } +void +tree_constant::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (rep) + rep->print_code (os); + + if (in_parens) + os << ")"; +} + /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/pt-const.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-const.h Sun Aug 07 01:02:15 1994 +0000 @@ -28,6 +28,8 @@ #pragma interface #endif +#include <iostream.h> + #include <stdlib.h> #include "mx-base.h" @@ -42,55 +44,52 @@ struct Mapper_fcn; -/* - * Constants. - */ +// Constants. + class tree_constant : public tree_fvc { friend class tree_constant_rep; public: - tree_constant (void) + tree_constant (void) : tree_fvc () { rep = new tree_constant_rep (); rep->count = 1; } - tree_constant (double d) + tree_constant (double d) : tree_fvc () { rep = new tree_constant_rep (d); rep->count = 1; } - tree_constant (const Matrix& m) + tree_constant (const Matrix& m) : tree_fvc () { rep = new tree_constant_rep (m); rep->count = 1; } - tree_constant (const DiagMatrix& d) + tree_constant (const DiagMatrix& d) : tree_fvc () { rep = new tree_constant_rep (d); rep->count = 1; } - tree_constant (const RowVector& v, int pcv = -1) + tree_constant (const RowVector& v, int pcv = -1) : tree_fvc () { rep = new tree_constant_rep (v, pcv); rep->count = 1; } - tree_constant (const ColumnVector& v, int pcv = -1) + tree_constant (const ColumnVector& v, int pcv = -1) : tree_fvc () { rep = new tree_constant_rep (v, pcv); rep->count = 1; } - tree_constant (const Complex& c) + tree_constant (const Complex& c) : tree_fvc () { rep = new tree_constant_rep (c); rep->count = 1; } - tree_constant (const ComplexMatrix& m) + tree_constant (const ComplexMatrix& m) : tree_fvc () { rep = new tree_constant_rep (m); rep->count = 1; } - tree_constant (const ComplexDiagMatrix& d) + tree_constant (const ComplexDiagMatrix& d) : tree_fvc () { rep = new tree_constant_rep (d); rep->count = 1; } - tree_constant (const ComplexRowVector& v, int pcv = -1) - { rep = new tree_constant_rep (v, pcv); rep->count = 1; } - tree_constant (const ComplexColumnVector& v, int pcv = -1) - { rep = new tree_constant_rep (v, pcv); rep->count = 1; } + tree_constant (const ComplexRowVector& v, int pcv = -1) : tree_fvc () + { rep = new tree_constant_rep (v, pcv); rep->count = 1; } + tree_constant (const ComplexColumnVector& v, int pcv = -1) : tree_fvc () + { rep = new tree_constant_rep (v, pcv); rep->count = 1; } - tree_constant (const char *s) + tree_constant (const char *s) : tree_fvc () { rep = new tree_constant_rep (s); rep->count = 1; } - tree_constant (double base, double limit, double inc) + tree_constant (double base, double limit, double inc) : tree_fvc () { rep = new tree_constant_rep (base, limit, inc); rep->count = 1; } - tree_constant (const Range& r) + tree_constant (const Range& r) : tree_fvc () { rep = new tree_constant_rep (r); rep->count = 1; } - tree_constant (tree_constant_rep::constant_type t) + tree_constant (tree_constant_rep::constant_type t) : tree_fvc () { rep = new tree_constant_rep (t); rep->count = 1; } - tree_constant (const tree_constant& a) + tree_constant (const tree_constant& a) : tree_fvc () { rep = a.rep; rep->count++; } - tree_constant (tree_constant_rep& r) - { rep = &r; rep->count++; } ~tree_constant (void); @@ -134,6 +133,9 @@ ColumnVector to_vector (void) const { return rep->to_vector (); } Matrix to_matrix (void) const { return rep->to_matrix (); } + void stash_original_text (char *s) + { rep->stash_original_text (s); } + tree_constant_rep::constant_type force_numeric (int force_str_conv = 0) { return rep->force_numeric (force_str_conv); } @@ -283,6 +285,8 @@ return retval; } + void print_code (ostream& os); + private: tree_constant_rep *rep; };
--- a/src/pt-exp-base.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-exp-base.cc Sun Aug 07 01:02:15 1994 +0000 @@ -59,11 +59,6 @@ #include "lex.h" #include "defun.h" -extern "C" -{ -#include <readline/readline.h> -} - // Nonzero means we're returning from a function. extern int returning; @@ -136,9 +131,21 @@ return 0; } -// NOTE: functions for the tree_constant_rep and tree_constant classes -// are now defined in tree-const.cc. This should help speed up -// compilation when working only on the tree_constant class. +// Expressions. + +tree_constant +tree_expression::eval (int print) +{ + panic ("invalid evaluation of generic expression"); + return tree_constant (); +} + +Octave_object +tree_expression::eval (int print, int nargout, const Octave_object& args) +{ + panic ("invalid evaluation of generic expression"); + return Octave_object (); +} // General matrices. This list type is much more work to handle than // constant matrices, but it allows us to construct matrices from @@ -234,7 +241,7 @@ struct const_matrix_list { - tree_matrix::dir dir_next; + tree_matrix::dir direction; tree_constant elem; int nr; int nc; @@ -307,7 +314,8 @@ goto done; } - tree_constant tmp = elem->eval (0); + Octave_object otmp = elem->eval (0); + tree_constant tmp = otmp(0); if (error_state || tmp.is_undefined ()) { retval = tree_constant (); @@ -317,7 +325,7 @@ int nr = tmp.rows (); int nc = tmp.columns (); - dir direct = ptr->dir_next; + dir direct = ptr->direction; if (nr == 0 || nc == 0) { @@ -339,10 +347,10 @@ if (found_new_row_in_empties) { found_new_row_in_empties = 0; - list[len].dir_next = md_down; + list[len].direction = md_down; } else - list[len].dir_next = direct; + list[len].direction = direct; list[len].elem = tmp; list[len].nr = nr; @@ -369,7 +377,7 @@ for (i = 0; i < len; i++) { - dir direct = list[i].dir_next; + dir direct = list[i].direction; int nr = list[i].nr; int nc = list[i].nc; @@ -460,7 +468,7 @@ } else { - switch (list[i].dir_next) + switch (list[i].direction) { case md_right: put_col += prev_nc; @@ -565,6 +573,48 @@ return retval; } +void +tree_matrix::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + os << "["; + + tree_matrix *list = this; + + while (list) + { + list->element->print_code (os); + + list = list->next; + + if (list) + { + switch (list->direction) + { + case md_right: + os << ", "; + break; + case md_down: + os << "; "; + break; + default: + break; + } + } + } + + os << "]"; + + if (in_parens) + os << ")"; +} + +// A base class for objects that can be evaluated with argument lists. + tree_constant tree_fvc::assign (tree_constant& t, const Octave_object& args) { @@ -572,135 +622,26 @@ return tree_constant (); } -// Builtin functions. - -tree_builtin::tree_builtin (const char *nm) -{ - nargin_max = -1; - nargout_max = -1; - is_mapper = 0; - fcn = 0; - if (nm) - my_name = strsave (nm); -} - -tree_builtin::tree_builtin (int i_max, int o_max, Mapper_fcn& m_fcn, - const char *nm) -{ - nargin_max = i_max; - nargout_max = o_max; - mapper_fcn = m_fcn; - is_mapper = 1; - fcn = 0; - if (nm) - my_name = strsave (nm); -} - -tree_builtin::tree_builtin (int i_max, int o_max, Octave_builtin_fcn g_fcn, - const char *nm) -{ - nargin_max = i_max; - nargout_max = o_max; - is_mapper = 0; - fcn = g_fcn; - if (nm) - my_name = strsave (nm); -} - - -tree_constant -tree_builtin::eval (int print) -{ - tree_constant retval; - - if (error_state) - return retval; - - if (fcn) - { - Octave_object args; - args(0) = tree_constant (my_name); - Octave_object tmp = (*fcn) (args, 1); - if (tmp.length () > 0) - retval = tmp(0); - } - else // Assume mapper function - ::error ("%s: argument expected", my_name); - - return retval; -} - -Octave_object -tree_builtin::eval (int print, int nargout, const Octave_object& args) -{ - Octave_object retval; - - if (error_state) - return retval; - - int nargin = args.length (); - - if (fcn) - { - if (any_arg_is_magic_colon (args)) - ::error ("invalid use of colon in function argument list"); - else - retval = (*fcn) (args, nargout); - } - else if (is_mapper) - { - if (nargin > nargin_max) - ::error ("%s: too many arguments", my_name); - else if (nargin > 0 && args.length () > 0 && args(1).is_defined ()) - { - tree_constant tmp = args(1).mapper (mapper_fcn, 0); - retval.resize (1); - retval(0) = tmp; - } - } - else - panic_impossible (); - - return retval; -} - -int -tree_builtin::max_expected_args (void) -{ - int ea = nargin_max; - if (nargin_max < 0) - ea = INT_MAX; - else - ea = nargin_max; - return ea; -} - // Symbols from the symbol table. char * tree_identifier::name (void) const { - return sym->name (); + return sym ? sym->name () : 0; } tree_identifier * tree_identifier::define (tree_constant *t) { int status = sym->define (t); - if (status) - return this; - else - return 0; + return status ? this : 0; } tree_identifier * tree_identifier::define (tree_function *t) { int status = sym->define (t); - if (status) - return this; - else - return 0; + return status ? this : 0; } void @@ -806,180 +747,6 @@ } } -static void -gobble_leading_white_space (FILE *ffile) -{ - int in_comment = 0; - int c; - while ((c = getc (ffile)) != EOF) - { - if (in_comment) - { - if (c == '\n') - in_comment = 0; - } - else - { - if (c == ' ' || c == '\t' || c == '\n') - continue; - else if (c == '%' || c == '#') - in_comment = 1; - else - { - ungetc (c, ffile); - break; - } - } - } -} - -static int -is_function_file (FILE *ffile) -{ - int status = 0; - - gobble_leading_white_space (ffile); - - long pos = ftell (ffile); - - char buf [10]; - fgets (buf, 10, ffile); - int len = strlen (buf); - if (len > 8 && strncmp (buf, "function", 8) == 0 - && ! (isalnum (buf[8]) || buf[8] == '_')) - status = 1; - - fseek (ffile, pos, SEEK_SET); - - return status; -} - -int -tree_identifier::load_fcn_from_file (int exec_script) -{ - int script_file_executed = 0; - - curr_fcn_file_name = name (); - - char *oct_file = oct_file_in_path (curr_fcn_file_name); - - int loaded_oct_file = 0; - - if (oct_file) - { - cerr << "found: " << oct_file << "\n"; - - delete [] oct_file; - -// XXX FIXME XXX -- this is where we try to link to an external -// object... - loaded_oct_file = 1; - } - - if (! loaded_oct_file) - { - char *ff = fcn_file_in_path (curr_fcn_file_name); - - if (ff) - { - script_file_executed = parse_fcn_file (exec_script, ff); - delete [] ff; - } - - if (! (error_state || script_file_executed)) - { - char *foo = name (); - force_link_to_function (foo); - } - } - - return script_file_executed; -} - -int -tree_identifier::parse_fcn_file (int exec_script, char *ff) -{ - begin_unwind_frame ("parse_fcn_file"); - - int script_file_executed = 0; - - assert (ff); - -// Open function file and parse. - - int old_reading_fcn_file_state = reading_fcn_file; - - unwind_protect_ptr (rl_instream); - unwind_protect_ptr (ff_instream); - - unwind_protect_int (using_readline); - unwind_protect_int (input_line_number); - unwind_protect_int (current_input_column); - unwind_protect_int (reading_fcn_file); - - using_readline = 0; - reading_fcn_file = 1; - input_line_number = 0; - current_input_column = 1; - - FILE *ffile = get_input_from_file (ff, 0); - - if (ffile) - { -// Check to see if this file defines a function or is just a list of -// commands. - - if (is_function_file (ffile)) - { - unwind_protect_int (echo_input); - unwind_protect_int (saving_history); - unwind_protect_int (reading_fcn_file); - - echo_input = 0; - saving_history = 0; - reading_fcn_file = 1; - - YY_BUFFER_STATE old_buf = current_buffer (); - YY_BUFFER_STATE new_buf = create_buffer (ffile); - - 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 (); - - int status = yyparse (); - - if (status != 0) - { - ::error ("parse error while reading function file %s", ff); - global_sym_tab->clear (curr_fcn_file_name); - } - } - else if (exec_script) - { -// The value of `reading_fcn_file' will be restored to the proper value -// when we unwind from this frame. - reading_fcn_file = old_reading_fcn_file_state; - - unwind_protect_int (reading_script_file); - reading_script_file = 1; - - parse_and_execute (ffile, 1); - - script_file_executed = 1; - } - fclose (ffile); - } - - run_unwind_frame ("parse_fcn_file"); - - return script_file_executed; -} - void tree_identifier::eval_undefined_error (void) { @@ -987,7 +754,7 @@ int l = line (); int c = column (); if (l == -1 && c == -1) - ::error ("`%s' undefined"); + ::error ("`%s' undefined", nm); else ::error ("`%s' undefined near line %d column %d", nm, l, c); } @@ -1012,29 +779,7 @@ { script_file_executed = 0; - if (! sym->is_linked_to_global ()) - { - if (sym->is_defined ()) - { - if (sym->is_function () && symbol_out_of_date (sym)) - { - script_file_executed = load_fcn_from_file (); - } - } - else if (! sym->is_formal_parameter ()) - { - link_to_builtin_or_function (sym); - - if (! sym->is_defined ()) - { - script_file_executed = load_fcn_from_file (); - } - else if (sym->is_function () && symbol_out_of_date (sym)) - { - script_file_executed = load_fcn_from_file (); - } - } - } + int script_file_executed = lookup (sym); tree_fvc *ans = 0; @@ -1085,6 +830,10 @@ { if (maybe_do_ans_assign && ! ans->is_constant ()) { + +// XXX FIXME XXX -- need a procedure to do this, probably in +// variables.cc, to isolate the code that does lookups... + symbol_record *sr = global_sym_tab->lookup ("ans", 1, 0); assert (sr); @@ -1093,7 +842,7 @@ tree_constant *tmp = new tree_constant (retval); - tree_simple_assignment_expression tmp_ass (ans_id, tmp); + tree_simple_assignment_expression tmp_ass (ans_id, tmp, 0, 1); tmp_ass.eval (print); @@ -1164,6 +913,10 @@ if (retval.length () > 0 && retval(0).is_defined ()) { + +// XXX FIXME XXX -- need a procedure to do this, probably in +// variables.cc, to isolate the code that does lookups... + symbol_record *sr = global_sym_tab->lookup ("ans", 1, 0); assert (sr); @@ -1172,7 +925,8 @@ tree_constant *tmp = new tree_constant (retval(0)); - tree_simple_assignment_expression tmp_ass (ans_id, tmp); + tree_simple_assignment_expression tmp_ass (ans_id, + tmp, 0, 1); tmp_ass.eval (print); @@ -1189,6 +943,1117 @@ return retval; } +void +tree_identifier::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + char *nm = name (); + os << (nm) ? nm : "(null)"; + + if (in_parens) + os << ")"; +} + +// Index expressions. + +tree_index_expression::~tree_index_expression (void) +{ + delete id; + delete list; +} + +tree_constant +tree_index_expression::eval (int print) +{ + tree_constant retval; + + if (error_state) + return retval; + + if (list) + { +// Extract the arguments into a simple vector. + Octave_object args = list->convert_to_const_vector (); +// Don't pass null arguments. + int nargin = args.length (); + if (error_state) + eval_error (); + else if (nargin > 1 && all_args_defined (args)) + { + Octave_object tmp = id->eval (print, 1, args); + + if (error_state) + eval_error (); + + if (tmp.length () > 0) + retval = tmp(0); + } + } + else + { + retval = id->eval (print); + if (error_state) + eval_error (); + } + + return retval; +} + +Octave_object +tree_index_expression::eval (int print, int nargout, const Octave_object& args) +{ + Octave_object retval; + + if (error_state) + return retval; + + if (list) + { +// Extract the arguments into a simple vector. + Octave_object args = list->convert_to_const_vector (); +// Don't pass null arguments. + if (error_state) + eval_error (); + else if (args.length () > 1 && all_args_defined (args)) + { + retval = id->eval (print, nargout, args); + if (error_state) + eval_error (); + } + } + else + { + Octave_object tmp_args; + retval = id->eval (print, nargout, tmp_args); + if (error_state) + eval_error (); + } + + return retval; +} + +void +tree_index_expression::eval_error (void) +{ + if (error_state > 0) + { + int l = line (); + int c = column (); + char *fmt; + if (l != -1 && c != -1) + { + if (list) + fmt = "evaluating index expression near line %d, column %d"; + else + fmt = "evaluating expression near line %d, column %d"; + + ::error (fmt, l, c); + } + else + { + if (list) + ::error ("evaluating index expression"); + else + ::error ("evaluating expression"); + } + } +} + +void +tree_index_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (id) + id->print_code (os); + + if (list) + { + os << " ("; + list->print_code (os); + os << ")"; + } + + if (in_parens) + os << ")"; +} + +// Prefix expressions. + +tree_constant +tree_prefix_expression::eval (int print) +{ + tree_constant retval; + + if (error_state) + return retval; + + if (id) + { + id->bump_value (etype); + retval = id->eval (print); + if (error_state) + { + retval = tree_constant (); + if (error_state) + eval_error (); + } + } + return retval; +} + +char * +tree_prefix_expression::oper (void) const +{ + static char *op; + switch (etype) + { + case tree_expression::increment: op = "++"; break; + case tree_expression::decrement: op = "--"; break; + default: op = "unknown"; break; + } + return op; +} + +void +tree_prefix_expression::eval_error (void) +{ + if (error_state > 0) + { + char *op = oper (); + + ::error ("evaluating prefix operator `%s' near line %d, column %d", + op, line (), column ()); + } +} + +void +tree_prefix_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + os << oper (); + + if (id) + id->print_code (os); + + if (in_parens) + os << ")"; +} + +// Postfix expressions. + +tree_constant +tree_postfix_expression::eval (int print) +{ + tree_constant retval; + + if (error_state) + return retval; + + if (id) + { + retval = id->eval (print); + id->bump_value (etype); + if (error_state) + { + retval = tree_constant (); + if (error_state) + eval_error (); + } + } + return retval; +} + +char * +tree_postfix_expression::oper (void) const +{ + static char *op; + switch (etype) + { + case tree_expression::increment: op = "++"; break; + case tree_expression::decrement: op = "--"; break; + default: op = "unknown"; break; + } + return op; +} + +void +tree_postfix_expression::eval_error (void) +{ + if (error_state > 0) + { + char *op = oper (); + + ::error ("evaluating postfix operator `%s' near line %d, column %d", + op, line (), column ()); + } +} + +void +tree_postfix_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (id) + id->print_code (os); + + os << oper (); + + if (in_parens) + os << ")"; +} + +// Unary expressions. + +tree_constant +tree_unary_expression::eval (int print) +{ + if (error_state) + return tree_constant (); + + tree_constant ans; + + switch (etype) + { + case tree_expression::not: + case tree_expression::uminus: + case tree_expression::hermitian: + case tree_expression::transpose: + if (op) + { + Octave_object tmp = op->eval (0); + tree_constant u = tmp(0); + if (error_state) + eval_error (); + else if (u.is_defined ()) + { + ans = do_unary_op (u, etype); + if (error_state) + { + ans = tree_constant (); + if (error_state) + eval_error (); + } + } + } + break; + default: + ::error ("unary operator %d not implemented", etype); + break; + } + + return ans; +} + +char * +tree_unary_expression::oper (void) const +{ + static char *op; + switch (etype) + { + case tree_expression::not: op = "!"; break; + case tree_expression::uminus: op = "-"; break; + case tree_expression::hermitian: op = "'"; break; + case tree_expression::transpose: op = ".'"; break; + default: op = "unknown"; break; + } + return op; +} + +void +tree_unary_expression::eval_error (void) +{ + if (error_state > 0) + { + char *op = oper (); + + ::error ("evaluating unary operator `%s' near line %d, column %d", + op, line (), column ()); + } +} + +void +tree_unary_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + switch (etype) + { + case tree_expression::not: + case tree_expression::uminus: + os << oper (); + if (op) + op->print_code (os); + break; + case tree_expression::hermitian: + case tree_expression::transpose: + if (op) + op->print_code (os); + os << oper (); + break; + default: + panic_impossible (); + break; + } + + if (in_parens) + os << ")"; +} + +// Binary expressions. + +tree_constant +tree_binary_expression::eval (int print) +{ + if (error_state) + return tree_constant (); + + tree_constant ans; + switch (etype) + { + case tree_expression::add: + case tree_expression::subtract: + case tree_expression::multiply: + case tree_expression::el_mul: + case tree_expression::divide: + case tree_expression::el_div: + case tree_expression::leftdiv: + case tree_expression::el_leftdiv: + case tree_expression::power: + case tree_expression::elem_pow: + case tree_expression::cmp_lt: + case tree_expression::cmp_le: + case tree_expression::cmp_eq: + case tree_expression::cmp_ge: + case tree_expression::cmp_gt: + case tree_expression::cmp_ne: + case tree_expression::and: + case tree_expression::or: + if (op1) + { + Octave_object tmp = op1->eval (0); + tree_constant a = tmp(0); + if (error_state) + eval_error (); + else if (a.is_defined () && op2) + { + tmp = op2->eval (0); + tree_constant b = tmp (0); + if (error_state) + eval_error (); + else if (b.is_defined ()) + { + ans = do_binary_op (a, b, etype); + if (error_state) + { + ans = tree_constant (); + if (error_state) + eval_error (); + } + } + } + } + break; + case tree_expression::and_and: + case tree_expression::or_or: + { + int result = 0; + if (op1) + { + Octave_object tmp = op1->eval (0); + tree_constant a = tmp(0); + if (error_state) + { + eval_error (); + break; + } + + int a_true = a.is_true (); + if (error_state) + { + eval_error (); + break; + } + + if (a_true) + { + if (etype == tree_expression::or_or) + { + result = 1; + goto done; + } + } + else + { + if (etype == tree_expression::and_and) + { + result = 0; + goto done; + } + } + + if (op2) + { + tmp = op2->eval (0); + tree_constant b = tmp(0); + if (error_state) + { + eval_error (); + break; + } + + result = b.is_true (); + if (error_state) + { + eval_error (); + break; + } + } + } + done: + ans = tree_constant ((double) result); + } + break; + default: + ::error ("binary operator %d not implemented", etype); + break; + } + + return ans; +} + +char * +tree_binary_expression::oper (void) const +{ + static char *op; + switch (etype) + { + case tree_expression::add: op = "+"; break; + case tree_expression::subtract: op = "-"; break; + case tree_expression::multiply: op = "*"; break; + case tree_expression::el_mul: op = ".*"; break; + case tree_expression::divide: op = "/"; break; + case tree_expression::el_div: op = "./"; break; + case tree_expression::leftdiv: op = "\\"; break; + case tree_expression::el_leftdiv: op = ".\\"; break; + case tree_expression::power: op = "^"; break; + case tree_expression::elem_pow: op = ".^"; break; + case tree_expression::cmp_lt: op = "<"; break; + case tree_expression::cmp_le: op = "<="; break; + case tree_expression::cmp_eq: op = "=="; break; + case tree_expression::cmp_ge: op = ">="; break; + case tree_expression::cmp_gt: op = ">"; break; + case tree_expression::cmp_ne: op = "!="; break; + case tree_expression::and_and: op = "&&"; break; + case tree_expression::or_or: op = "||"; break; + case tree_expression::and: op = "&"; break; + case tree_expression::or: op = "|"; break; + default: op = "unknown"; break; + } + return op; +} + +void +tree_binary_expression::eval_error (void) +{ + if (error_state > 0) + { + char *op = oper (); + + ::error ("evaluating binary operator `%s' near line %d, column %d", + op, line (), column ()); + } +} + +void +tree_binary_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (op1) + op1->print_code (os); + + os << " " << oper () << " "; + + if (op2) + op2->print_code (os); + + if (in_parens) + os << ")"; +} + +// Assignment expressions. + +tree_constant +tree_assignment_expression::eval (int print) +{ + panic ("invalid evaluation of generic expression"); + return tree_constant (); +} + +// Simple assignment expressions. + +tree_simple_assignment_expression::~tree_simple_assignment_expression (void) +{ + if (! preserve) + { + delete lhs; + delete index; + } + delete rhs; +} + +tree_constant +tree_simple_assignment_expression::eval (int print) +{ + assert (etype == tree_expression::assignment); + + tree_constant ans; + tree_constant retval; + + if (error_state) + return retval; + + if (rhs) + { + Octave_object tmp = rhs->eval (0); + tree_constant rhs_val = tmp(0); + if (error_state) + { + if (error_state) + eval_error (); + } + else if (! index) + { + ans = lhs->assign (rhs_val); + if (error_state) + eval_error (); + } + else + { +// Extract the arguments into a simple vector. + Octave_object args = index->convert_to_const_vector (); + + int nargin = args.length (); + + if (error_state) + eval_error (); + else if (nargin > 1) + { + ans = lhs->assign (rhs_val, args); + if (error_state) + eval_error (); + } + } + } + + if (! error_state && ans.is_defined ()) + { + int pad_after = 0; + if (print && user_pref.print_answer_id_name) + { + if (print_as_scalar (ans)) + { + ostrstream output_buf; + output_buf << lhs->name () << " = " << ends; + maybe_page_output (output_buf); + } + else + { + pad_after = 1; + ostrstream output_buf; + output_buf << lhs->name () << " =\n\n" << ends; + maybe_page_output (output_buf); + } + } + + retval = ans.eval (print); + + if (print && pad_after) + { + ostrstream output_buf; + output_buf << "\n" << ends; + maybe_page_output (output_buf); + } + } + + return retval; +} + +void +tree_simple_assignment_expression::eval_error (void) +{ + if (error_state > 0) + { + int l = line (); + int c = column (); + if (l != -1 && c != -1) + ::error ("evaluating assignment expression near line %d, column %d", + l, c); +// else +// error ("evaluating assignment expression"); + } +} + +void +tree_simple_assignment_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (! is_ans_assign ()) + { + if (lhs) + lhs->print_code (os); + + if (index) + { + os << " ("; + index->print_code (os); + os << ")"; + } + + os << " = "; + } + + if (rhs) + rhs->print_code (os); + + if (in_parens) + os << ")"; +} + +// Multi-valued assignmnt expressions. + +tree_multi_assignment_expression::~tree_multi_assignment_expression (void) +{ + delete lhs; + delete rhs; +} + +tree_constant +tree_multi_assignment_expression::eval (int print) +{ + tree_constant retval; + + if (error_state) + return retval; + + Octave_object tmp_args; + Octave_object result = eval (print, 1, tmp_args); + + if (result.length () > 0) + retval = result(0); + + return retval; +} + +Octave_object +tree_multi_assignment_expression::eval (int print, int nargout, + const Octave_object& args) +{ + assert (etype == tree_expression::multi_assignment); + + if (error_state || ! rhs) + return Octave_object (); + + nargout = lhs->length (); + Octave_object tmp_args; + Octave_object results = rhs->eval (0, nargout, tmp_args); + + if (error_state) + eval_error (); + + int ma_line = line (); + int ma_column = column (); + + if (results.length () > 0) + { + int i = 0; + int pad_after = 0; + int last_was_scalar_type = 0; + for (Pix p = lhs->first (); p != 0; lhs->next (p)) + { + tree_index_expression *lhs_expr = (*lhs) (p); + + if (i < nargout) + { +// XXX FIXME? XXX -- this is apparently the way Matlab works, but +// maybe we should have the option of skipping the assignment instead. + + tree_constant *tmp = 0; + if (results(i).is_undefined ()) + { + Matrix m; + tmp = new tree_constant (m); + } + else + tmp = new tree_constant (results(i)); + + tree_simple_assignment_expression tmp_expr + (lhs_expr, tmp, 1, 0, ma_line, ma_column); + + results(i) = tmp_expr.eval (0); // May change + + if (error_state) + break; + + if (print && pad_after) + { + ostrstream output_buf; + output_buf << "\n" << '\0'; + maybe_page_output (output_buf); + } + + if (print && user_pref.print_answer_id_name) + { + tree_identifier *tmp_id = lhs_expr->ident (); + char *tmp_nm = tmp_id->name (); + + if (print_as_scalar (results(i))) + { + ostrstream output_buf; + output_buf << tmp_nm << " = " << '\0'; + maybe_page_output (output_buf); + last_was_scalar_type = 1; + } + else + { + ostrstream output_buf; + output_buf << tmp_nm << " =\n\n" << '\0'; + maybe_page_output (output_buf); + last_was_scalar_type = 0; + } + } + + results(i).eval (print); + + pad_after++; + i++; + } + else + { + tree_simple_assignment_expression tmp_expr + (lhs_expr, 0, 1, 0, ma_line, ma_column); + + tmp_expr.eval (0); + + if (error_state) + break; + + if (last_was_scalar_type && i == 1) + pad_after = 0; + + break; + } + } + + if (print && pad_after) + { + ostrstream output_buf; + output_buf << "\n" << '\0'; + maybe_page_output (output_buf); + } + } + + return results; +} + +void +tree_multi_assignment_expression::eval_error (void) +{ + if (error_state > 0) + ::error ("evaluating assignment expression near line %d, column %d", + line (), column ()); +} + +void +tree_multi_assignment_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (lhs) + { + int len = lhs->length (); + + if (len > 1) + os << "["; + + lhs->print_code (os); + + if (len > 1) + os << "]"; + } + + os << " = "; + + if (rhs) + rhs->print_code (os); + + if (in_parens) + os << ")"; +} + +// Colon expressions. + +tree_colon_expression * +tree_colon_expression::chain (tree_expression *t) +{ + tree_colon_expression *retval = 0; + if (! op1 || op3) + ::error ("invalid colon expression"); + else + { + op3 = op2; // Stupid syntax. + op2 = t; + + retval = this; + } + return retval; +} + +tree_constant +tree_colon_expression::eval (int print) +{ + tree_constant retval; + + if (error_state || ! op1 || ! op2) + return retval; + + Octave_object otmp = op1->eval (0); + tree_constant tmp = otmp(0); + + if (tmp.is_undefined ()) + { + eval_error ("invalid null value in colon expression"); + return retval; + } + + tmp = tmp.make_numeric (); + if (tmp.const_type () != tree_constant_rep::scalar_constant + && tmp.const_type () != tree_constant_rep::complex_scalar_constant) + { + eval_error ("base for colon expression must be a scalar"); + return retval; + } + double base = tmp.double_value (); + + otmp = op2->eval (0); + tmp = otmp(0); + + if (tmp.is_undefined ()) + { + eval_error ("invalid null value in colon expression"); + return retval; + } + + tmp = tmp.make_numeric (); + if (tmp.const_type () != tree_constant_rep::scalar_constant + && tmp.const_type () != tree_constant_rep::complex_scalar_constant) + { + eval_error ("limit for colon expression must be a scalar"); + return retval; + } + double limit = tmp.double_value (); + + double inc = 1.0; + if (op3) + { + otmp = op3->eval (0); + tmp = otmp(0); + + if (tmp.is_undefined ()) + { + eval_error ("invalid null value in colon expression"); + return retval; + } + + tmp = tmp.make_numeric (); + if (tmp.const_type () != tree_constant_rep::scalar_constant + && tmp.const_type () != tree_constant_rep::complex_scalar_constant) + { + eval_error ("increment for colon expression must be a scalar"); + return retval; + } + else + inc = tmp.double_value (); + } + + retval = tree_constant (base, limit, inc); + + if (error_state) + { + if (error_state) + eval_error ("evaluating colon expression"); + return tree_constant (); + } + + return retval; +} + +void +tree_colon_expression::eval_error (const char *s) +{ + if (error_state > 0) + ::error ("%s near line %d column %d", s, line (), column ()); +} + +void +tree_colon_expression::print_code (ostream& os) +{ + print_code_indent (os); + + if (in_parens) + os << "("; + + if (op1) + op1->print_code (os); + +// Stupid syntax. + + if (op3) + { + os << ":"; + op3->print_code (os); + } + + if (op2) + { + os << ":"; + op2->print_code (os); + } + + if (in_parens) + os << ")"; +} + +// Builtin functions. + +tree_builtin::tree_builtin (const char *nm) +{ + nargin_max = -1; + nargout_max = -1; + is_mapper = 0; + fcn = 0; + if (nm) + my_name = strsave (nm); +} + +tree_builtin::tree_builtin (int i_max, int o_max, Mapper_fcn& m_fcn, + const char *nm) +{ + nargin_max = i_max; + nargout_max = o_max; + mapper_fcn = m_fcn; + is_mapper = 1; + fcn = 0; + if (nm) + my_name = strsave (nm); +} + +tree_builtin::tree_builtin (int i_max, int o_max, Octave_builtin_fcn g_fcn, + const char *nm) +{ + nargin_max = i_max; + nargout_max = o_max; + is_mapper = 0; + fcn = g_fcn; + if (nm) + my_name = strsave (nm); +} + +tree_constant +tree_builtin::eval (int print) +{ + tree_constant retval; + + if (error_state) + return retval; + + if (fcn) + { + Octave_object args; + args(0) = tree_constant (my_name); + Octave_object tmp = (*fcn) (args, 1); + if (tmp.length () > 0) + retval = tmp(0); + } + else // Assume mapper function + ::error ("%s: argument expected", my_name); + + return retval; +} + +Octave_object +tree_builtin::eval (int print, int nargout, const Octave_object& args) +{ + Octave_object retval; + + if (error_state) + return retval; + + int nargin = args.length (); + + if (fcn) + { + if (any_arg_is_magic_colon (args)) + ::error ("invalid use of colon in function argument list"); + else + retval = (*fcn) (args, nargout); + } + else if (is_mapper) + { + if (nargin > nargin_max) + ::error ("%s: too many arguments", my_name); + else if (nargin > 0 && args.length () > 0 && args(1).is_defined ()) + { + tree_constant tmp = args(1).mapper (mapper_fcn, 0); + retval.resize (1); + retval(0) = tmp; + } + } + else + panic_impossible (); + + return retval; +} + +int +tree_builtin::max_expected_args (void) +{ + int ea = nargin_max; + if (nargin_max < 0) + ea = INT_MAX; + else + ea = nargin_max; + return ea; +} + // User defined functions. #if 0 @@ -1447,9 +2312,66 @@ } } +void +tree_function::print_code (ostream& os) +{ + print_code_reset (); + + print_code_indent (os); + + os << "function "; + + if (ret_list) + { + int len = ret_list->length (); + + if (len > 1) + os << "["; + + ret_list->print_code (os); + + if (len > 1) + os << "]"; + + os << " = "; + } + + os << (fcn_name ? fcn_name : "(null)") << " "; + + if (param_list) + { + int len = param_list->length (); + if (len > 0) + os << "("; + + param_list->print_code (os); + + if (len > 0) + { + os << ")"; + print_code_new_line (os); + } + } + else + { + os << "()"; + print_code_new_line (os); + } + + if (cmd_list) + { + increment_indent_level (); + cmd_list->print_code (os); + } + + os << "endfunction"; + + print_code_new_line (os); +} + DEFUN ("va_arg", Fva_arg, Sva_arg, 1, 1, "va_arg (): return next argument in a function that takes a\n\ -varible number of parameters") +variable number of parameters") { Octave_object retval; @@ -1505,785 +2427,6 @@ return retval; } -// Expressions. - -tree_constant -tree_expression::eval (int print) -{ - panic ("invalid evaluation of generic expression"); - return tree_constant (); -} - -Octave_object -tree_expression::eval (int print, int nargout, const Octave_object& args) -{ - panic ("invalid evaluation of generic expression"); - return Octave_object (); -} - -// Prefix expressions. - -tree_constant -tree_prefix_expression::eval (int print) -{ - tree_constant retval; - - if (error_state) - return retval; - - if (id) - { - id->bump_value (etype); - retval = id->eval (print); - if (error_state) - { - retval = tree_constant (); - if (error_state) - eval_error (); - } - } - return retval; -} - -void -tree_prefix_expression::eval_error (void) -{ - if (error_state > 0) - { - char *op; - switch (etype) - { - case tree_expression::increment: op = "++"; break; - case tree_expression::decrement: op = "--"; break; - default: op = "unknown"; break; - } - - ::error ("evaluating prefix operator `%s' near line %d, column %d", - op, line (), column ()); - } -} - -// Postfix expressions. - -tree_constant -tree_postfix_expression::eval (int print) -{ - tree_constant retval; - - if (error_state) - return retval; - - if (id) - { - retval = id->eval (print); - id->bump_value (etype); - if (error_state) - { - retval = tree_constant (); - if (error_state) - eval_error (); - } - } - return retval; -} - -void -tree_postfix_expression::eval_error (void) -{ - if (error_state > 0) - { - char *op; - switch (etype) - { - case tree_expression::increment: op = "++"; break; - case tree_expression::decrement: op = "--"; break; - default: op = "unknown"; break; - } - - ::error ("evaluating postfix operator `%s' near line %d, column %d", - op, line (), column ()); - } -} - -// Unary expressions. - -tree_constant -tree_unary_expression::eval (int print) -{ - if (error_state) - return tree_constant (); - - tree_constant ans; - - switch (etype) - { - case tree_expression::not: - case tree_expression::uminus: - case tree_expression::hermitian: - case tree_expression::transpose: - if (op) - { - tree_constant u = op->eval (0); - if (error_state) - eval_error (); - else if (u.is_defined ()) - { - ans = do_unary_op (u, etype); - if (error_state) - { - ans = tree_constant (); - if (error_state) - eval_error (); - } - } - } - break; - default: - ::error ("unary operator %d not implemented", etype); - break; - } - - return ans; -} - -void -tree_unary_expression::eval_error (void) -{ - if (error_state > 0) - { - char *op; - switch (etype) - { - case tree_expression::not: op = "!"; break; - case tree_expression::uminus: op = "-"; break; - case tree_expression::hermitian: op = "'"; break; - case tree_expression::transpose: op = ".'"; break; - default: op = "unknown"; break; - } - - ::error ("evaluating unary operator `%s' near line %d, column %d", - op, line (), column ()); - } -} - -// Binary expressions. - -tree_constant -tree_binary_expression::eval (int print) -{ - if (error_state) - return tree_constant (); - - tree_constant ans; - switch (etype) - { - case tree_expression::add: - case tree_expression::subtract: - case tree_expression::multiply: - case tree_expression::el_mul: - case tree_expression::divide: - case tree_expression::el_div: - case tree_expression::leftdiv: - case tree_expression::el_leftdiv: - case tree_expression::power: - case tree_expression::elem_pow: - case tree_expression::cmp_lt: - case tree_expression::cmp_le: - case tree_expression::cmp_eq: - case tree_expression::cmp_ge: - case tree_expression::cmp_gt: - case tree_expression::cmp_ne: - case tree_expression::and: - case tree_expression::or: - if (op1) - { - tree_constant a = op1->eval (0); - if (error_state) - eval_error (); - else if (a.is_defined () && op2) - { - tree_constant b = op2->eval (0); - if (error_state) - eval_error (); - else if (b.is_defined ()) - { - ans = do_binary_op (a, b, etype); - if (error_state) - { - ans = tree_constant (); - if (error_state) - eval_error (); - } - } - } - } - break; - case tree_expression::and_and: - case tree_expression::or_or: - { - int result = 0; - if (op1) - { - tree_constant a = op1->eval (0); - if (error_state) - { - eval_error (); - break; - } - - int a_true = a.is_true (); - if (error_state) - { - eval_error (); - break; - } - - if (a_true) - { - if (etype == tree_expression::or_or) - { - result = 1; - goto done; - } - } - else - { - if (etype == tree_expression::and_and) - { - result = 0; - goto done; - } - } - - if (op2) - { - tree_constant b = op2->eval (0); - if (error_state) - { - eval_error (); - break; - } - - result = b.is_true (); - if (error_state) - { - eval_error (); - break; - } - } - } - done: - ans = tree_constant ((double) result); - } - break; - default: - ::error ("binary operator %d not implemented", etype); - break; - } - - return ans; -} - -void -tree_binary_expression::eval_error (void) -{ - if (error_state > 0) - { - char *op; - switch (etype) - { - case tree_expression::add: op = "+"; break; - case tree_expression::subtract: op = "-"; break; - case tree_expression::multiply: op = "*"; break; - case tree_expression::el_mul: op = ".*"; break; - case tree_expression::divide: op = "/"; break; - case tree_expression::el_div: op = "./"; break; - case tree_expression::leftdiv: op = "\\"; break; - case tree_expression::el_leftdiv: op = ".\\"; break; - case tree_expression::power: op = "^"; break; - case tree_expression::elem_pow: op = ".^"; break; - case tree_expression::cmp_lt: op = "<"; break; - case tree_expression::cmp_le: op = "<="; break; - case tree_expression::cmp_eq: op = "=="; break; - case tree_expression::cmp_ge: op = ">="; break; - case tree_expression::cmp_gt: op = ">"; break; - case tree_expression::cmp_ne: op = "!="; break; - case tree_expression::and_and: op = "&&"; break; - case tree_expression::or_or: op = "||"; break; - case tree_expression::and: op = "&"; break; - case tree_expression::or: op = "|"; break; - default: op = "unknown"; break; - } - - ::error ("evaluating binary operator `%s' near line %d, column %d", - op, line (), column ()); - } -} - -// Assignment expressions. - -tree_constant -tree_assignment_expression::eval (int print) -{ - panic ("invalid evaluation of generic expression"); - return tree_constant (); -} - -// Simple assignment expressions. - -tree_simple_assignment_expression::~tree_simple_assignment_expression (void) -{ - if (! preserve) - { - delete lhs; - delete index; - } - delete rhs; -} - -tree_constant -tree_simple_assignment_expression::eval (int print) -{ - assert (etype == tree_expression::assignment); - - tree_constant ans; - tree_constant retval; - - if (error_state) - return retval; - - if (rhs) - { - tree_constant rhs_val = rhs->eval (0); - if (error_state) - { - if (error_state) - eval_error (); - } - else if (! index) - { - ans = lhs->assign (rhs_val); - if (error_state) - eval_error (); - } - else - { -// Extract the arguments into a simple vector. - Octave_object args = index->convert_to_const_vector (); - - int nargin = args.length (); - - if (error_state) - eval_error (); - else if (nargin > 1) - { - ans = lhs->assign (rhs_val, args); - if (error_state) - eval_error (); - } - } - } - - if (! error_state && ans.is_defined ()) - { - int pad_after = 0; - if (print && user_pref.print_answer_id_name) - { - if (print_as_scalar (ans)) - { - ostrstream output_buf; - output_buf << lhs->name () << " = " << ends; - maybe_page_output (output_buf); - } - else - { - pad_after = 1; - ostrstream output_buf; - output_buf << lhs->name () << " =\n\n" << ends; - maybe_page_output (output_buf); - } - } - - retval = ans.eval (print); - - if (print && pad_after) - { - ostrstream output_buf; - output_buf << "\n" << ends; - maybe_page_output (output_buf); - } - } - - return retval; -} - -void -tree_simple_assignment_expression::eval_error (void) -{ - if (error_state > 0) - { - int l = line (); - int c = column (); - if (l != -1 && c != -1) - ::error ("evaluating assignment expression near line %d, column %d", - l, c); -// else -// error ("evaluating assignment expression"); - } -} - -// Multi-valued assignmnt expressions. - -tree_multi_assignment_expression::~tree_multi_assignment_expression (void) -{ - delete lhs; - delete rhs; -} - -tree_constant -tree_multi_assignment_expression::eval (int print) -{ - tree_constant retval; - - if (error_state) - return retval; - - Octave_object tmp_args; - Octave_object result = eval (print, 1, tmp_args); - - if (result.length () > 0) - retval = result(0); - - return retval; -} - -Octave_object -tree_multi_assignment_expression::eval (int print, int nargout, - const Octave_object& args) -{ - assert (etype == tree_expression::multi_assignment); - - if (error_state || ! rhs) - return Octave_object (); - - nargout = lhs->length (); - Octave_object tmp_args; - Octave_object results = rhs->eval (0, nargout, tmp_args); - - if (error_state) - eval_error (); - - int ma_line = line (); - int ma_column = column (); - - if (results.length () > 0) - { - int i = 0; - int pad_after = 0; - int last_was_scalar_type = 0; - for (Pix p = lhs->first (); p != 0; lhs->next (p)) - { - tree_index_expression *lhs_expr = (*lhs) (p); - - if (i < nargout) - { -// XXX FIXME? XXX -- this is apparently the way Matlab works, but -// maybe we should have the option of skipping the assignment instead. - - tree_constant *tmp = 0; - if (results(i).is_undefined ()) - { - Matrix m; - tmp = new tree_constant (m); - } - else - tmp = new tree_constant (results(i)); - - tree_simple_assignment_expression tmp_expr - (lhs_expr, tmp, 1, ma_line, ma_column); - - results(i) = tmp_expr.eval (0); // May change - - if (error_state) - break; - - if (print && pad_after) - { - ostrstream output_buf; - output_buf << "\n" << '\0'; - maybe_page_output (output_buf); - } - - if (print && user_pref.print_answer_id_name) - { - tree_identifier *tmp_id = lhs_expr->ident (); - char *tmp_nm = tmp_id->name (); - - if (print_as_scalar (results(i))) - { - ostrstream output_buf; - output_buf << tmp_nm << " = " << '\0'; - maybe_page_output (output_buf); - last_was_scalar_type = 1; - } - else - { - ostrstream output_buf; - output_buf << tmp_nm << " =\n\n" << '\0'; - maybe_page_output (output_buf); - last_was_scalar_type = 0; - } - } - - results(i).eval (print); - - pad_after++; - i++; - } - else - { - tree_simple_assignment_expression tmp_expr - (lhs_expr, 0, 1, ma_line, ma_column); - - tmp_expr.eval (0); - - if (error_state) - break; - - if (last_was_scalar_type && i == 1) - pad_after = 0; - - break; - } - } - - if (print && pad_after) - { - ostrstream output_buf; - output_buf << "\n" << '\0'; - maybe_page_output (output_buf); - } - } - - return results; -} - -void -tree_multi_assignment_expression::eval_error (void) -{ - if (error_state > 0) - ::error ("evaluating assignment expression near line %d, column %d", - line (), column ()); -} - -// Colon expressions. - -tree_colon_expression * -tree_colon_expression::chain (tree_expression *t) -{ - tree_colon_expression *retval = 0; - if (! op1 || op3) - ::error ("invalid colon expression"); - else - { - op3 = op2; // Stupid syntax. - op2 = t; - - retval = this; - } - return retval; -} - -tree_constant -tree_colon_expression::eval (int print) -{ - tree_constant retval; - - if (error_state || ! op1 || ! op2) - return retval; - - tree_constant tmp; - - tmp = op1->eval (0); - - if (tmp.is_undefined ()) - { - eval_error ("invalid null value in colon expression"); - return retval; - } - - tmp = tmp.make_numeric (); - if (tmp.const_type () != tree_constant_rep::scalar_constant - && tmp.const_type () != tree_constant_rep::complex_scalar_constant) - { - eval_error ("base for colon expression must be a scalar"); - return retval; - } - double base = tmp.double_value (); - - tmp = op2->eval (0); - - if (tmp.is_undefined ()) - { - eval_error ("invalid null value in colon expression"); - return retval; - } - - tmp = tmp.make_numeric (); - if (tmp.const_type () != tree_constant_rep::scalar_constant - && tmp.const_type () != tree_constant_rep::complex_scalar_constant) - { - eval_error ("limit for colon expression must be a scalar"); - return retval; - } - double limit = tmp.double_value (); - - double inc = 1.0; - if (op3) - { - tmp = op3->eval (0); - - if (tmp.is_undefined ()) - { - eval_error ("invalid null value in colon expression"); - return retval; - } - - tmp = tmp.make_numeric (); - if (tmp.const_type () != tree_constant_rep::scalar_constant - && tmp.const_type () != tree_constant_rep::complex_scalar_constant) - { - eval_error ("increment for colon expression must be a scalar"); - return retval; - } - else - inc = tmp.double_value (); - } - - retval = tree_constant (base, limit, inc); - - if (error_state) - { - if (error_state) - eval_error ("evaluating colon expression"); - return tree_constant (); - } - - return retval; -} - -void -tree_colon_expression::eval_error (const char *s) -{ - if (error_state > 0) - ::error ("%s near line %d column %d", s, line (), column ()); -} - -// Index expressions. - -tree_index_expression::~tree_index_expression (void) -{ - delete id; - delete list; -} - -tree_constant -tree_index_expression::eval (int print) -{ - tree_constant retval; - - if (error_state) - return retval; - - if (list) - { -// Extract the arguments into a simple vector. - Octave_object args = list->convert_to_const_vector (); -// Don't pass null arguments. - int nargin = args.length (); - if (error_state) - eval_error (); - else if (nargin > 1 && all_args_defined (args)) - { - Octave_object tmp = id->eval (print, 1, args); - - if (error_state) - eval_error (); - - if (tmp.length () > 0) - retval = tmp(0); - } - } - else - { - retval = id->eval (print); - if (error_state) - eval_error (); - } - - return retval; -} - -Octave_object -tree_index_expression::eval (int print, int nargout, const Octave_object& args) -{ - Octave_object retval; - - if (error_state) - return retval; - - if (list) - { -// Extract the arguments into a simple vector. - Octave_object args = list->convert_to_const_vector (); -// Don't pass null arguments. - if (error_state) - eval_error (); - else if (args.length () > 1 && all_args_defined (args)) - { - retval = id->eval (print, nargout, args); - if (error_state) - eval_error (); - } - } - else - { - Octave_object tmp_args; - retval = id->eval (print, nargout, tmp_args); - if (error_state) - eval_error (); - } - - return retval; -} - -void -tree_index_expression::eval_error (void) -{ - if (error_state > 0) - { - int l = line (); - int c = column (); - char *fmt; - if (l != -1 && c != -1) - { - if (list) - fmt = "evaluating index expression near line %d, column %d"; - else - fmt = "evaluating expression near line %d, column %d"; - - ::error (fmt, l, c); - } - else - { - if (list) - ::error ("evaluating index expression"); - else - ::error ("evaluating expression"); - } - } -} - /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/pt-exp-base.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-exp-base.h Sun Aug 07 01:02:15 1994 +0000 @@ -30,6 +30,7 @@ #include <time.h> #include <stdio.h> +#include <iostream.h> #include "variables.h" #include "mappers.h" @@ -67,6 +68,8 @@ tree_expression : public tree { public: + int in_parens; + enum type { unknown, @@ -105,7 +108,10 @@ }; tree_expression (int l = -1, int c = -1) : tree (l, c) - { etype = unknown; } + { + in_parens = 0; + etype = unknown; + } ~tree_expression (void) { } @@ -149,14 +155,14 @@ tree_matrix (void) { - dir_next = tree_matrix::md_none; + direction = tree_matrix::md_none; element = 0; next = 0; } tree_matrix (tree_expression *e, tree_matrix::dir d) { - dir_next = d; + direction = d; element = e; next = 0; } @@ -171,8 +177,10 @@ tree_constant eval (int print); + void print_code (ostream& os); + private: - tree_matrix::dir dir_next; // Direction to the next element. + tree_matrix::dir direction; // Direction from the previous element. tree_expression *element; tree_matrix *next; }; @@ -224,13 +232,13 @@ friend class tree_index_expression; public: - tree_identifier (int l = -1, int c = -1) + tree_identifier (int l = -1, int c = -1) : tree_fvc (l, c) { sym = 0; maybe_do_ans_assign = 0; } - tree_identifier (symbol_record *s, int l = -1, int c = -1) + tree_identifier (symbol_record *s, int l = -1, int c = -1) : tree_fvc (l, c) { sym = s; maybe_do_ans_assign = 0; @@ -255,10 +263,6 @@ void bump_value (tree_expression::type); - int load_fcn_from_file (int exec_script = 1); - - int parse_fcn_file (int exec_script = 1, char *ff = 0); - tree_fvc *do_lookup (int& script_file_executed); void link_to_global (void) @@ -278,6 +282,8 @@ void eval_undefined_error (void); + void print_code (ostream& os); + private: symbol_record *sym; int maybe_do_ans_assign; @@ -333,6 +339,8 @@ void eval_error (void); + void print_code (ostream& os); + private: tree_identifier *id; tree_argument_list *list; @@ -368,6 +376,10 @@ int is_prefix_expression (void) const { return 1; } + char *oper (void) const; + + void print_code (ostream& os); + private: tree_identifier *id; }; @@ -399,6 +411,10 @@ void eval_error (void); + char *oper (void) const; + + void print_code (ostream& os); + private: tree_identifier *id; }; @@ -430,6 +446,10 @@ void eval_error (void); + char *oper (void) const; + + void print_code (ostream& os); + private: tree_expression *op; }; @@ -466,6 +486,10 @@ void eval_error (void); + char *oper (void) const; + + void print_code (ostream& os); + private: tree_expression *op1; tree_expression *op2; @@ -477,14 +501,9 @@ tree_assignment_expression : public tree_expression { public: - int in_parens; - tree_assignment_expression (int l = -1, int c = -1) : tree_expression (l, c) - { - in_parens = 0; - etype = tree_expression::assignment; - } + { etype = tree_expression::assignment; } ~tree_assignment_expression (void) { } @@ -500,38 +519,42 @@ tree_simple_assignment_expression : public tree_assignment_expression { public: - tree_simple_assignment_expression (int plhs = 0, int l = -1, int c = -1) + void init (int plhs, int ans_assign) + { + etype = tree_expression::assignment; + lhs = 0; + index = 0; + rhs = 0; + preserve = plhs; + ans_ass = ans_assign; + } + + tree_simple_assignment_expression (int plhs = 0, int ans_assign = 0, + int l = -1, int c = -1) : tree_assignment_expression (l, c) - { - etype = tree_expression::assignment; - lhs = 0; - index = 0; - rhs = 0; - preserve = plhs; - } + { init (plhs, ans_assign); } tree_simple_assignment_expression (tree_identifier *i, tree_expression *r, - int plhs = 0, int l = -1, int c = -1) + int plhs = 0, int ans_assign = 0, + int l = -1, int c = -1) : tree_assignment_expression (l, c) { - etype = tree_expression::assignment; + init (plhs, ans_assign); lhs = i; - index = 0; rhs = r; - preserve = plhs; } tree_simple_assignment_expression (tree_index_expression *idx_expr, tree_expression *r, - int plhs = 0, int l = -1, int c = -1) + int plhs = 0, int ans_assign = 0, + int l = -1, int c = -1) : tree_assignment_expression (l, c) { - etype = tree_expression::assignment; + init (plhs, ans_assign); lhs = idx_expr->ident (); index = idx_expr->arg_list (); rhs = r; - preserve = plhs; } ~tree_simple_assignment_expression (void); @@ -539,15 +562,21 @@ tree_identifier *left_hand_side (void) { return lhs; } + int is_ans_assign (void) + { return ans_ass; } + tree_constant eval (int print); void eval_error (void); + void print_code (ostream& os); + private: tree_identifier *lhs; tree_argument_list *index; tree_expression *rhs; int preserve; + int ans_ass; }; // Multi-valued assignment expressions. @@ -582,6 +611,8 @@ void eval_error (void); + void print_code (ostream& os); + private: tree_return_list *lhs; tree_expression *rhs; @@ -624,6 +655,8 @@ void eval_error (const char *s); + void print_code (ostream& os); + private: tree_expression *op1; tree_expression *op2; @@ -660,6 +693,11 @@ int max_expected_args (void); + void print_code (ostream& os) + { + os << my_name << " can't be printed because it is a builtin function\n"; + } + private: int nargin_max; int nargout_max; @@ -745,6 +783,8 @@ void traceback_error (void); + void print_code (ostream& os); + private: int call_depth; tree_parameter_list *param_list;
--- a/src/pt-misc.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-misc.cc Sun Aug 07 01:02:15 1994 +0000 @@ -34,6 +34,8 @@ #include <unistd.h> #endif +#include <iostream.h> + #include "error.h" #include "tree.h" #include "tree-misc.h" @@ -59,6 +61,31 @@ delete expression; } +void +tree_statement::print_code (ostream& os) +{ + if (command) + { + command->print_code (os); + + if (! print_flag) + os << ";"; + + command->print_code_new_line (os); + } + else if (expression) + { + expression->print_code (os); + + if (! print_flag) + os << ";"; + + expression->print_code_new_line (os); + } + + +} + tree_constant tree_statement_list::eval (int print) { @@ -102,6 +129,18 @@ return retval; } +void +tree_statement_list::print_code (ostream& os) +{ + for (Pix p = first (); p != 0; next (p)) + { + tree_statement *elt = this->operator () (p); + + if (elt) + elt->print_code (os); + } +} + Octave_object tree_argument_list::convert_to_const_vector (void) { @@ -135,6 +174,27 @@ return args; } +void +tree_argument_list::print_code (ostream& os) +{ + Pix p = first (); + + while (p) + { + tree_expression *elt = this->operator () (p); + + next (p); + + if (elt) + { + elt->print_code (os); + + if (p) + os << ", "; + } + } +} + // Parameter lists. void @@ -225,6 +285,52 @@ } void +tree_parameter_list::print_code (ostream& os) +{ + Pix p = first (); + + while (p) + { + tree_identifier *elt = this->operator () (p); + + next (p); + + if (elt) + { + elt->print_code (os); + + if (p) + os << ", "; + } + } +} + +// Return lists. + +void +tree_return_list::print_code (ostream& os) +{ + Pix p = first (); + + while (p) + { + tree_index_expression *elt = this->operator () (p); + + next (p); + + if (elt) + { + elt->print_code (os); + + if (p) + os << ", "; + } + } +} + +// Global. + +void tree_global::eval (void) { if (ident) @@ -243,6 +349,18 @@ } void +tree_global::print_code (ostream& os) +{ + if (ident) + ident->print_code (os); + + if (assign_expr) + assign_expr->print_code (os); +} + +// Global initializer lists. + +void tree_global_init_list::eval (void) { for (Pix p = first (); p != 0; next (p)) @@ -252,6 +370,29 @@ } } +void +tree_global_init_list::print_code (ostream& os) +{ + Pix p = first (); + + while (p) + { + tree_global *elt = this->operator () (p); + + next (p); + + if (elt) + { + elt->print_code (os); + + if (p) + os << ", "; + } + } +} + +// If. + int tree_if_clause::eval (void) { @@ -309,6 +450,38 @@ } void +tree_if_clause::print_code (ostream& os) +{ + if (expr) + { + expr->print_code (os); + + print_code_new_line (os); + + increment_indent_level (); + } + else + { + print_code_indent (os); + + os << "else"; + + print_code_new_line (os); + + increment_indent_level (); + } + + if (list) + { + list->print_code (os); + + decrement_indent_level (); + } +} + +// List of if commands. + +void tree_if_command_list::eval (void) { for (Pix p = first (); p != 0; next (p)) @@ -320,6 +493,35 @@ } } +void +tree_if_command_list::print_code (ostream& os) +{ + Pix p = first (); + + int first_elt = 1; + + while (p) + { + tree_if_clause *elt = this->operator () (p); + + next (p); + + if (elt) + { + if (p && ! first_elt) + { + print_code_indent (os); + + os << "elseif "; + } + + elt->print_code (os); + } + + first_elt = 0; + } +} + /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/pt-misc.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-misc.h Sun Aug 07 01:02:15 1994 +0000 @@ -28,6 +28,7 @@ #pragma interface #endif +class ostream; class Octave_object; class tree_constant; class tree_command; @@ -54,7 +55,7 @@ // A list of expressions and commands to be executed. class -tree_statement +tree_statement : public tree_print_code { friend class tree_statement_list; @@ -85,6 +86,8 @@ void set_print_flag (int print) { print_flag = print; } + void print_code (ostream& os); + private: tree_command *command; // Command to execute. tree_expression *expression; // Command to execute. @@ -92,7 +95,7 @@ }; class -tree_statement_list : public SLList<tree_statement *> +tree_statement_list : public SLList<tree_statement *>, public tree_print_code { public: tree_statement_list (void) : SLList<tree_statement *> () { } @@ -109,13 +112,15 @@ } tree_constant eval (int print); + + void print_code (ostream& os); }; // Argument lists. Used to hold the list of expressions that are the // arguments in a function call or index expression. class -tree_argument_list : public SLList<tree_expression *> +tree_argument_list : public SLList<tree_expression *>, public tree_print_code { public: tree_argument_list (void) : SLList<tree_expression *> () { } @@ -132,6 +137,8 @@ } Octave_object convert_to_const_vector (void); + + void print_code (ostream& os); }; // Parameter lists. Used to hold the list of input and output @@ -139,7 +146,7 @@ // only. class -tree_parameter_list : public SLList<tree_identifier *> +tree_parameter_list : public SLList<tree_identifier *>, public tree_print_code { public: tree_parameter_list (void) : SLList<tree_identifier *> () { } @@ -177,6 +184,8 @@ Octave_object convert_to_const_vector (void); + void print_code (ostream& os); + private: int marked_for_varargs; }; @@ -185,7 +194,8 @@ // assignment expressions. class -tree_return_list : public SLList<tree_index_expression *> +tree_return_list : public SLList<tree_index_expression *>, + public tree_print_code { public: tree_return_list (void) : SLList<tree_index_expression *> () { } @@ -201,12 +211,14 @@ delete t; } } + + void print_code (ostream& os); }; // List of expressions that make up a global statement. class -tree_global +tree_global : public tree_print_code { public: tree_global (void) @@ -235,13 +247,15 @@ void eval (void); + void print_code (ostream& os); + private: tree_identifier *ident; tree_simple_assignment_expression *assign_expr; }; class -tree_global_init_list : public SLList<tree_global *> +tree_global_init_list : public SLList<tree_global *>, public tree_print_code { public: tree_global_init_list (void) : SLList<tree_global *> () { } @@ -258,10 +272,12 @@ } void eval (void); + + void print_code (ostream& os); }; class -tree_if_clause +tree_if_clause : public tree_print_code { public: tree_if_clause (void) @@ -290,13 +306,15 @@ int eval (void); + void print_code (ostream& os); + private: tree_expression *expr; tree_statement_list *list; }; class -tree_if_command_list : public SLList<tree_if_clause *> +tree_if_command_list : public SLList<tree_if_clause *>, public tree_print_code { public: tree_if_command_list (void) : SLList<tree_if_clause *> () { } @@ -313,6 +331,8 @@ } void eval (void); + + void print_code (ostream& os); }; #endif
--- a/src/pt-plot.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-plot.cc Sun Aug 07 01:02:15 1994 +0000 @@ -51,7 +51,7 @@ extern "C" { - char *tilde_expand (char *s); /* From readline's tilde.c */ +#include <readline/tilde.h> } // The number of lines we\'ve plotted so far. @@ -69,11 +69,9 @@ // Pipe to gnuplot. static oprocstream plot_stream; -/* - * Plotting, eh? - */ +// Plotting, eh? -tree_plot_command::tree_plot_command (void) +tree_plot_command::tree_plot_command (void) : tree_command () { range = 0; plot_list = 0; @@ -81,6 +79,7 @@ } tree_plot_command::tree_plot_command (subplot_list *plt, int nd) + : tree_command () { range = 0; plot_list = plt; @@ -89,6 +88,7 @@ tree_plot_command::tree_plot_command (subplot_list *plt, plot_limits *rng, int nd) + : tree_command () { range = rng; plot_list = plt; @@ -771,9 +771,6 @@ return retval; } -/* - * Set plotting options. - */ DEFUN_TEXT ("show", Fshow, Sshow, -1, 1, "show [options]\n\ \n\
--- a/src/pt-plot.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/pt-plot.h Sun Aug 07 01:02:15 1994 +0000 @@ -28,6 +28,8 @@ #pragma interface #endif +#include <iostream.h> + class tree_command; class tree_plot_command; class plot_limits; @@ -37,8 +39,6 @@ class subplot; class subplot_list; -class ostream; - #include <SLList.h> #include "tree.h" @@ -55,6 +55,11 @@ void eval (void); + void print_code (ostream& os) + { + os << "<plot command printing not implemented yet>"; + } + private: int ndim; plot_limits *range;
--- a/src/tc-inlines.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/tc-inlines.h Sun Aug 07 01:02:15 1994 +0000 @@ -139,18 +139,6 @@ return c; } -static inline int -valid_scalar_indices (const Octave_object& args) -{ - int nargin = args.length (); - int valid = ((nargin == 3 - && args(2).valid_as_scalar_index () - && args(1).valid_as_scalar_index ()) - || (nargin == 2 && args(1).valid_as_scalar_index ())); - - return valid; -} - /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/tc-rep.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/tc-rep.cc Sun Aug 07 01:02:15 1994 +0000 @@ -51,9 +51,7 @@ #include "tc-inlines.cc" -/* - * How about a few macros? - */ +// How about a few macros? #ifndef MAX #define MAX(a,b) ((a) > (b) ? (a) : (b)) @@ -67,14 +65,12 @@ #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... - */ +// 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 @@ -231,20 +227,33 @@ return 0; } +static int +valid_scalar_indices (const Octave_object& args) +{ + int nargin = args.length (); + + return ((nargin == 3 + && args(2).valid_as_scalar_index () + && args(1).valid_as_scalar_index ()) + || (nargin == 2 + && args(1).valid_as_scalar_index ())); +} + // Now, the classes. -/* - * The real representation of constants. - */ +// The real representation of constants. + tree_constant_rep::tree_constant_rep (void) { type_tag = unknown_constant; + orig_text = 0; } tree_constant_rep::tree_constant_rep (double d) { scalar = d; type_tag = scalar_constant; + orig_text = 0; } tree_constant_rep::tree_constant_rep (const Matrix& m) @@ -259,6 +268,7 @@ matrix = new Matrix (m); type_tag = matrix_constant; } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const DiagMatrix& d) @@ -273,6 +283,7 @@ matrix = new Matrix (d); type_tag = matrix_constant; } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const RowVector& v, int @@ -307,6 +318,7 @@ type_tag = matrix_constant; } } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const ColumnVector& v, @@ -341,12 +353,14 @@ type_tag = matrix_constant; } } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const Complex& c) { complex_scalar = new Complex (c); type_tag = complex_scalar_constant; + orig_text = 0; } tree_constant_rep::tree_constant_rep (const ComplexMatrix& m) @@ -361,6 +375,7 @@ complex_matrix = new ComplexMatrix (m); type_tag = complex_matrix_constant; } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const ComplexDiagMatrix& d) @@ -375,6 +390,7 @@ complex_matrix = new ComplexMatrix (d); type_tag = complex_matrix_constant; } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const ComplexRowVector& v, @@ -409,6 +425,7 @@ type_tag = complex_matrix_constant; } } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const ComplexColumnVector& v, @@ -443,12 +460,14 @@ type_tag = complex_matrix_constant; } } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const char *s) { string = strsave (s); type_tag = string_constant; + orig_text = 0; } tree_constant_rep::tree_constant_rep (double b, double l, double i) @@ -482,6 +501,7 @@ else panic_impossible (); } + orig_text = 0; } tree_constant_rep::tree_constant_rep (const Range& r) @@ -503,13 +523,15 @@ } else panic_impossible (); + + orig_text = 0; } tree_constant_rep::tree_constant_rep (tree_constant_rep::constant_type t) { assert (t == magic_colon); - type_tag = magic_colon; + orig_text = 0; } tree_constant_rep::tree_constant_rep (const tree_constant_rep& t) @@ -544,6 +566,8 @@ panic_impossible (); break; } + + orig_text = strsave (t.orig_text); } tree_constant_rep::~tree_constant_rep (void) @@ -575,6 +599,8 @@ panic_impossible (); break; } + + delete [] orig_text; } #if defined (MDEBUG) @@ -815,6 +841,12 @@ return retval; } +void +tree_constant_rep::stash_original_text (char *s) +{ + orig_text = strsave (s); +} + tree_constant_rep::constant_type tree_constant_rep::force_numeric (int force_str_conv) { @@ -1315,6 +1347,127 @@ } } +static char * +undo_string_escapes (char c) +{ + static char retval[2]; + retval[1] = '\0'; + + if (! c) + return 0; + + switch (c) + { + case '\a': + return "\\a"; + case '\b': // backspace + return "\\b"; + case '\f': // formfeed + return "\\f"; + case '\n': // newline + return "\\n"; + case '\r': // carriage return + return "\\r"; + case '\t': // horizontal tab + return "\\t"; + case '\v': // vertical tab + return "\\v"; + case '\\': // backslash + return "\\\\"; + case '"': // double quote + return "\\\""; + default: + retval[0] = c; + return retval; + } +} + +void +tree_constant_rep::print_code (ostream& os) +{ + int nr = rows (); + int nc = columns (); + + switch (type_tag) + { + case scalar_constant: + if (orig_text) + os << orig_text; + else + os << scalar; + break; + case matrix_constant: + if (nr == 0 || nc == 0) + os << "[]"; + else + panic_impossible (); + break; + case complex_scalar_constant: + { + double re = complex_scalar->real (); + double im = complex_scalar->imag (); + +// We don't collapse Re +/- Im into a complex number yet, so if we get +// here, we had better have a pure imaginary number that's positive... + + assert (re == 0.0 && im > 0.0); + + if (orig_text) + os << orig_text; + else + os << im; + +#if 0 + int sign_printed = 0; + + if (re != 0.0) + { + os << re; + + if (im > 0.0) + { + os << " + "; + sign_printed = 1; + } + else if (im < 0.0) + { + os << " - "; + sign_printed = 1; + } + } + + if (im != 0.0) + os << (sign_printed ? (im < 0.0 ? -im : im) : im); +#endif + } + break; + case complex_matrix_constant: + if (nr == 0 || nc == 0) + os << "[]"; + else + panic_impossible (); + break; + case string_constant: + { + os << "\""; + char *s, *t = string; + while (s = undo_string_escapes (*t++)) + os << s; + os << "\""; + } + break; + case range_constant: + panic_impossible (); + break; + case magic_colon: + os << ":"; + break; + default: + panic_impossible (); + break; + } +} + tree_constant tree_constant_rep::do_index (const Octave_object& args) { @@ -1968,7 +2121,7 @@ } break; case string_constant: - retval = tree_constant (*this); + retval = string; break; case magic_colon: default: @@ -2653,11 +2806,10 @@ return retval; } -/* - * 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. - */ +// 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 (const tree_constant& rhs, const Octave_object& args) { @@ -2693,10 +2845,9 @@ } } -/* - * Assignments to scalars. If resize_on_range_error is true, - * this can convert the left-hand side to a matrix. - */ +// Assignments to scalars. If resize_on_range_error is true, +// this can convert the left-hand side to a matrix. + void tree_constant_rep::do_scalar_assignment (const tree_constant& rhs, const Octave_object& args) @@ -2798,12 +2949,11 @@ ::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. - */ +// 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 (const tree_constant& rhs, const Octave_object& args) @@ -2874,9 +3024,8 @@ } } -/* - * Matrix assignments indexed by a single value. - */ +// Matrix assignments indexed by a single value. + void tree_constant_rep::do_matrix_assignment (const tree_constant& rhs, const tree_constant& i_arg) @@ -2918,11 +3067,10 @@ ::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. - */ +// 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 (const tree_constant& rhs, const tree_constant& i_arg) @@ -3083,9 +3231,8 @@ } } -/* - * Fortran-style assignment for vector index. - */ +// Fortran-style assignment for vector index. + void tree_constant_rep::fortran_style_matrix_assignment (const tree_constant& rhs, idx_vector& i) @@ -3128,9 +3275,8 @@ ::error ("number of rows and columns must match for indexed assignment"); } -/* - * Fortran-style assignment for colon index. - */ +// Fortran-style assignment for colon index. + void tree_constant_rep::fortran_style_matrix_assignment (const tree_constant& rhs, tree_constant_rep::constant_type mci) @@ -3176,11 +3322,10 @@ } } -/* - * 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. - */ +// 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 (const tree_constant& rhs, const tree_constant& i_arg) @@ -3260,9 +3405,8 @@ } } -/* - * Check whether an indexed assignment to a vector is valid. - */ +// 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) @@ -3298,9 +3442,8 @@ panic_impossible (); } -/* - * Assignment to a vector with an integer index. - */ +// Assignment to a vector with an integer index. + void tree_constant_rep::do_vector_assign (const tree_constant& rhs, int i) { @@ -3356,9 +3499,8 @@ } } -/* - * Assignment to a vector with a vector index. - */ +// Assignment to a vector with a vector index. + void tree_constant_rep::do_vector_assign (const tree_constant& rhs, idx_vector& iv) @@ -3462,9 +3604,8 @@ panic_impossible (); } -/* - * Assignment to a vector with a range index. - */ +// Assignment to a vector with a range index. + void tree_constant_rep::do_vector_assign (const tree_constant& rhs, Range& ri) @@ -3561,20 +3702,19 @@ 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. - */ +// 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 (const tree_constant& rhs, const tree_constant& i_arg, @@ -4212,23 +4352,21 @@ } } -/* - * 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 | - * ---------+---+---+----+----+ - */ +// 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 @@ -4648,12 +4786,11 @@ } } -/* - * Functions for deleting rows or columns of a matrix. These are used - * to handle statements like - * - * M (i, j) = [] - */ +// 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) { @@ -5006,31 +5143,32 @@ panic_impossible (); } -/* - * Indexing functions. - */ +// Indexing functions. + 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; + return (type_tag == magic_colon + || (type_tag == scalar_constant && NINT (scalar) == 1) + || (type_tag == range_constant + && range->nelem () == 1 && NINT (range->base ()) == 1)); } tree_constant tree_constant_rep::do_scalar_index (const Octave_object& args) const { + tree_constant retval; + if (valid_scalar_indices (args)) { if (type_tag == scalar_constant) - return tree_constant (scalar); + retval = scalar; else if (type_tag == complex_scalar_constant) - return tree_constant (*complex_scalar); + retval = *complex_scalar; else panic_impossible (); + + return retval; } else { @@ -5049,7 +5187,7 @@ idx_vector j (mj, user_pref.do_fortran_indexing, ""); if (! j) - return tree_constant (); + return retval; int len = j.length (); if (len == j.ones_count ()) @@ -5073,7 +5211,7 @@ idx_vector i (mi, user_pref.do_fortran_indexing, ""); if (! i) - return tree_constant (); + return retval; int len = i.length (); if (len == i.ones_count ()) @@ -5088,8 +5226,7 @@ else if (args(1).is_scalar_type () && NINT (args(1).double_value ()) == 0) { - Matrix m (0, 0); - return tree_constant (m); + return Matrix (); } else break; @@ -5107,13 +5244,11 @@ if (type_tag == scalar_constant) { - Matrix m (rows, cols, scalar); - return tree_constant (m); + return Matrix (rows, cols, scalar); } else if (type_tag == complex_scalar_constant) { - ComplexMatrix cm (rows, cols, *complex_scalar); - return tree_constant (cm); + return ComplexMatrix (rows, cols, *complex_scalar); } else panic_impossible (); @@ -6239,8 +6374,35 @@ tree_constant_rep::constant_type mcj) const { tree_constant retval; + assert (mci == magic_colon && mcj == magic_colon); - retval = tree_constant (*this); + + 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; }
--- a/src/tc-rep.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/tc-rep.h Sun Aug 07 01:02:15 1994 +0000 @@ -39,27 +39,18 @@ struct Mapper_fcn; -/* - * Forward class declarations. - */ +// Forward class declarations. + class tree; class tree_constant; -/* - * The actual representation of the tree_constant. - */ +// The actual representation of the tree_constant. + class tree_constant_rep { friend class tree_constant; - enum force_orient - { - no_orient, - row_orient, - column_orient, - }; - public: enum constant_type { @@ -73,6 +64,14 @@ magic_colon, }; + enum force_orient + { + no_orient, + row_orient, + column_orient, + }; + +private: tree_constant_rep (void); tree_constant_rep (double d); @@ -155,6 +154,8 @@ ColumnVector to_vector (void) const; Matrix to_matrix (void) const; + void stash_original_text (char *s); + tree_constant_rep::constant_type force_numeric (int force_str_conv = 0); tree_constant make_numeric (int force_str_conv = 0) const; @@ -245,6 +246,8 @@ void maybe_mutate (void); void print (void); + void print_code (ostream& os); + tree_constant do_index (const Octave_object& args); tree_constant do_scalar_index (const Octave_object& args) const; @@ -330,7 +333,6 @@ tree_constant mapper (Mapper_fcn& m_fcn, int print) const; -private: int count; constant_type type_tag; union @@ -342,6 +344,7 @@ char *string; // A character string constant. Range *range; // A set of evenly spaced values. }; + char *orig_text; }; extern tree_constant do_binary_op (tree_constant& a, tree_constant& b,
--- a/src/token.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/token.cc Sun Aug 07 01:02:15 1994 +0000 @@ -40,6 +40,7 @@ line_num = l; column_num = c; type_tag = generic_token; + orig_text = 0; } token::token (char *s, int l, int c) @@ -48,14 +49,16 @@ column_num = c; type_tag = string_token; str = strsave (s); + orig_text = 0; } -token::token (double d, int l, int c) +token::token (double d, char *s, int l, int c) { line_num = l; column_num = c; type_tag = double_token; num = d; + orig_text = strsave (s); } token::token (end_tok_type t, int l, int c) @@ -64,6 +67,7 @@ column_num = c; type_tag = ettype_token; et = t; + orig_text = 0; } token::token (plot_tok_type t, int l, int c) @@ -72,6 +76,7 @@ column_num = c; type_tag = pttype_token; pt = t; + orig_text = 0; } token::token (symbol_record *s, int l, int c) @@ -80,12 +85,14 @@ column_num = c; type_tag = sym_rec_token; sr = s; + orig_text = 0; } token::~token (void) { if (type_tag == string_token) delete [] str; + delete [] orig_text; } int @@ -135,6 +142,12 @@ return sr; } +char * +token::text_rep (void) +{ + return orig_text; +} + /* ;;; Local Variables: *** ;;; mode: C++ ***
--- a/src/token.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/token.h Sun Aug 07 01:02:15 1994 +0000 @@ -62,7 +62,7 @@ token (int l = -1, int c = -1); token (char *s, int l = -1, int c = -1); - token (double d, int l = -1, int c = -1); + token (double d, char *s = 0, int l = -1, int c = -1); token (end_tok_type t, int l = -1, int c = -1); token (plot_tok_type t, int l = -1, int c = -1); token (symbol_record *s, int l = -1, int c = -1); @@ -78,6 +78,8 @@ plot_tok_type pttype (void); symbol_record *sym_rec (void); + char *text_rep (void); + private: int line_num; int column_num; @@ -90,6 +92,7 @@ plot_tok_type pt; symbol_record *sr; }; + char *orig_text; }; #endif
--- a/src/utils.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/utils.cc Sun Aug 07 01:02:15 1994 +0000 @@ -47,8 +47,6 @@ #include <sys/param.h> #include <setjmp.h> #include <string.h> -#include <stdlib.h> -#include <stdio.h> #include <limits.h> #include <iostream.h> #include <strstream.h> @@ -75,7 +73,7 @@ LOSE! LOSE! #endif -char *tilde_expand (char *s); /* From readline's tilde.c */ +#include <readline/tilde.h> } // This mess suggested by the autoconf manual. @@ -118,9 +116,8 @@ // Top level context (?) extern jmp_buf toplevel; -/* - * Save a string. - */ +// Save a string. + char * strsave (const char *s) { @@ -133,9 +130,8 @@ return tmp; } -/* - * Concatenate two strings. - */ +// Concatenate two strings. + char * strconcat (const char *s, const char *t) { @@ -145,9 +141,8 @@ return strcat (tmp, t); } -/* - * Throw away input until a given character is read. - */ +// Throw away input until a given character is read. + void discard_until (istream& stream, char character) { @@ -211,9 +206,8 @@ return path; } -/* - * Return to the main command loop in octave.cc. - */ +// Return to the main command loop in octave.cc. + void jump_to_top_level (void) { @@ -236,9 +230,8 @@ : (strncasecmp (std, s, slen) == 0))); } -/* - * Ugh. - */ +// Ugh. + int keyword_almost_match (const char **std, int *min_len, const char *s, int min_toks_to_match, int max_toks) @@ -473,10 +466,9 @@ return argv; } -/* - * Format a list in neat columns. Mostly stolen from GNU ls. This - * should maybe be in utils.cc. - */ +// Format a list in neat columns. Mostly stolen from GNU ls. This +// should maybe be in utils.cc. + ostrstream& list_in_columns (ostrstream& os, char **list) { @@ -541,9 +533,8 @@ return os; } -/* - * See if the given file is in the path. - */ +// See if the given file is in the path. + char * file_in_path (const char *name, const char *suffix) { @@ -587,20 +578,18 @@ return retval; } -/* - * See if there is an function file in the path. If so, return the - * full path to the file. - */ +// See if there is an function file in the path. If so, return the +// full path to the file. + char * fcn_file_in_path (const char *name) { return file_in_path (name, ".m"); } -/* - * See if there is an octave file in the path. If so, return the - * full path to the file. - */ +// See if there is an octave file in the path. If so, return the +// full path to the file. + char * oct_file_in_path (const char *name) {
--- a/src/variables.cc Sun Aug 07 01:02:15 1994 +0000 +++ b/src/variables.cc Sun Aug 07 01:02:15 1994 +0000 @@ -36,55 +36,62 @@ #include <iostream.h> #include <strstream.h> -#include "statdefs.h" +#include "octave-hist.h" +#include "unwind-prot.h" +#include "user-prefs.h" #include "tree-const.h" #include "variables.h" -#include "mappers.h" -#include "user-prefs.h" +#include "statdefs.h" +#include "defaults.h" #include "version.h" -#include "symtab.h" -#include "defaults.h" +#include "mappers.h" +#include "oct-obj.h" +#include "sysdep.h" #include "dirfns.h" -#include "pager.h" -#include "sysdep.h" +#include "symtab.h" #include "octave.h" -#include "oct-obj.h" #include "error.h" +#include "pager.h" #include "utils.h" +#include "defun.h" +#include "input.h" +#include "parse.h" #include "tree.h" #include "help.h" -#include "defun.h" +#include "lex.h" extern "C" { +#include <readline/readline.h> #include <readline/tilde.h> #include "fnmatch.h" } // Symbol table for symbols at the top level. -symbol_table *top_level_sym_tab; +symbol_table *top_level_sym_tab = 0; // Symbol table for the current scope. -symbol_table *curr_sym_tab; +symbol_table *curr_sym_tab = 0; // Symbol table for global symbols. -symbol_table *global_sym_tab; +symbol_table *global_sym_tab = 0; void initialize_symbol_tables (void) { - global_sym_tab = new symbol_table (); + if (! global_sym_tab) + global_sym_tab = new symbol_table (); - top_level_sym_tab = new symbol_table (); + if (! top_level_sym_tab) + top_level_sym_tab = new symbol_table (); curr_sym_tab = top_level_sym_tab; } -/* - * Is there a corresponding function file that is newer than the - * symbol definition? - */ +// Is there a corresponding function file that is newer than the +// symbol definition? + int symbol_out_of_date (symbol_record *sr) { @@ -113,6 +120,227 @@ return 0; } +static void +gobble_leading_white_space (FILE *ffile) +{ + int in_comment = 0; + int c; + while ((c = getc (ffile)) != EOF) + { + if (in_comment) + { + if (c == '\n') + in_comment = 0; + } + else + { + if (c == ' ' || c == '\t' || c == '\n') + continue; + else if (c == '%' || c == '#') + in_comment = 1; + else + { + ungetc (c, ffile); + break; + } + } + } +} + +static int +is_function_file (FILE *ffile) +{ + int status = 0; + + gobble_leading_white_space (ffile); + + long pos = ftell (ffile); + + char buf [10]; + fgets (buf, 10, ffile); + int len = strlen (buf); + if (len > 8 && strncmp (buf, "function", 8) == 0 + && ! (isalnum (buf[8]) || buf[8] == '_')) + status = 1; + + fseek (ffile, pos, SEEK_SET); + + return status; +} + +static int +parse_fcn_file (int exec_script, char *ff) +{ + begin_unwind_frame ("parse_fcn_file"); + + int script_file_executed = 0; + + assert (ff); + +// Open function file and parse. + + int old_reading_fcn_file_state = reading_fcn_file; + + unwind_protect_ptr (rl_instream); + unwind_protect_ptr (ff_instream); + + unwind_protect_int (using_readline); + unwind_protect_int (input_line_number); + unwind_protect_int (current_input_column); + unwind_protect_int (reading_fcn_file); + + using_readline = 0; + reading_fcn_file = 1; + input_line_number = 0; + current_input_column = 1; + + FILE *ffile = get_input_from_file (ff, 0); + + if (ffile) + { +// Check to see if this file defines a function or is just a list of +// commands. + + if (is_function_file (ffile)) + { + unwind_protect_int (echo_input); + unwind_protect_int (saving_history); + unwind_protect_int (reading_fcn_file); + + echo_input = 0; + saving_history = 0; + reading_fcn_file = 1; + + YY_BUFFER_STATE old_buf = current_buffer (); + YY_BUFFER_STATE new_buf = create_buffer (ffile); + + 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 (); + + int status = yyparse (); + + if (status != 0) + { + error ("parse error while reading function file %s", ff); + global_sym_tab->clear (curr_fcn_file_name); + } + } + else if (exec_script) + { +// The value of `reading_fcn_file' will be restored to the proper value +// when we unwind from this frame. + reading_fcn_file = old_reading_fcn_file_state; + + unwind_protect_int (reading_script_file); + reading_script_file = 1; + + parse_and_execute (ffile, 1); + + script_file_executed = 1; + } + fclose (ffile); + } + + run_unwind_frame ("parse_fcn_file"); + + return script_file_executed; +} + +int +load_fcn_from_file (symbol_record *sym_rec, int exec_script) +{ + int script_file_executed = 0; + + char *nm = sym_rec->name (); + + curr_fcn_file_name = nm; + + char *oct_file = oct_file_in_path (curr_fcn_file_name); + + int loaded_oct_file = 0; + + if (oct_file) + { + cerr << "found: " << oct_file << "\n"; + + delete [] oct_file; + +// XXX FIXME XXX -- this is where we try to link to an external +// object... + loaded_oct_file = 1; + } + + if (! loaded_oct_file) + { + char *ff = fcn_file_in_path (curr_fcn_file_name); + + if (ff) + { + script_file_executed = parse_fcn_file (exec_script, ff); + delete [] ff; + } + + if (! (error_state || script_file_executed)) + force_link_to_function (nm); + } + + return script_file_executed; +} + +int +lookup (symbol_record *sym_rec, int exec_script) +{ + int script_file_executed = 0; + + if (! sym_rec->is_linked_to_global ()) + { + if (sym_rec->is_defined ()) + { + if (sym_rec->is_function () && symbol_out_of_date (sym_rec)) + { + script_file_executed = load_fcn_from_file (sym_rec, exec_script); + } + } + else if (! sym_rec->is_formal_parameter ()) + { + link_to_builtin_or_function (sym_rec); + + if (! sym_rec->is_defined ()) + { + script_file_executed = load_fcn_from_file (sym_rec, exec_script); + } + else if (sym_rec->is_function () && symbol_out_of_date (sym_rec)) + { + script_file_executed = load_fcn_from_file (sym_rec, exec_script); + } + } + } + + return script_file_executed; +} + +// Get the symbol record for the given name that is visible in the +// current scope. Reread any function definitions that appear to be +// out of date. If a function is available in a file but is not +// currently loaded, this will load it and insert the name in the +// current symbol table. + +symbol_record * +lookup_by_name (const char *nm, int exec_script) +{ + symbol_record *sym_rec = curr_sym_tab->lookup (nm, 1, 0); + + lookup (sym_rec, exec_script); + + return sym_rec; +} + void document_symbol (const char *name, const char *help) { @@ -237,10 +465,9 @@ sr->protect (); } -/* - * Give a global variable a definition. This will insert the symbol - * in the global table if necessary. - */ +// Give a global variable a definition. This will insert the symbol +// in the global table if necessary. + void bind_builtin_variable (const char *varname, tree_constant *val, int protect, int eternal, sv_Function sv_fcn, @@ -274,10 +501,9 @@ sr->document (help); } -/* - * Look for the given name in the global symbol table. If it refers - * to a string, return a new copy. If not, return 0; - */ +// Look for the given name in the global symbol table. If it refers +// to a string, return a new copy. If not, return 0; + char * builtin_string_variable (const char *name) { @@ -306,11 +532,10 @@ return retval; } -/* - * Look for the given name in the global symbol table. If it refers - * to a real scalar, place the value in d and return 0. Otherwise, - * return -1. - */ +// Look for the given name in the global symbol table. If it refers +// to a real scalar, place the value in d and return 0. Otherwise, +// return -1. + int builtin_real_scalar_variable (const char *name, double& d) { @@ -338,11 +563,10 @@ return status; } -/* - * Make the definition of the symbol record sr be the same as the - * definition of the global variable of the same name, creating it if - * it doesn't already exist. - */ +// Make the definition of the symbol record sr be the same as the +// definition of the global variable of the same name, creating it if +// it doesn't already exist. + void link_to_global_variable (symbol_record *sr) { @@ -382,10 +606,9 @@ sr->mark_as_linked_to_global (); } -/* - * Make the definition of the symbol record sr be the same as the - * definition of the builtin variable of the same name. - */ +// Make the definition of the symbol record sr be the same as the +// definition of the builtin variable of the same name. + void link_to_builtin_variable (symbol_record *sr) { @@ -395,12 +618,11 @@ sr->alias (tmp_sym); } -/* - * Make the definition of the symbol record sr be the same as the - * definition of the builtin variable or function, or user function of - * the same name, provided that the name has not been used as a formal - * parameter. - */ +// Make the definition of the symbol record sr be the same as the +// definition of the builtin variable or function, or user function of +// the same name, provided that the name has not been used as a formal +// parameter. + void link_to_builtin_or_function (symbol_record *sr) { @@ -412,15 +634,14 @@ sr->alias (tmp_sym); } -/* - * Force a link to a function in the current symbol table. This is - * used just after defining a function to avoid different behavior - * depending on whether or not the function has been evaluated after - * being defined. - * - * Return without doing anything if there isn't a function with the - * given name defined in the global symbol table. - */ +// Force a link to a function in the current symbol table. This is +// used just after defining a function to avoid different behavior +// depending on whether or not the function has been evaluated after +// being defined. +// +// Return without doing anything if there isn't a function with the +// given name defined in the global symbol table. + void force_link_to_function (const char *id_name) { @@ -456,15 +677,14 @@ return retval; } -/* - * Extract a keyword and its value from a file. Input should look - * something like: - * - * #[ \t]*keyword[ \t]*:[ \t]*string-value\n - * - * Returns a pointer to new storage. The caller is responsible for - * deleting it. - */ +// Extract a keyword and its value from a file. Input should look +// something like: +// +// #[ \t]*keyword[ \t]*:[ \t]*string-value\n +// +// Returns a pointer to new storage. The caller is responsible for +// deleting it. + char * extract_keyword (istream& is, char *keyword) { @@ -558,9 +778,8 @@ return status; } -/* - * Skip trailing white space and - */ +// Skip trailing white space and + void skip_comments (istream& is) { @@ -583,9 +802,8 @@ } } -/* - * Is `s' a valid identifier? - */ +// Is `s' a valid identifier? + int valid_identifier (char *s) { @@ -646,9 +864,8 @@ return retval; } -/* - * Is this variable a builtin? - */ +// Is this variable a builtin? + int is_builtin_variable (const char *name) { @@ -656,9 +873,8 @@ return (sr && sr->is_builtin_variable ()); } -/* - * Is this tree_constant a valid function? - */ +// Is this tree_constant a valid function? + tree_fvc * is_valid_function (const tree_constant& arg, char *warn_for, int warn) { @@ -675,15 +891,11 @@ symbol_record *sr = global_sym_tab->lookup (fcn_name, 0, 0); if (sr && symbol_out_of_date (sr)) - { - tree_identifier tmp (sr); - tmp.load_fcn_from_file (0); - } + load_fcn_from_file (sr, 0); else { sr = global_sym_tab->lookup (fcn_name, 1, 0); - tree_identifier tmp (sr); - tmp.load_fcn_from_file (0); + load_fcn_from_file (sr, 0); } ans = sr->def (); @@ -698,9 +910,8 @@ return ans; } -/* - * Does this function take the right number of arguments? - */ +// Does this function take the right number of arguments? + int takes_correct_nargs (tree_fvc *fcn, int expected_nargin, char *warn_for, int warn) @@ -972,9 +1183,8 @@ "on IEEE machines, allow divide by zero errors to be suppressed"); } -/* - * List variable names. - */ +// List variable names. + static void print_symbol_info_line (ostrstream& output_buf, const symbol_record_info& s) { @@ -1375,9 +1585,8 @@ return retval; } -/* - * Return nonzero if PATTERN has any special globbing chars in it. - */ +// Return nonzero if PATTERN has any special globbing chars in it. + static int glob_pattern_p (char *pattern) { @@ -1530,16 +1739,11 @@ return retval; } -DEFUN_TEXT ("who", Fwho, Swho, -1, 1, - "who [-all] [-builtins] [-functions] [-long] [-variables]\n\ -\n\ -List currently defined symbol(s). Options may be shortened to one\n\ -character, but may not be combined.") +static Octave_object +do_who (int argc, char **argv, int nargout) { Octave_object retval; - DEFINE_ARGV("who"); - int show_builtins = 0; int show_functions = (curr_sym_tab == top_level_sym_tab); int show_variables = 1; @@ -1628,11 +1832,52 @@ output_buf << ends; maybe_page_output (output_buf); + return retval; +} + +DEFUN_TEXT ("who", Fwho, Swho, -1, 1, + "who [-all] [-builtins] [-functions] [-long] [-variables]\n\ +\n\ +List currently defined symbol(s). Options may be shortened to one\n\ +character, but may not be combined.") +{ + Octave_object retval; + + DEFINE_ARGV("who"); + + retval = do_who (argc, argv, nargout); + DELETE_ARGV; return retval; } +DEFUN_TEXT ("whos", Fwhos, Swhos, -1, 1, + "whos [-all] [-builtins] [-functions] [-long] [-variables]\n\ +\n\ +List currently defined symbol(s). Options may be shortened to one\n\ +character, but may not be combined.") +{ + Octave_object retval; + + Octave_object tmp_args = args; + tmp_args(args.length ()) = "-long"; + + int argc = tmp_args.length (); + char **argv = make_argv (tmp_args, "whos"); + + if (error_state) + return retval; + + retval = do_who (argc, argv, nargout); + + while (--argc >= 0) + delete [] argv[argc]; + delete [] argv; + + return retval; +} + // XXX FIXME XXX -- should these really be here? char * @@ -1685,15 +1930,14 @@ #endif } -/* - * Handle OCTAVE_PATH from the environment like TeX handles TEXINPUTS. - * If the path starts with `:', prepend the standard path. If it ends - * with `:' append the standard path. If it begins and ends with - * `:', do both (which is useless, but the luser asked for it...). - * - * This function may eventually be called more than once, so be - * careful not to create memory leaks. - */ +// Handle OCTAVE_PATH from the environment like TeX handles TEXINPUTS. +// If the path starts with `:', prepend the standard path. If it ends +// with `:' append the standard path. If it begins and ends with +// `:', do both (which is useless, but the luser asked for it...). +// +// This function may eventually be called more than once, so be +// careful not to create memory leaks. + char * default_path (void) {
--- a/src/variables.h Sun Aug 07 01:02:15 1994 +0000 +++ b/src/variables.h Sun Aug 07 01:02:15 1994 +0000 @@ -66,6 +66,12 @@ extern int symbol_out_of_date (symbol_record *sr); +extern int load_fcn_from_file (symbol_record *s, int exec_script = 1); + +extern int lookup (symbol_record *s, int exec_script = 1); + +extern symbol_record *lookup_by_name (const char *nm, int exec_script = 1); + extern void document_symbol (const char *name, const char *help); extern void install_builtin_mapper (builtin_mapper_function *mf);