Mercurial > octave-nkf
changeset 593:6f948c6251a9
[project @ 1994-08-09 04:29:10 by jwe]
| author | jwe |
|---|---|
| date | Tue, 09 Aug 1994 04:29:10 +0000 |
| parents | a6ceb977bd95 |
| children | 45172f0adca5 |
| files | src/pt-const.h src/pt-plot.h src/tc-rep.cc src/tc-rep.h src/variables.cc src/variables.h |
| diffstat | 6 files changed, 1075 insertions(+), 1058 deletions(-) [+] |
line wrap: on
line diff
--- a/src/pt-const.h Tue Aug 09 01:26:57 1994 +0000 +++ b/src/pt-const.h Tue Aug 09 04:29:10 1994 +0000 @@ -192,11 +192,6 @@ int save_three_d (ostream& os, int parametric = 0) { return rep->save_three_d (os, parametric); } - int load (istream& is) { return rep->load (is); } - tree_constant_rep::constant_type load - (istream& is, tree_constant_rep::constant_type t) - { return rep->load (is, t); } - double double_value (void) const { return rep->double_value (); } Matrix matrix_value (void) const { return rep->matrix_value (); } Complex complex_value (void) const { return rep->complex_value (); }
--- a/src/pt-plot.h Tue Aug 09 01:26:57 1994 +0000 +++ b/src/pt-plot.h Tue Aug 09 04:29:10 1994 +0000 @@ -47,7 +47,7 @@ class tree_plot_command : public tree_command { - public: +public: tree_plot_command (void); tree_plot_command (subplot_list *plt, int nd); tree_plot_command (subplot_list *plt, plot_limits *rng, int nd); @@ -56,21 +56,18 @@ void eval (void); - void print_code (ostream& os) - { - os << "<plot command printing not implemented yet>"; - } + void print_code (ostream& os); - private: +private: int ndim; plot_limits *range; subplot_list *plot_list; }; class -plot_limits +plot_limits : public tree_print_code { - public: +public: plot_limits (void); plot_limits (plot_range *xlim); plot_limits (plot_range *xlim, plot_range *ylim); @@ -81,16 +78,18 @@ void print (int print, ostrstream& plot_buf); - private: + void print_code (ostream& os); + +private: plot_range *x_range; plot_range *y_range; plot_range *z_range; }; class -plot_range +plot_range : public tree_print_code { - public: +public: plot_range (void); plot_range (tree_expression *l, tree_expression *u); @@ -98,15 +97,17 @@ void print (ostrstream& plot_buf); - private: + void print_code (ostream& os); + +private: tree_expression *lower; tree_expression *upper; }; class -subplot_using +subplot_using : public tree_print_code { - public: +public: subplot_using (void); subplot_using (tree_expression *fmt); @@ -118,16 +119,18 @@ int print (int ndim, int n_max, ostrstream& plot_buf); - private: + void print_code (ostream& os); + +private: int qualifier_count; tree_expression *x[4]; tree_expression *scanf_fmt; }; class -subplot_style +subplot_style : public tree_print_code { - public: +public: subplot_style (void); subplot_style (char *s); subplot_style (char *s, tree_expression *lt); @@ -137,14 +140,16 @@ int print (ostrstream& plot_buf); - private: + void print_code (ostream& os); + +private: char *style; tree_expression *linetype; tree_expression *pointtype; }; class -subplot +subplot : public tree_print_code { public: subplot (void) @@ -185,6 +190,8 @@ int print (int ndim, ostrstream& plot_buf); + void print_code (ostream& os); + private: tree_expression *plot_data; subplot_using *using; @@ -193,7 +200,7 @@ }; class -subplot_list : public SLList<subplot *> +subplot_list : public SLList<subplot *>, public tree_print_code { public: subplot_list (void) : SLList<subplot *> () { } @@ -208,6 +215,10 @@ delete t; } } + + int print (int ndim, ostrstream& plot_buf); + + void print_code (ostream& os); }; extern char *save_in_tmp_file (tree_constant& t, int ndim = 2,
--- a/src/tc-rep.cc Tue Aug 09 01:26:57 1994 +0000 +++ b/src/tc-rep.cc Tue Aug 09 04:29:10 1994 +0000 @@ -1630,146 +1630,6 @@ return 1; } -int -tree_constant_rep::load (istream& is) -{ - int is_global = 0; - - type_tag = unknown_constant; - -// Look for type keyword - - char *tag = extract_keyword (is, "type"); - - if (tag && *tag) - { - char *ptr = strchr (tag, ' '); - if (ptr) - { - *ptr = '\0'; - is_global = (strncmp (tag, "global", 6) == 0); - *ptr = ' '; - if (is_global) - ptr++; - else - ptr = tag; - } - else - ptr = tag; - - if (strncmp (ptr, "scalar", 6) == 0) - type_tag = load (is, scalar_constant); - else if (strncmp (ptr, "matrix", 6) == 0) - type_tag = load (is, matrix_constant); - else if (strncmp (ptr, "complex scalar", 14) == 0) - type_tag = load (is, complex_scalar_constant); - else if (strncmp (ptr, "complex matrix", 14) == 0) - type_tag = load (is, complex_matrix_constant); - else if (strncmp (ptr, "string", 6) == 0) - type_tag = load (is, string_constant); - else if (strncmp (ptr, "range", 5) == 0) - type_tag = load (is, range_constant); - else - ::error ("unknown constant type `%s'", tag); - } - else - ::error ("failed to extract keyword specifying value type"); - - delete [] tag; - - return is_global; -} - -tree_constant_rep::constant_type -tree_constant_rep::load (istream& is, tree_constant_rep::constant_type t) -{ - tree_constant_rep::constant_type status = unknown_constant; - - switch (t) - { - case scalar_constant: - is >> scalar; - if (is) - status = scalar_constant; - else - ::error ("failed to load scalar constant"); - break; - case matrix_constant: - { - int nr = 0, nc = 0; - - if (extract_keyword (is, "rows", nr) && nr > 0 - && extract_keyword (is, "columns", nc) && nc > 0) - { - matrix = new Matrix (nr, nc); - is >> *matrix; - if (is) - status = matrix_constant; - else - ::error ("failed to load matrix constant"); - } - else - ::error ("failed to extract number of rows and columns"); - } - break; - case complex_scalar_constant: - complex_scalar = new Complex; - is >> *complex_scalar; - if (is) - status = complex_scalar_constant; - else - ::error ("failed to load complex scalar constant"); - break; - case complex_matrix_constant: - { - int nr = 0, nc = 0; - - if (extract_keyword (is, "rows", nr) && nr > 0 - && extract_keyword (is, "columns", nc) && nc > 0) - { - complex_matrix = new ComplexMatrix (nr, nc); - is >> *complex_matrix; - if (is) - status = complex_matrix_constant; - else - ::error ("failed to load complex matrix constant"); - } - else - ::error ("failed to extract number of rows and columns"); - } - break; - case string_constant: - { - int len; - if (extract_keyword (is, "length", len) && len > 0) - { - string = new char [len+1]; - is.get (string, len+1, EOF); - if (is) - status = string_constant; - else - ::error ("failed to load string constant"); - } - else - ::error ("failed to extract string length"); - } - break; - case range_constant: - skip_comments (is); - range = new Range (); - is >> *range; - if (is) - status = range_constant; - else - ::error ("failed to load range constant"); - break; - default: - panic_impossible (); - break; - } - return status; -} - double tree_constant_rep::double_value (void) const {
--- a/src/tc-rep.h Tue Aug 09 01:26:57 1994 +0000 +++ b/src/tc-rep.h Tue Aug 09 04:29:10 1994 +0000 @@ -297,8 +297,6 @@ int save (ostream& os, int mark_as_global, int precision); int save_three_d (ostream& os, int parametric); - int load (istream& is); - constant_type load (istream& is, constant_type t); double double_value (void) const; Matrix matrix_value (void) const;
--- a/src/variables.cc Tue Aug 09 01:26:57 1994 +0000 +++ b/src/variables.cc Tue Aug 09 04:29:10 1994 +0000 @@ -78,6 +78,11 @@ // Symbol table for global symbols. symbol_table *global_sym_tab = 0; +// Initialization. + +// Create the initial symbol tables and set the current scope at the +// top level. + void initialize_symbol_tables (void) { @@ -90,10 +95,335 @@ curr_sym_tab = top_level_sym_tab; } +// Attributes of variables and functions. + +// Is this variable a builtin? + +int +is_builtin_variable (const char *name) +{ + symbol_record *sr = global_sym_tab->lookup (name, 0, 0); + return (sr && sr->is_builtin_variable ()); +} + +// Is this a text-style function? + +int +is_text_function_name (const char *s) +{ + symbol_record *sr = global_sym_tab->lookup (s); + return (sr && sr->is_text_function ()); +} + +// Is this function globally in this scope? + +static int +is_globally_visible (const char *name) +{ + symbol_record *sr = curr_sym_tab->lookup (name, 0, 0); + return (sr && sr->is_linked_to_global ()); +} + +// Is this name a valid identifier? + +static int +valid_identifier (char *s) +{ + if (! s || ! (isalnum (*s) || *s == '_')) + return 0; + + while (*++s != '\0') + if (! (isalnum (*s) || *s == '_')) + return 0; + + return 1; +} + +// Is this tree_constant a valid function? + +tree_fvc * +is_valid_function (const tree_constant& arg, char *warn_for, int warn) +{ + tree_fvc *ans = 0; + + if (! arg.is_string_type ()) + { + if (warn) + error ("%s: expecting function name as argument", warn_for); + return ans; + } + + char *fcn_name = arg.string_value (); + + symbol_record *sr = 0; + if (fcn_name) + sr = lookup_by_name (fcn_name); + + if (sr) + ans = sr->def (); + + if (! sr || ! ans || ! sr->is_function ()) + { + if (warn) + error ("%s: the symbol `%s' is not valid as a function", + warn_for, fcn_name); + ans = 0; + } + + return ans; +} + +// Does this function take the right number of arguments? + +int +takes_correct_nargs (tree_fvc *fcn, int expected_nargin, char *warn_for, + int warn) +{ + int nargin = fcn->max_expected_args () - 1; + int e_nargin = expected_nargin - 1; + if (nargin != e_nargin) + { + if (warn) + error ("%s: expecting function to take %d argument%c", + warn_for, e_nargin, (e_nargin == 1 ? "" : "s")); + return 0; + } + return 1; +} + +DEFUN ("is_global", Fis_global, Sis_global, 2, 1, + "is_global (X): return 1 if the string X names a global variable\n\ +otherwise, return 0.") +{ + Octave_object retval = 0.0; + + int nargin = args.length (); + + if (nargin != 2 || ! args(1).is_string_type ()) + { + print_usage ("is_global"); + return retval; + } + + char *name = args(1).string_value (); + + symbol_record *sr = curr_sym_tab->lookup (name, 0, 0); + + retval = (double) (sr && sr->is_linked_to_global ()); + + return retval; +} + +DEFUN ("exist", Fexist, Sexist, 2, 1, + "exist (NAME): check if variable or file exists\n\ +\n\ +return 0 if NAME is undefined, 1 if it is a variable, or 2 if it is\n\ +a function.") +{ + Octave_object retval; + + int nargin = args.length (); + + if (nargin != 2 || ! args(1).is_string_type ()) + { + print_usage ("exist"); + return retval; + } + + char *name = args(1).string_value (); + + symbol_record *sr = curr_sym_tab->lookup (name, 0, 0); + if (! sr) + sr = global_sym_tab->lookup (name, 0, 0); + + retval = 0.0; + + if (sr && sr->is_variable () && sr->is_defined ()) + retval = 1.0; + else if (sr && sr->is_function ()) + retval = 2.0; + else + { + char *path = fcn_file_in_path (name); + if (path) + { + delete [] path; + retval = 2.0; + } + else + { + struct stat buf; + if (stat (name, &buf) == 0 && S_ISREG (buf.st_mode)) + retval = 2.0; + } + } + + return retval; +} + +// XXX FIXME XXX -- should these really be here? + +static char * +octave_home (void) +{ +#ifdef RUN_IN_PLACE + static char *home = OCTAVE_HOME; + return home; +#else + static char *home = 0; + delete [] home; + char *oh = getenv ("OCTAVE_HOME"); + if (oh) + home = strsave (oh); + else + home = strsave (OCTAVE_HOME); + return home; +#endif +} + +static char * +octave_info_dir (void) +{ +#ifdef RUN_IN_PLACE + static char *oi = OCTAVE_INFO_DIR; + return oi; +#else + static char *oi = 0; + delete [] oi; + char *oh = octave_home (); + oi = strconcat (oh, "/info/"); + return oi; +#endif +} + +static char * +default_pager (void) +{ + static char *pager_binary = 0; + delete [] pager_binary; + char *pgr = getenv ("PAGER"); + if (pgr) + pager_binary = strsave (pgr); + else +#ifdef DEFAULT_PAGER + pager_binary = strsave (DEFAULT_PAGER); +#else + pager_binary = strsave (""); +#endif + + return pager_binary; +} + +char * +octave_lib_dir (void) +{ +#ifdef RUN_IN_PLACE + static char *ol = OCTAVE_LIB_DIR; + return ol; +#else + static char *ol = 0; + delete [] ol; + char *oh = octave_home (); + char *tmp = strconcat (oh, "/lib/octave/"); + ol = strconcat (tmp, version_string); + delete [] tmp; + return ol; +#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. + +char * +default_path (void) +{ + static char *pathstring = 0; + delete [] pathstring; + + static char *std_path = 0; + delete [] std_path; + + char *libdir = octave_lib_dir (); + + std_path = strconcat (".:", libdir); + + char *oct_path = getenv ("OCTAVE_PATH"); + + if (oct_path) + { + pathstring = strsave (oct_path); + + if (pathstring[0] == ':') + { + char *tmp = pathstring; + pathstring = strconcat (std_path, pathstring); + delete [] tmp; + } + + int tmp_len = strlen (pathstring); + if (pathstring[tmp_len-1] == ':') + { + char *tmp = pathstring; + pathstring = strconcat (pathstring, std_path); + delete [] tmp; + } + } + else + pathstring = strsave (std_path); + + return pathstring; +} + +char * +default_info_file (void) +{ + static char *info_file_string = 0; + delete [] info_file_string; + char *oct_info_file = getenv ("OCTAVE_INFO_FILE"); + if (oct_info_file) + info_file_string = strsave (oct_info_file); + else + { + char *infodir = octave_info_dir (); + info_file_string = strconcat (infodir, "/octave.info"); + } + return info_file_string; +} + +char * +default_editor (void) +{ + static char *editor_string = 0; + delete [] editor_string; + char *env_editor = getenv ("EDITOR"); + if (env_editor && *env_editor) + editor_string = strsave (env_editor); + else + editor_string = strsave ("vi"); + return editor_string; +} + +char * +get_site_defaults (void) +{ + static char *sd = 0; + delete [] sd; + char *libdir = octave_lib_dir (); + sd = strconcat (libdir, "/octaverc"); + return sd; +} + +// Functions for looking up variables and functions. + // Is there a corresponding function file that is newer than the // symbol definition? -int +static int symbol_out_of_date (symbol_record *sr) { int ignore = user_pref.ignore_function_time_stamp; @@ -253,7 +583,7 @@ return script_file_executed; } -int +static int load_fcn_from_file (symbol_record *sym_rec, int exec_script) { int script_file_executed = 0; @@ -304,22 +634,16 @@ 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); - } + 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); - } + 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); - } + script_file_executed = load_fcn_from_file (sym_rec, exec_script); } } @@ -342,165 +666,7 @@ return sym_rec; } -void -document_symbol (const char *name, const char *help) -{ - if (is_builtin_variable (name)) - { - error ("sorry, can't redefine help for builtin variables"); - } - else - { - symbol_record *sym_rec = curr_sym_tab->lookup (name, 0); - if (sym_rec) - sym_rec->document (help); - else - error ("document: no such symbol `%s'", name); - } -} - -void -install_builtin_mapper (builtin_mapper_function *mf) -{ - symbol_record *sym_rec = global_sym_tab->lookup (mf->name, 1); - sym_rec->unprotect (); - - Mapper_fcn mfcn; - mfcn.can_return_complex_for_real_arg = mf->can_return_complex_for_real_arg; - mfcn.lower_limit = mf->lower_limit; - mfcn.upper_limit = mf->upper_limit; - mfcn.d_d_mapper = mf->d_d_mapper; - mfcn.d_c_mapper = mf->d_c_mapper; - mfcn.c_c_mapper = mf->c_c_mapper; - - tree_builtin *def = new tree_builtin (2, 1, mfcn, mf->name); - - sym_rec->define (def); - - sym_rec->document (mf->help_string); - sym_rec->make_eternal (); - sym_rec->protect (); -} - -void -install_builtin_function (builtin_function *f) -{ - symbol_record *sym_rec = global_sym_tab->lookup (f->name, 1); - sym_rec->unprotect (); - - tree_builtin *def = new tree_builtin (f->nargin_max, f->nargout_max, - f->fcn, f->name); - - sym_rec->define (def, f->is_text_fcn); - - sym_rec->document (f->help_string); - sym_rec->make_eternal (); - sym_rec->protect (); -} - -void -install_builtin_variable (builtin_variable *v) -{ - if (v->install_as_function) - install_builtin_variable_as_function (v->name, v->value, v->protect, - v->eternal, v->help_string); - else - bind_builtin_variable (v->name, v->value, v->protect, v->eternal, - v->sv_function, v->help_string); -} - -void -install_builtin_variable_as_function (const char *name, tree_constant *val, - int protect, int eternal, - const char *help) -{ - symbol_record *sym_rec = global_sym_tab->lookup (name, 1); - sym_rec->unprotect (); - - const char *tmp_help = help; - if (! help) - tmp_help = sym_rec->help (); - - sym_rec->define_as_fcn (val); - - sym_rec->document (tmp_help); - - if (protect) - sym_rec->protect (); - - if (eternal) - sym_rec->make_eternal (); -} - -void -alias_builtin (const char *alias, const char *name) -{ - symbol_record *sr_name = global_sym_tab->lookup (name, 0, 0); - if (! sr_name) - panic ("can't alias to undefined name!"); - - symbol_record *sr_alias = global_sym_tab->lookup (alias, 1, 0); - - if (sr_alias) - sr_alias->alias (sr_name); - else - panic_impossible (); -} - -void -bind_nargin_and_nargout (symbol_table *sym_tab, int nargin, int nargout) -{ - tree_constant *tmp; - symbol_record *sr; - - sr = sym_tab->lookup ("nargin", 1, 0); - sr->unprotect (); - tmp = new tree_constant (nargin-1); - sr->define (tmp); - sr->protect (); - - sr = sym_tab->lookup ("nargout", 1, 0); - sr->unprotect (); - tmp = new tree_constant (nargout); - sr->define (tmp); - sr->protect (); -} - -// 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, - const char *help) -{ - symbol_record *sr = global_sym_tab->lookup (varname, 1, 0); - -// It is a programming error for a builtin symbol to be missing. -// Besides, we just inserted it, so it must be there. - - assert (sr); - - sr->unprotect (); - -// Must do this before define, since define will call the special -// variable function only if it knows about it, and it needs to, so -// that user prefs can be properly initialized. - - if (sv_fcn) - sr->set_sv_function (sv_fcn); - - sr->define_builtin_var (val); - - if (protect) - sr->protect (); - - if (eternal) - sr->make_eternal (); - - if (help) - sr->document (help); -} +// Variable values. // Look for the given name in the global symbol table. If it refers // to a string, return a new copy. If not, return 0; @@ -564,6 +730,8 @@ return status; } +// Global stuff and links to builtin variables and functions. + // 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. @@ -655,28 +823,7 @@ } } -DEFUN ("is_global", Fis_global, Sis_global, 2, 1, - "is_global (X): return 1 if the string X names a global variable\n\ -otherwise, return 0.") -{ - Octave_object retval = 0.0; - - int nargin = args.length (); - - if (nargin != 2 || ! args(1).is_string_type ()) - { - print_usage ("is_global"); - return retval; - } - - char *name = args(1).string_value (); - - symbol_record *sr = curr_sym_tab->lookup (name, 0, 0); - - retval = (double) (sr && sr->is_linked_to_global ()); - - return retval; -} +// Loading variables from files. // Extract a keyword and its value from a file. Input should look // something like: @@ -686,7 +833,7 @@ // Returns a pointer to new storage. The caller is responsible for // deleting it. -char * +static char * extract_keyword (istream& is, char *keyword) { ostrstream buf; @@ -733,7 +880,7 @@ return retval; } -int +static int extract_keyword (istream& is, char *keyword, int& value) { ostrstream buf; @@ -781,7 +928,7 @@ // Skip trailing white space and -void +static void skip_comments (istream& is) { char c = '\0'; @@ -803,555 +950,150 @@ } } -// Is `s' a valid identifier? - -int -valid_identifier (char *s) +static tree_constant +load_variable (istream& is, tree_constant_rep::constant_type t) { - if (! s || ! (isalnum (*s) || *s == '_')) - return 0; - - while (*++s != '\0') - if (! (isalnum (*s) || *s == '_')) - return 0; + tree_constant retval; - return 1; -} - -DEFUN ("exist", Fexist, Sexist, 2, 1, - "exist (NAME): check if variable or file exists\n\ -\n\ -return 0 if NAME is undefined, 1 if it is a variable, or 2 if it is\n\ -a function.") -{ - Octave_object retval; - - int nargin = args.length (); - - if (nargin != 2 || ! args(1).is_string_type ()) + switch (t) { - print_usage ("exist"); - return retval; - } - - char *name = args(1).string_value (); + case tree_constant_rep::scalar_constant: + { + double tmp; + is >> tmp; + if (is) + retval = tmp; + else + error ("failed to load scalar constant"); + } + break; + case tree_constant_rep::matrix_constant: + { + int nr = 0, nc = 0; - symbol_record *sr = curr_sym_tab->lookup (name, 0, 0); - if (! sr) - sr = global_sym_tab->lookup (name, 0, 0); - - retval = 0.0; + if (extract_keyword (is, "rows", nr) && nr > 0 + && extract_keyword (is, "columns", nc) && nc > 0) + { + Matrix tmp (nr, nc); + is >> tmp; + if (is) + retval = tmp; + else + error ("failed to load matrix constant"); + } + else + error ("failed to extract number of rows and columns"); + } + break; + case tree_constant_rep::complex_scalar_constant: + { + Complex tmp; + is >> tmp; + if (is) + retval = tmp; + else + error ("failed to load complex scalar constant"); + } + break; + case tree_constant_rep::complex_matrix_constant: + { + int nr = 0, nc = 0; - if (sr && sr->is_variable () && sr->is_defined ()) - retval = 1.0; - else if (sr && sr->is_function ()) - retval = 2.0; - else - { - char *path = fcn_file_in_path (name); - if (path) - { - delete [] path; - retval = 2.0; - } - else - { - struct stat buf; - if (stat (name, &buf) == 0 && S_ISREG (buf.st_mode)) - retval = 2.0; - } + if (extract_keyword (is, "rows", nr) && nr > 0 + && extract_keyword (is, "columns", nc) && nc > 0) + { + ComplexMatrix tmp (nr, nc); + is >> tmp; + if (is) + retval = tmp; + else + error ("failed to load complex matrix constant"); + } + else + error ("failed to extract number of rows and columns"); + } + break; + case tree_constant_rep::string_constant: + { + int len; + if (extract_keyword (is, "length", len) && len > 0) + { + char *tmp = new char [len+1]; + is.get (tmp, len+1, EOF); + if (is) + retval = tmp; + else + error ("failed to load string constant"); + } + else + error ("failed to extract string length"); + } + break; + case tree_constant_rep::range_constant: + { + skip_comments (is); // # base, limit, range comment added by save(). + Range tmp; + is >> tmp; + if (is) + retval = tmp; + else + error ("failed to load range constant"); + } + break; + default: + panic_impossible (); + break; } return retval; } -// Is this variable a builtin? - -int -is_builtin_variable (const char *name) -{ - symbol_record *sr = global_sym_tab->lookup (name, 0, 0); - return (sr && sr->is_builtin_variable ()); -} - -// Is this tree_constant a valid function? - -tree_fvc * -is_valid_function (const tree_constant& arg, char *warn_for, int warn) +static tree_constant +load_variable (istream& is, int& is_global) { - tree_fvc *ans = 0; - - if (! arg.is_string_type ()) - { - if (warn) - error ("%s: expecting function name as argument", warn_for); - return ans; - } - - char *fcn_name = arg.string_value (); - symbol_record *sr = global_sym_tab->lookup (fcn_name, 0, 0); - - if (sr && symbol_out_of_date (sr)) - load_fcn_from_file (sr, 0); - else - { - sr = global_sym_tab->lookup (fcn_name, 1, 0); - load_fcn_from_file (sr, 0); - } - - ans = sr->def (); - if (! ans || ! sr->is_function ()) - { - if (warn) - error ("%s: the symbol `%s' is not valid as a function", - warn_for, fcn_name); - ans = 0; - } - - return ans; -} - -// Does this function take the right number of arguments? - -int -takes_correct_nargs (tree_fvc *fcn, int expected_nargin, char *warn_for, - int warn) -{ - int nargin = fcn->max_expected_args () - 1; - int e_nargin = expected_nargin - 1; - if (nargin != e_nargin) - { - if (warn) - error ("%s: expecting function to take %d argument%c", - warn_for, e_nargin, (e_nargin == 1 ? "" : "s")); - return 0; - } - return 1; -} - -// It's not likely that this does the right thing now. XXX FIXME XXX - -char ** -make_name_list (void) -{ - int key_len = 0; - int glb_len = 0; - int top_len = 0; - int lcl_len = 0; - int ffl_len = 0; - - char **key = 0; - char **glb = 0; - char **top = 0; - char **lcl = 0; - char **ffl = 0; - -// Each of these functions returns a new vector of pointers to new -// strings. - - key = names (keyword_help (), key_len); - glb = global_sym_tab->list (glb_len); - top = top_level_sym_tab->list (top_len); - if (top_level_sym_tab != curr_sym_tab) - lcl = curr_sym_tab->list (lcl_len); - ffl = get_fcn_file_names (ffl_len, 1); - - int total_len = key_len + glb_len + top_len + lcl_len + ffl_len; + tree_constant retval; - char **list = new char * [total_len+1]; - -// Put all the symbols in one big list. Only copy pointers, not the -// strings they point to, then only delete the original array of -// pointers, and not the strings they point to. - - int j = 0; - int i = 0; - for (i = 0; i < key_len; i++) - list[j++] = key[i]; - - for (i = 0; i < glb_len; i++) - list[j++] = glb[i]; - - for (i = 0; i < top_len; i++) - list[j++] = top[i]; - - for (i = 0; i < lcl_len; i++) - list[j++] = lcl[i]; - - for (i = 0; i < ffl_len; i++) - list[j++] = ffl[i]; - - list[j] = 0; - - delete [] key; - delete [] glb; - delete [] top; - delete [] lcl; - delete [] ffl; - - return list; -} - -int -is_text_function_name (const char *s) -{ - symbol_record *sr = global_sym_tab->lookup (s); - return (sr && sr->is_text_function ()); -} - -void -install_builtin_variables (void) -{ -// XXX FIXME XX -- these should probably be moved to where they -// logically belong instead of being all grouped here. + is_global = 0; - DEFVAR ("EDITOR", SBV_EDITOR, editor, 0, 0, 1, sv_editor, - "name of the editor to be invoked by the edit_history command"); - - DEFVAR ("I", SBV_I, Complex (0.0, 1.0), 0, 1, 1, 0, - "sqrt (-1)"); - - DEFVAR ("Inf", SBV_Inf, octave_Inf, 0, 1, 1, 0, - "infinity"); - - DEFVAR ("INFO_FILE", SBV_INFO_FILE, info_file, 0, 0, 1, sv_info_file, - "name of the Octave info file"); - - DEFVAR ("J", SBV_J, Complex (0.0, 1.0), 0, 1, 1, 0, - "sqrt (-1)"); - - #if defined (HAVE_ISNAN) - DEFVAR ("NaN", SBV_NaN, octave_NaN, 0, 1, 1, 0, - "not a number"); - #endif - - DEFVAR ("LOADPATH", SBV_LOADPATH, load_path, 0, 0, 1, sv_loadpath, - "colon separated list of directories to search for scripts"); +// Look for type keyword - DEFVAR ("PAGER", SBV_PAGER, default_pager (), 0, 0, 1, sv_pager_binary, - "path to pager binary"); - - DEFVAR ("PS1", SBV_PS1, "\\s:\\#> ", 0, 0, 1, sv_ps1, - "primary prompt string"); - - DEFVAR ("PS2", SBV_PS2, "> ", 0, 0, 1, sv_ps2, - "secondary prompt string"); - - DEFVAR ("PWD", SBV_PWD, get_working_directory ("initialize_globals"), - 0, 1, 1, sv_pwd, - "current working directory"); - - DEFVAR ("SEEK_SET", SBV_SEEK_SET, 0.0, 0, 1, 1, 0, - "used with fseek to position file relative to the beginning"); - - DEFVAR ("SEEK_CUR", SBV_SEEK_CUR, 1.0, 0, 1, 1, 0, - "used with fseek to position file relative to the current position"); - - DEFVAR ("SEEK_END", SBV_SEEK_END, 2.0, 0, 1, 1, 0, - "used with fseek to position file relative to the end"); - - DEFVAR ("ans", SBV_ans, , 0, 0, 1, 0, - ""); + char *tag = extract_keyword (is, "type"); - DEFVAR ("commas_in_literal_matrix", SBV_commas_in_literal_matrix, "", - 0, 0, 1, commas_in_literal_matrix, - "control auto-insertion of commas in literal matrices"); - - DEFVAR ("do_fortran_indexing", SBV_do_fortran_indexing, "false", 0, 0, - 1, do_fortran_indexing, - "allow single indices for matrices"); - - DEFVAR ("empty_list_elements_ok", SBV_empty_list_elements_ok, "warn", - 0, 0, 1, empty_list_elements_ok, - "ignore the empty element in expressions like `a = [[], 1]'"); - - DEFVAR ("eps", SBV_eps, DBL_EPSILON, 0, 1, 1, 0, - "machine precision"); - - DEFVAR ("gnuplot_binary", SBV_gnuplot_binary, "gnuplot", 0, 0, 1, - sv_gnuplot_binary, - "path to gnuplot binary"); - - DEFVAR ("i", SBV_i, Complex (0.0, 1.0), 1, 1, 1, 0, - "sqrt (-1)"); - - DEFVAR ("ignore_function_time_stamp", SBV_ignore_function_time_stamp, - "system", 0, 0, 1, - ignore_function_time_stamp, - "don't check to see if function files have changed since they were\n\ - last compiled. Possible values are \"system\" and \"all\""); - - DEFVAR ("implicit_str_to_num_ok", SBV_implicit_str_to_num_ok, "false", - 0, 0, 1, implicit_str_to_num_ok, - "allow implicit string to number conversion"); - - DEFVAR ("inf", SBV_inf, octave_Inf, 0, 1, 1, 0, - "infinity"); - - DEFVAR ("j", SBV_j, Complex (0.0, 1.0), 1, 1, 1, 0, - "sqrt (-1)"); - - #if defined (HAVE_ISNAN) - DEFVAR ("nan", SBV_nan, octave_NaN, 0, 1, 1, 0, - "not a number"); - #endif - - DEFVAR ("ok_to_lose_imaginary_part", SBV_ok_to_lose_imaginary_part, - "warn", 0, 0, 1, ok_to_lose_imaginary_part, - "silently convert from complex to real by dropping imaginary part"); - - DEFVAR ("output_max_field_width", SBV_output_max_field_width, 10.0, 0, - 0, 1, set_output_max_field_width, - "maximum width of an output field for numeric output"); - - DEFVAR ("output_precision", SBV_output_precision, 5.0, 0, 0, 1, - set_output_precision, - "number of significant figures to display for numeric output"); - - DEFVAR ("page_screen_output", SBV_page_screen_output, "true", 0, 0, 1, - page_screen_output, - "if possible, send output intended for the screen through the pager"); - - DEFVAR ("pi", SBV_pi, 4.0 * atan (1.0), 0, 1, 1, 0, - "ratio of the circumference of a circle to its diameter"); - - DEFVAR ("prefer_column_vectors", SBV_prefer_column_vectors, "true", 0, - 0, 1, prefer_column_vectors, - "prefer column/row vectors"); - - DEFVAR ("prefer_zero_one_indexing", SBV_prefer_zero_one_indexing, - "false", 0, 0, 1, prefer_zero_one_indexing, - "when there is a conflict, prefer zero-one style indexing"); - - DEFVAR ("print_answer_id_name", SBV_print_answer_id_name, "true", 0, - 0, 1, print_answer_id_name, - "set output style to print `var_name = ...'"); - - DEFVAR ("print_empty_dimensions", SBV_print_empty_dimensions, "true", - 0, 0, 1, print_empty_dimensions, - "also print dimensions of empty matrices"); - - DEFVAR ("propagate_empty_matrices", SBV_propagate_empty_matrices, - "true", 0, 0, 1, propagate_empty_matrices, - "operations on empty matrices return an empty matrix, not an error"); - - DEFVAR ("resize_on_range_error", SBV_resize_on_range_error, "true", 0, - 0, 1, resize_on_range_error, - "enlarge matrices on assignment"); - - DEFVAR ("return_last_computed_value", SBV_return_last_computed_value, - "false", 0, 0, 1, - return_last_computed_value, - "if a function does not return any values explicitly, return the\n\ - last computed value"); + if (tag && *tag) + { + char *ptr = strchr (tag, ' '); + if (ptr) + { + *ptr = '\0'; + is_global = (strncmp (tag, "global", 6) == 0); + *ptr = ' '; + if (is_global) + ptr++; + else + ptr = tag; + } + else + ptr = tag; - DEFVAR ("save_precision", SBV_save_precision, 17.0, 0, 0, 1, - set_save_precision, - "number of significant figures kept by the ASCII save command"); - - DEFVAR ("silent_functions", SBV_silent_functions, "false", 0, 0, 1, - silent_functions, - "suppress printing results in called functions"); - - DEFVAR ("split_long_rows", SBV_split_long_rows, "true", 0, 0, 1, - split_long_rows, - "split long matrix rows instead of wrapping"); - - DEFVAR ("stdin", SBV_stdin, 0.0, 0, 1, 1, 0, - "file number of the standard input stream"); - - DEFVAR ("stdout", SBV_stdout, 1.0, 0, 1, 1, 0, - "file number of the standard output stream"); - - DEFVAR ("stderr", SBV_stderr, 2.0, 0, 1, 1, 0, - "file number of the standard error stream"); - - DEFVAR ("treat_neg_dim_as_zero", SBV_treat_neg_dim_as_zero, "false", - 0, 0, 1, treat_neg_dim_as_zero, - "convert negative dimensions to zero"); - - DEFVAR ("warn_assign_as_truth_value", SBV_warn_assign_as_truth_value, - "true", 0, 0, 1, - warn_assign_as_truth_value, - "produce warning for assignments used as truth values"); - - DEFVAR ("warn_comma_in_global_decl", SBV_warn_comma_in_global_decl, - "true", 0, 0, 1, warn_comma_in_global_decl, - "produce warning for commas in global declarations"); - - DEFVAR ("warn_divide_by_zero", SBV_warn_divide_by_zero, "true", 0, 0, - 1, warn_divide_by_zero, - "on IEEE machines, allow divide by zero errors to be suppressed"); -} - -// List variable names. - -static void -print_symbol_info_line (ostrstream& output_buf, const symbol_record_info& s) -{ - output_buf << (s.is_read_only () ? " -" : " w"); - output_buf << (s.is_eternal () ? "- " : "d "); -#if 0 - output_buf << (s.hides_fcn () ? "f" : (s.hides_builtin () ? "F" : "-")); -#endif - output_buf.form (" %-16s", s.type_as_string ()); - if (s.is_function ()) - output_buf << " - -"; - else - { - output_buf.form ("%7d", s.rows ()); - output_buf.form ("%7d", s.columns ()); - } - output_buf << " " << s.name () << "\n"; -} - -static void -print_long_listing (ostrstream& output_buf, symbol_record_info *s) -{ - if (! s) - return; - - symbol_record_info *ptr = s; - while (ptr->is_defined ()) - { - print_symbol_info_line (output_buf, *ptr); - ptr++; - } -} - -static int -maybe_list (const char *header, ostrstream& output_buf, - int show_verbose, symbol_table *sym_tab, unsigned type, - unsigned scope) -{ - int count; - int status = 0; - if (show_verbose) - { - symbol_record_info *symbols; - symbols = sym_tab->long_list (count, 1, type, scope); - if (symbols && count > 0) - { - output_buf << "\n" << header << "\n\n" - << "prot type rows cols name\n" - << "==== ==== ==== ==== ====\n"; - - print_long_listing (output_buf, symbols); - status = 1; - } - delete [] symbols; + if (strncmp (ptr, "scalar", 6) == 0) + retval = load_variable (is, tree_constant_rep::scalar_constant); + else if (strncmp (ptr, "matrix", 6) == 0) + retval = load_variable (is, tree_constant_rep::matrix_constant); + else if (strncmp (ptr, "complex scalar", 14) == 0) + retval = load_variable (is, tree_constant_rep::complex_scalar_constant); + else if (strncmp (ptr, "complex matrix", 14) == 0) + retval = load_variable (is, tree_constant_rep::complex_matrix_constant); + else if (strncmp (ptr, "string", 6) == 0) + retval = load_variable (is, tree_constant_rep::string_constant); + else if (strncmp (ptr, "range", 5) == 0) + retval = load_variable (is, tree_constant_rep::range_constant); + else + error ("unknown constant type `%s'", tag); } else - { - char **symbols = sym_tab->list (count, 1, type, scope); - if (symbols && count > 0) - { - output_buf << "\n" << header << "\n\n"; - list_in_columns (output_buf, symbols); - status = 1; - } - delete [] symbols; - } - return status; -} - -DEFUN_TEXT ("clear", Fclear, Sclear, -1, 1, - "clear [name ...]\n\ -\n\ -clear symbol(s) matching a list of globbing patterns\n\ -if no arguments are given, clear all user-defined variables and functions") -{ - Octave_object retval; - - DEFINE_ARGV("clear"); - -// Always clear the local table, but don't clear currently compiled -// functions unless we are at the top level. (Allowing that to happen -// inside functions would result in pretty odd behavior...) - - int clear_user_functions = (curr_sym_tab == top_level_sym_tab); - - if (argc == 1) - { - curr_sym_tab->clear (); - global_sym_tab->clear (clear_user_functions); - } - else - { - int lcount; - char **lvars = curr_sym_tab->list (lcount, 0, - symbol_def::USER_VARIABLE, - SYMTAB_LOCAL_SCOPE); - int gcount; - char **gvars = curr_sym_tab->list (gcount, 0, - symbol_def::USER_VARIABLE, - SYMTAB_GLOBAL_SCOPE); - int fcount; - char **fcns = curr_sym_tab->list (fcount, 0, - symbol_def::USER_FUNCTION, - SYMTAB_ALL_SCOPES); + error ("failed to extract keyword specifying value type"); - while (--argc > 0) - { - argv++; - if (*argv) - { - int i; - for (i = 0; i < lcount; i++) - { - if (fnmatch (*argv, lvars[i], __FNM_FLAGS) == 0) - curr_sym_tab->clear (lvars[i]); - } - - int count; - for (i = 0; i < gcount; i++) - { - if (fnmatch (*argv, gvars[i], __FNM_FLAGS) == 0) - { - count = curr_sym_tab->clear (gvars[i]); - if (count > 0) - global_sym_tab->clear (gvars[i], clear_user_functions); - } - } - - for (i = 0; i < fcount; i++) - { - if (fnmatch (*argv, fcns[i], __FNM_FLAGS) == 0) - { - count = curr_sym_tab->clear (fcns[i]); - if (count > 0) - global_sym_tab->clear (fcns[i], clear_user_functions); - } - } - } - } - - delete [] lvars; - delete [] gvars; - delete [] fcns; - - } - - DELETE_ARGV; - - return retval; -} - -DEFUN_TEXT ("document", Fdocument, Sdocument, -1, 1, - "document symbol string ...\n\ -\n\ -Associate a cryptic message with a variable name.") -{ - Octave_object retval; - - DEFINE_ARGV("document"); - - if (argc == 3) - document_symbol (argv[1], argv[2]); - else - print_usage ("document"); - - DELETE_ARGV; + delete [] tag; return retval; } @@ -1378,8 +1120,8 @@ // Try to read data for this name. - tree_constant tc; - int global = tc.load (is); + int global; + tree_constant tc = load_variable (is, global); if (tc.const_type () == tree_constant_rep::unknown_constant) { @@ -1624,13 +1366,6 @@ return 0; } -static int -is_globally_visible (const char *name) -{ - symbol_record *sr = curr_sym_tab->lookup (name, 0, 0); - return (sr && sr->is_linked_to_global ()); -} - DEFUN_TEXT ("save", Fsave, Ssave, -1, 1, "save file [var ...]\n\ \n\ @@ -1740,6 +1475,176 @@ return retval; } +// Help stuff. + +// It's not likely that this does the right thing now. XXX FIXME XXX + +char ** +make_name_list (void) +{ + int key_len = 0; + int glb_len = 0; + int top_len = 0; + int lcl_len = 0; + int ffl_len = 0; + + char **key = 0; + char **glb = 0; + char **top = 0; + char **lcl = 0; + char **ffl = 0; + +// Each of these functions returns a new vector of pointers to new +// strings. + + key = names (keyword_help (), key_len); + glb = global_sym_tab->list (glb_len); + top = top_level_sym_tab->list (top_len); + if (top_level_sym_tab != curr_sym_tab) + lcl = curr_sym_tab->list (lcl_len); + ffl = get_fcn_file_names (ffl_len, 1); + + int total_len = key_len + glb_len + top_len + lcl_len + ffl_len; + + char **list = new char * [total_len+1]; + +// Put all the symbols in one big list. Only copy pointers, not the +// strings they point to, then only delete the original array of +// pointers, and not the strings they point to. + + int j = 0; + int i = 0; + for (i = 0; i < key_len; i++) + list[j++] = key[i]; + + for (i = 0; i < glb_len; i++) + list[j++] = glb[i]; + + for (i = 0; i < top_len; i++) + list[j++] = top[i]; + + for (i = 0; i < lcl_len; i++) + list[j++] = lcl[i]; + + for (i = 0; i < ffl_len; i++) + list[j++] = ffl[i]; + + list[j] = 0; + + delete [] key; + delete [] glb; + delete [] top; + delete [] lcl; + delete [] ffl; + + return list; +} + +// List variable names. + +static void +print_symbol_info_line (ostrstream& output_buf, const symbol_record_info& s) +{ + output_buf << (s.is_read_only () ? " -" : " w"); + output_buf << (s.is_eternal () ? "- " : "d "); +#if 0 + output_buf << (s.hides_fcn () ? "f" : (s.hides_builtin () ? "F" : "-")); +#endif + output_buf.form (" %-16s", s.type_as_string ()); + if (s.is_function ()) + output_buf << " - -"; + else + { + output_buf.form ("%7d", s.rows ()); + output_buf.form ("%7d", s.columns ()); + } + output_buf << " " << s.name () << "\n"; +} + +static void +print_long_listing (ostrstream& output_buf, symbol_record_info *s) +{ + if (! s) + return; + + symbol_record_info *ptr = s; + while (ptr->is_defined ()) + { + print_symbol_info_line (output_buf, *ptr); + ptr++; + } +} + +static int +maybe_list (const char *header, ostrstream& output_buf, + int show_verbose, symbol_table *sym_tab, unsigned type, + unsigned scope) +{ + int count; + int status = 0; + if (show_verbose) + { + symbol_record_info *symbols; + symbols = sym_tab->long_list (count, 1, type, scope); + if (symbols && count > 0) + { + output_buf << "\n" << header << "\n\n" + << "prot type rows cols name\n" + << "==== ==== ==== ==== ====\n"; + + print_long_listing (output_buf, symbols); + status = 1; + } + delete [] symbols; + } + else + { + char **symbols = sym_tab->list (count, 1, type, scope); + if (symbols && count > 0) + { + output_buf << "\n" << header << "\n\n"; + list_in_columns (output_buf, symbols); + status = 1; + } + delete [] symbols; + } + return status; +} + +DEFUN_TEXT ("document", Fdocument, Sdocument, -1, 1, + "document symbol string ...\n\ +\n\ +Associate a cryptic message with a variable name.") +{ + Octave_object retval; + + DEFINE_ARGV("document"); + + if (argc == 3) + { + char *name = argv[1]; + char *help = argv[2]; + + if (is_builtin_variable (name)) + error ("sorry, can't redefine help for builtin variables"); + else + { + symbol_record *sym_rec = curr_sym_tab->lookup (name, 0); + + if (sym_rec) + sym_rec->document (help); + else + error ("document: no such symbol `%s'", name); + } + } + else + print_usage ("document"); + + DELETE_ARGV; + + return retval; +} + // XXX FIXME XXX -- this should take a list of regular expressions // naming the variables to look for. @@ -1884,161 +1789,423 @@ return retval; } -// XXX FIXME XXX -- should these really be here? +// Install variables and functions in the symbol tables. -char * -octave_home (void) +void +install_builtin_mapper (builtin_mapper_function *mf) { -#ifdef RUN_IN_PLACE - static char *home = OCTAVE_HOME; - return home; -#else - static char *home = 0; - delete [] home; - char *oh = getenv ("OCTAVE_HOME"); - if (oh) - home = strsave (oh); + symbol_record *sym_rec = global_sym_tab->lookup (mf->name, 1); + sym_rec->unprotect (); + + Mapper_fcn mfcn; + mfcn.can_return_complex_for_real_arg = mf->can_return_complex_for_real_arg; + mfcn.lower_limit = mf->lower_limit; + mfcn.upper_limit = mf->upper_limit; + mfcn.d_d_mapper = mf->d_d_mapper; + mfcn.d_c_mapper = mf->d_c_mapper; + mfcn.c_c_mapper = mf->c_c_mapper; + + tree_builtin *def = new tree_builtin (2, 1, mfcn, mf->name); + + sym_rec->define (def); + + sym_rec->document (mf->help_string); + sym_rec->make_eternal (); + sym_rec->protect (); +} + +void +install_builtin_function (builtin_function *f) +{ + symbol_record *sym_rec = global_sym_tab->lookup (f->name, 1); + sym_rec->unprotect (); + + tree_builtin *def = new tree_builtin (f->nargin_max, f->nargout_max, + f->fcn, f->name); + + sym_rec->define (def, f->is_text_fcn); + + sym_rec->document (f->help_string); + sym_rec->make_eternal (); + sym_rec->protect (); +} + +void +install_builtin_variable (builtin_variable *v) +{ + if (v->install_as_function) + install_builtin_variable_as_function (v->name, v->value, v->protect, + v->eternal, v->help_string); else - home = strsave (OCTAVE_HOME); - return home; -#endif + bind_builtin_variable (v->name, v->value, v->protect, v->eternal, + v->sv_function, v->help_string); } -char * -octave_lib_dir (void) +void +install_builtin_variable_as_function (const char *name, tree_constant *val, + int protect, int eternal, + const char *help) { -#ifdef RUN_IN_PLACE - static char *ol = OCTAVE_LIB_DIR; - return ol; -#else - static char *ol = 0; - delete [] ol; - char *oh = octave_home (); - char *tmp = strconcat (oh, "/lib/octave/"); - ol = strconcat (tmp, version_string); - delete [] tmp; - return ol; -#endif + symbol_record *sym_rec = global_sym_tab->lookup (name, 1); + sym_rec->unprotect (); + + const char *tmp_help = help; + if (! help) + tmp_help = sym_rec->help (); + + sym_rec->define_as_fcn (val); + + sym_rec->document (tmp_help); + + if (protect) + sym_rec->protect (); + + if (eternal) + sym_rec->make_eternal (); +} + +void +alias_builtin (const char *alias, const char *name) +{ + symbol_record *sr_name = global_sym_tab->lookup (name, 0, 0); + if (! sr_name) + panic ("can't alias to undefined name!"); + + symbol_record *sr_alias = global_sym_tab->lookup (alias, 1, 0); + + if (sr_alias) + sr_alias->alias (sr_name); + else + panic_impossible (); } -char * -octave_info_dir (void) +// Defining variables. + +void +bind_nargin_and_nargout (symbol_table *sym_tab, int nargin, int nargout) { -#ifdef RUN_IN_PLACE - static char *oi = OCTAVE_INFO_DIR; - return oi; -#else - static char *oi = 0; - delete [] oi; - char *oh = octave_home (); - oi = strconcat (oh, "/info/"); - return oi; -#endif + tree_constant *tmp; + symbol_record *sr; + + sr = sym_tab->lookup ("nargin", 1, 0); + sr->unprotect (); + tmp = new tree_constant (nargin-1); + sr->define (tmp); + sr->protect (); + + sr = sym_tab->lookup ("nargout", 1, 0); + sr->unprotect (); + tmp = new tree_constant (nargout); + sr->define (tmp); + sr->protect (); +} + +// Give a global variable a definition. This will insert the symbol +// in the global table if necessary. + +// How is this different than install_builtin_variable? Are both +// functions needed? + +void +bind_builtin_variable (const char *varname, tree_constant *val, + int protect, int eternal, sv_Function sv_fcn, + const char *help) +{ + symbol_record *sr = global_sym_tab->lookup (varname, 1, 0); + +// It is a programming error for a builtin symbol to be missing. +// Besides, we just inserted it, so it must be there. + + assert (sr); + + sr->unprotect (); + +// Must do this before define, since define will call the special +// variable function only if it knows about it, and it needs to, so +// that user prefs can be properly initialized. + + if (sv_fcn) + sr->set_sv_function (sv_fcn); + + sr->define_builtin_var (val); + + if (protect) + sr->protect (); + + if (eternal) + sr->make_eternal (); + + if (help) + sr->document (help); } -// 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) +void +install_builtin_variables (void) { - static char *pathstring = 0; - delete [] pathstring; +// XXX FIXME XX -- these should probably be moved to where they +// logically belong instead of being all grouped here. + + DEFVAR ("EDITOR", SBV_EDITOR, editor, 0, 0, 1, sv_editor, + "name of the editor to be invoked by the edit_history command"); + + DEFVAR ("I", SBV_I, Complex (0.0, 1.0), 0, 1, 1, 0, + "sqrt (-1)"); + + DEFVAR ("Inf", SBV_Inf, octave_Inf, 0, 1, 1, 0, + "infinity"); + + DEFVAR ("INFO_FILE", SBV_INFO_FILE, info_file, 0, 0, 1, sv_info_file, + "name of the Octave info file"); + + DEFVAR ("J", SBV_J, Complex (0.0, 1.0), 0, 1, 1, 0, + "sqrt (-1)"); - static char *std_path = 0; - delete [] std_path; + #if defined (HAVE_ISNAN) + DEFVAR ("NaN", SBV_NaN, octave_NaN, 0, 1, 1, 0, + "not a number"); + #endif + + DEFVAR ("LOADPATH", SBV_LOADPATH, load_path, 0, 0, 1, sv_loadpath, + "colon separated list of directories to search for scripts"); + + DEFVAR ("PAGER", SBV_PAGER, default_pager (), 0, 0, 1, sv_pager_binary, + "path to pager binary"); + + DEFVAR ("PS1", SBV_PS1, "\\s:\\#> ", 0, 0, 1, sv_ps1, + "primary prompt string"); + + DEFVAR ("PS2", SBV_PS2, "> ", 0, 0, 1, sv_ps2, + "secondary prompt string"); + + DEFVAR ("PWD", SBV_PWD, get_working_directory ("initialize_globals"), + 0, 1, 1, sv_pwd, + "current working directory"); + + DEFVAR ("SEEK_SET", SBV_SEEK_SET, 0.0, 0, 1, 1, 0, + "used with fseek to position file relative to the beginning"); - char *libdir = octave_lib_dir (); + DEFVAR ("SEEK_CUR", SBV_SEEK_CUR, 1.0, 0, 1, 1, 0, + "used with fseek to position file relative to the current position"); + + DEFVAR ("SEEK_END", SBV_SEEK_END, 2.0, 0, 1, 1, 0, + "used with fseek to position file relative to the end"); + + DEFVAR ("ans", SBV_ans, , 0, 0, 1, 0, + ""); + + DEFVAR ("commas_in_literal_matrix", SBV_commas_in_literal_matrix, "", + 0, 0, 1, commas_in_literal_matrix, + "control auto-insertion of commas in literal matrices"); + + DEFVAR ("do_fortran_indexing", SBV_do_fortran_indexing, "false", 0, 0, + 1, do_fortran_indexing, + "allow single indices for matrices"); + + DEFVAR ("empty_list_elements_ok", SBV_empty_list_elements_ok, "warn", + 0, 0, 1, empty_list_elements_ok, + "ignore the empty element in expressions like `a = [[], 1]'"); - std_path = strconcat (".:", libdir); + DEFVAR ("eps", SBV_eps, DBL_EPSILON, 0, 1, 1, 0, + "machine precision"); + + DEFVAR ("gnuplot_binary", SBV_gnuplot_binary, "gnuplot", 0, 0, 1, + sv_gnuplot_binary, + "path to gnuplot binary"); + + DEFVAR ("i", SBV_i, Complex (0.0, 1.0), 1, 1, 1, 0, + "sqrt (-1)"); - char *oct_path = getenv ("OCTAVE_PATH"); + DEFVAR ("ignore_function_time_stamp", SBV_ignore_function_time_stamp, + "system", 0, 0, 1, + ignore_function_time_stamp, + "don't check to see if function files have changed since they were\n\ + last compiled. Possible values are \"system\" and \"all\""); + + DEFVAR ("implicit_str_to_num_ok", SBV_implicit_str_to_num_ok, "false", + 0, 0, 1, implicit_str_to_num_ok, + "allow implicit string to number conversion"); + + DEFVAR ("inf", SBV_inf, octave_Inf, 0, 1, 1, 0, + "infinity"); + + DEFVAR ("j", SBV_j, Complex (0.0, 1.0), 1, 1, 1, 0, + "sqrt (-1)"); - if (oct_path) - { - pathstring = strsave (oct_path); + #if defined (HAVE_ISNAN) + DEFVAR ("nan", SBV_nan, octave_NaN, 0, 1, 1, 0, + "not a number"); + #endif + + DEFVAR ("ok_to_lose_imaginary_part", SBV_ok_to_lose_imaginary_part, + "warn", 0, 0, 1, ok_to_lose_imaginary_part, + "silently convert from complex to real by dropping imaginary part"); + + DEFVAR ("output_max_field_width", SBV_output_max_field_width, 10.0, 0, + 0, 1, set_output_max_field_width, + "maximum width of an output field for numeric output"); + + DEFVAR ("output_precision", SBV_output_precision, 5.0, 0, 0, 1, + set_output_precision, + "number of significant figures to display for numeric output"); + + DEFVAR ("page_screen_output", SBV_page_screen_output, "true", 0, 0, 1, + page_screen_output, + "if possible, send output intended for the screen through the pager"); - if (pathstring[0] == ':') - { - char *tmp = pathstring; - pathstring = strconcat (std_path, pathstring); - delete [] tmp; - } + DEFVAR ("pi", SBV_pi, 4.0 * atan (1.0), 0, 1, 1, 0, + "ratio of the circumference of a circle to its diameter"); + + DEFVAR ("prefer_column_vectors", SBV_prefer_column_vectors, "true", 0, + 0, 1, prefer_column_vectors, + "prefer column/row vectors"); + + DEFVAR ("prefer_zero_one_indexing", SBV_prefer_zero_one_indexing, + "false", 0, 0, 1, prefer_zero_one_indexing, + "when there is a conflict, prefer zero-one style indexing"); + + DEFVAR ("print_answer_id_name", SBV_print_answer_id_name, "true", 0, + 0, 1, print_answer_id_name, + "set output style to print `var_name = ...'"); + + DEFVAR ("print_empty_dimensions", SBV_print_empty_dimensions, "true", + 0, 0, 1, print_empty_dimensions, + "also print dimensions of empty matrices"); + + DEFVAR ("propagate_empty_matrices", SBV_propagate_empty_matrices, + "true", 0, 0, 1, propagate_empty_matrices, + "operations on empty matrices return an empty matrix, not an error"); - int tmp_len = strlen (pathstring); - if (pathstring[tmp_len-1] == ':') - { - char *tmp = pathstring; - pathstring = strconcat (pathstring, std_path); - delete [] tmp; - } - } - else - pathstring = strsave (std_path); + DEFVAR ("resize_on_range_error", SBV_resize_on_range_error, "true", 0, + 0, 1, resize_on_range_error, + "enlarge matrices on assignment"); + + DEFVAR ("return_last_computed_value", SBV_return_last_computed_value, + "false", 0, 0, 1, + return_last_computed_value, + "if a function does not return any values explicitly, return the\n\ + last computed value"); + + DEFVAR ("save_precision", SBV_save_precision, 17.0, 0, 0, 1, + set_save_precision, + "number of significant figures kept by the ASCII save command"); + + DEFVAR ("silent_functions", SBV_silent_functions, "false", 0, 0, 1, + silent_functions, + "suppress printing results in called functions"); + + DEFVAR ("split_long_rows", SBV_split_long_rows, "true", 0, 0, 1, + split_long_rows, + "split long matrix rows instead of wrapping"); - return pathstring; + DEFVAR ("stdin", SBV_stdin, 0.0, 0, 1, 1, 0, + "file number of the standard input stream"); + + DEFVAR ("stdout", SBV_stdout, 1.0, 0, 1, 1, 0, + "file number of the standard output stream"); + + DEFVAR ("stderr", SBV_stderr, 2.0, 0, 1, 1, 0, + "file number of the standard error stream"); + + DEFVAR ("treat_neg_dim_as_zero", SBV_treat_neg_dim_as_zero, "false", + 0, 0, 1, treat_neg_dim_as_zero, + "convert negative dimensions to zero"); + + DEFVAR ("warn_assign_as_truth_value", SBV_warn_assign_as_truth_value, + "true", 0, 0, 1, + warn_assign_as_truth_value, + "produce warning for assignments used as truth values"); + + DEFVAR ("warn_comma_in_global_decl", SBV_warn_comma_in_global_decl, + "true", 0, 0, 1, warn_comma_in_global_decl, + "produce warning for commas in global declarations"); + + DEFVAR ("warn_divide_by_zero", SBV_warn_divide_by_zero, "true", 0, 0, + 1, warn_divide_by_zero, + "on IEEE machines, allow divide by zero errors to be suppressed"); } -char * -default_info_file (void) +// Deleting names from the symbol tables. + +DEFUN_TEXT ("clear", Fclear, Sclear, -1, 1, + "clear [name ...]\n\ +\n\ +clear symbol(s) matching a list of globbing patterns\n\ +if no arguments are given, clear all user-defined variables and functions") { - static char *info_file_string = 0; - delete [] info_file_string; - char *oct_info_file = getenv ("OCTAVE_INFO_FILE"); - if (oct_info_file) - info_file_string = strsave (oct_info_file); + Octave_object retval; + + DEFINE_ARGV("clear"); + +// Always clear the local table, but don't clear currently compiled +// functions unless we are at the top level. (Allowing that to happen +// inside functions would result in pretty odd behavior...) + + int clear_user_functions = (curr_sym_tab == top_level_sym_tab); + + if (argc == 1) + { + curr_sym_tab->clear (); + global_sym_tab->clear (clear_user_functions); + } else { - char *infodir = octave_info_dir (); - info_file_string = strconcat (infodir, "/octave.info"); - } - return info_file_string; -} + int lcount; + char **lvars = curr_sym_tab->list (lcount, 0, + symbol_def::USER_VARIABLE, + SYMTAB_LOCAL_SCOPE); + int gcount; + char **gvars = curr_sym_tab->list (gcount, 0, + symbol_def::USER_VARIABLE, + SYMTAB_GLOBAL_SCOPE); + int fcount; + char **fcns = curr_sym_tab->list (fcount, 0, + symbol_def::USER_FUNCTION, + SYMTAB_ALL_SCOPES); -char * -default_editor (void) -{ - static char *editor_string = 0; - delete [] editor_string; - char *env_editor = getenv ("EDITOR"); - if (env_editor && *env_editor) - editor_string = strsave (env_editor); - else - editor_string = strsave ("vi"); - return editor_string; -} + while (--argc > 0) + { + argv++; + if (*argv) + { + int i; + for (i = 0; i < lcount; i++) + { + if (fnmatch (*argv, lvars[i], __FNM_FLAGS) == 0) + curr_sym_tab->clear (lvars[i]); + } -char * -get_site_defaults (void) -{ - static char *sd = 0; - delete [] sd; - char *libdir = octave_lib_dir (); - sd = strconcat (libdir, "/octaverc"); - return sd; -} + int count; + for (i = 0; i < gcount; i++) + { + if (fnmatch (*argv, gvars[i], __FNM_FLAGS) == 0) + { + count = curr_sym_tab->clear (gvars[i]); + if (count > 0) + global_sym_tab->clear (gvars[i], clear_user_functions); + } + } -char * -default_pager (void) -{ - static char *pager_binary = 0; - delete [] pager_binary; - char *pgr = getenv ("PAGER"); - if (pgr) - pager_binary = strsave (pgr); - else -#ifdef DEFAULT_PAGER - pager_binary = strsave (DEFAULT_PAGER); -#else - pager_binary = strsave (""); -#endif + for (i = 0; i < fcount; i++) + { + if (fnmatch (*argv, fcns[i], __FNM_FLAGS) == 0) + { + count = curr_sym_tab->clear (fcns[i]); + if (count > 0) + global_sym_tab->clear (fcns[i], clear_user_functions); + } + } + } + } - return pager_binary; + delete [] lvars; + delete [] gvars; + delete [] fcns; + + } + + DELETE_ARGV; + + return retval; } /*
--- a/src/variables.h Tue Aug 09 01:26:57 1994 +0000 +++ b/src/variables.h Tue Aug 09 04:29:10 1994 +0000 @@ -64,15 +64,27 @@ extern void initialize_symbol_tables (void); -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 char *builtin_string_variable (const char *); +extern int builtin_real_scalar_variable (const char *, double&); + +extern void link_to_global_variable (symbol_record *sr); +extern void link_to_builtin_variable (symbol_record *sr); +extern void link_to_builtin_or_function (symbol_record *sr); + +extern void force_link_to_function (const char *s); + +extern int is_builtin_variable (const char *name); +extern int is_text_function_name (const char *s); + +extern tree_fvc *is_valid_function (const tree_constant&, char *, + int warn = 0); +extern int takes_correct_nargs (tree_fvc *, int, char *, int warn = 0); + +extern char **make_name_list (void); extern void install_builtin_mapper (builtin_mapper_function *mf); @@ -96,39 +108,13 @@ sv_Function f = (sv_Function) 0, const char *help = 0); -extern char *builtin_string_variable (const char *); -extern int builtin_real_scalar_variable (const char *, double&); - -extern void link_to_global_variable (symbol_record *sr); -extern void link_to_builtin_variable (symbol_record *sr); -extern void link_to_builtin_or_function (symbol_record *sr); - -extern void force_link_to_function (const char *s); - -extern char *extract_keyword (istream&, char *); -extern int extract_keyword (istream&, char *, int&); - -extern void skip_comments (istream&); -extern int valid_identifier (char *); -extern int identifier_exists (char *); -extern int is_builtin_variable (const char *name); -extern tree_fvc *is_valid_function (const tree_constant&, char *, - int warn = 0); -extern int takes_correct_nargs (tree_fvc *, int, char *, int warn = 0); -extern char **make_name_list (void); - -extern int is_text_function_name (const char *s); - extern void install_builtin_variables (void); -extern char *octave_home (void); extern char *octave_lib_dir (void); -extern char *octave_info_dir (void); extern char *default_path (void); extern char *default_info_file (void); extern char *default_editor (void); extern char *get_site_defaults (void); -extern char *default_pager (void); // Symbol table for symbols at the top level. extern symbol_table *top_level_sym_tab;