--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/variables.cc	Sun Aug 08 01:13:40 1993 +0000
@@ -0,0 +1,514 @@
+// variables.cc                                              -*- C++ -*-
+/*
+
+Copyright (C) 1992, 1993 John W. Eaton
+
+This file is part of Octave.
+
+Octave is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2, or (at your option) any
+later version.
+
+Octave is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with Octave; see the file COPYING.  If not, write to the Free
+Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+*/
+
+#ifdef __GNUG__
+#pragma implementation
+#endif
+
+#include <sys/types.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <ctype.h>
+#include <iostream.h>
+
+#include "statdefs.h"
+#include "tree-const.h"
+#include "variables.h"
+#include "symtab.h"
+#include "error.h"
+#include "utils.h"
+#include "tree.h"
+
+// Symbol table for symbols at the top level.
+symbol_table *top_level_sym_tab;
+
+// Symbol table for the current scope.
+symbol_table *curr_sym_tab;
+
+// Symbol table for global symbols.
+symbol_table *global_sym_tab;
+
+/*
+ * Is there a corresponding M-file that is newer than the symbol
+ * definition?
+ */
+int
+symbol_out_of_date (symbol_record *sr)
+{
+  int status = 0;
+  if (sr != (symbol_record *) NULL)
+    {
+      tree *ans = sr->def ();
+      if (ans != NULL_TREE)
+	{
+	  char *mf = ans->m_file_name ();
+	  if (mf != (char *) NULL)
+	    {
+	      time_t tp = ans->time_parsed ();
+	      status = is_newer (mf, tp);
+	    }
+	}
+    }
+  return status;
+}
+
+/*
+ * Force a symbol into the global symbol table.
+ */
+symbol_record *
+force_global (char *name)
+{
+  symbol_record *retval = (symbol_record *) NULL;
+
+  if (valid_identifier (name))
+    {
+      symbol_record *sr;
+      sr = curr_sym_tab->lookup (name, 0, 0);
+      if (sr == (symbol_record *) NULL)
+	{
+	  retval = global_sym_tab->lookup (name, 1, 0);
+	}
+      else if (sr->is_formal_parameter ())
+	{
+	  error ("formal parameter `%s' can't be made global", name);
+	}
+      else
+	{
+	  retval = global_sym_tab->lookup (name, 1, 0);
+	  retval->alias (sr);
+	  curr_sym_tab->clear (name);
+	}
+    }
+  else
+    warning ("`%s' is invalid as an identifier", name);
+
+  return retval;
+}
+
+int
+bind_variable (char *varname, tree_constant *val)
+{
+// Look for the symbol in the current symbol table.  If it's there,
+// great.  If not, don't insert it, but look for it in the global
+// symbol table.  If it's there, great.  If not, insert it in the
+// original current symbol table.
+
+  symbol_record *sr;
+  sr = curr_sym_tab->lookup (varname, 0, 0);
+  if (sr == (symbol_record *) NULL)
+    {
+      sr = global_sym_tab->lookup (varname, 0, 0);
+      if (sr == (symbol_record *) NULL)
+	{
+	  sr = curr_sym_tab->lookup (varname, 1);
+	}
+    }
+
+  if (sr != (symbol_record *) NULL)
+    {
+      sr->define (val);
+      return 0;
+    }
+  else
+    return 1;
+}
+
+int
+bind_protected_variable (char *varname, tree_constant *val)
+{
+// Look for the symbol in the current symbol table.  If it's there,
+// great.  If not, don't insert it, but look for it in the global
+// symbol table.  If it's there, great.  If not, insert it in the
+// original current symbol table.
+
+  symbol_record *sr;
+  sr = curr_sym_tab->lookup (varname, 0, 0);
+  if (sr == (symbol_record *) NULL)
+    {
+      sr = global_sym_tab->lookup (varname, 0, 0);
+      if (sr == (symbol_record *) NULL)
+	{
+	  sr = curr_sym_tab->lookup (varname, 1);
+	}
+    }
+
+  if (sr != (symbol_record *) NULL)
+    {
+      sr->unprotect ();
+      sr->define (val);
+      sr->protect ();
+      return 0;
+    }
+  else
+    return 1;
+}
+
+/*
+ * Look for name first in current then in global symbol tables.  If
+ * name is found and it refers to a string, return a new string
+ * containing its value.  Otherwise, return NULL.
+ */
+char *
+octave_string_variable (char *name)
+{
+  char *retval = (char *) NULL;
+  symbol_record *sr;
+  sr = curr_sym_tab->lookup (name, 0, 0);
+  if (sr == (symbol_record *) NULL)
+    {
+      sr = global_sym_tab->lookup (name, 0, 0);
+      if (sr == (symbol_record *) NULL)
+	return retval;
+    }
+
+  tree *defn = sr->def ();
+  if (defn != NULL_TREE)
+    {
+      tree_constant val = defn->eval (0);
+      if (val.is_string_type ())
+	{
+	  char *s = val.string_value ();
+	  if (s != (char *) NULL)
+	    retval = strsave (s);
+	}
+    }
+
+  return retval;
+}
+
+/*
+ * Look for name first in current then in global symbol tables.  If
+ * name is found and it refers to a real scalar, place the value in d
+ * and return 0.  Otherwise, return -1.
+ */
+int
+octave_real_scalar_variable (char *name, double& d)
+{
+  int status = -1;
+  symbol_record *sr;
+  sr = curr_sym_tab->lookup (name, 0, 0);
+  if (sr == (symbol_record *) NULL)
+    {
+      sr = global_sym_tab->lookup (name, 0, 0);
+      if (sr == (symbol_record *) NULL)
+	return status;
+    }
+
+  tree *defn = sr->def ();
+  if (defn != NULL_TREE)
+    {
+      tree_constant val = defn->eval (0);
+      if (val.const_type () == tree_constant_rep::scalar_constant)
+	{
+	  d = val.double_value ();
+	  status = 0;
+	}
+    }
+
+  return status;
+}
+
+/*
+ * Extract a keyword and its value from a file.  Input should look
+ * something like:
+ *
+ *  #[ \t]*keyword[ \t]*:[ \t]*string-value\n
+ */
+int
+extract_keyword (istream& is, char *keyword, char *value)
+{
+  char *ptr = value;
+
+  int status = 0;
+
+  char c;
+  while (is.get (c))
+    {
+      if (c == '#')
+	{
+	  while (is.get (c) && (c == ' ' || c == '\t' || c == '#'))
+	    ; // Skip whitespace and comment characters.
+
+	  if (isalpha (c))
+	    *ptr++ = c;
+
+	  while (is.get (c) && isalpha (c))
+	    *ptr++ = c;
+
+	  if (strncmp (value, keyword, strlen (keyword)) == 0)
+	    {
+	      ptr = value;
+	      while (is.get (c) && (c == ' ' || c == '\t' || c == ':'))
+		; // Skip whitespace and the colon.
+
+	      if (c != '\n')
+		{
+		  *ptr++ = c;
+		  while (is.get (c) && c != '\n')
+		    *ptr++ = c;
+		}
+	      *ptr = '\0';
+	      status = 1;
+	      break;
+	    }
+	}
+    }
+  return status;
+}
+
+int
+extract_keyword (istream& is, char *keyword, int& value)
+{
+  char buf [128];
+  char *ptr = buf;
+
+  int status = 0;
+  value = 0;
+
+  char c;
+  while (is.get (c))
+    {
+      if (c == '#')
+	{
+	  while (is.get (c) && (c == ' ' || c == '\t' || c == '#'))
+	    ; // Skip whitespace and comment characters.
+
+	  if (isalpha (c))
+	    *ptr++ = c;
+
+	  while (is.get (c) && isalpha (c))
+	    *ptr++ = c;
+
+	  if (strncmp (buf, keyword, strlen (keyword)) == 0)
+	    {
+	      ptr = buf;
+	      while (is.get (c) && (c == ' ' || c == '\t' || c == ':'))
+		; // Skip whitespace and the colon.
+
+	      is.putback (c);
+	      if (c != '\n')
+		is >> value;
+	      if (is)
+		status = 1;
+	      while (is.get (c) && c != '\n')
+		; // Skip to beginning of next line;
+	      break;
+	    }
+	}
+    }
+  return status;
+}
+
+/*
+ * Skip trailing white space and
+ */
+void
+skip_comments (istream& is)
+{
+  char c = '\0';
+  while (is.get (c))
+    {
+      if (c == ' ' || c == '\t' || c == '\n')
+	; // Skip whitespace on way to beginning of next line.
+      else
+	break;
+    }
+
+  for (;;)
+    {
+      if (is && c == '#')
+	while (is.get (c) && c != '\n')
+	  ; // Skip to beginning of next line, ignoring everything.
+      else
+	break;
+    }
+}
+
+/*
+ * Is `s' a valid identifier?
+ */
+int
+valid_identifier (char *s)
+{
+  if (s == (char *) NULL || ! (isalnum (*s) || *s == '_'))
+     return 0;
+
+  while (*++s != '\0')
+    if (! (isalnum (*s) || *s == '_'))
+      return 0;
+
+  return 1;
+}
+
+/*
+ * See if the identifier is in scope.
+ */
+int
+identifier_exists (char *name)
+{
+  int status = 0;
+
+  if (curr_sym_tab->lookup (name, 0, 0) != (symbol_record *) NULL
+      || global_sym_tab->lookup (name, 0, 0) != (symbol_record *) NULL)
+    status = 1;
+  else
+    {
+      char *path = m_file_in_path (name);
+      if (path != (char *) NULL)
+	{
+	  delete [] path;
+	  status = 2;
+	}
+      else
+	{
+	  struct stat buf;
+	  if (stat (name, &buf) == 0 && S_ISREG (buf.st_mode))
+	    status = 2;
+	}
+	
+    }
+  return status;
+}
+
+/*
+ * Is this tree_constant a valid function?
+ */
+tree *
+is_valid_function (tree_constant& arg, char *warn_for, int warn = 0)
+{
+  tree *ans = NULL_TREE;
+
+  if (! arg.is_string_type ())
+    {
+      if (warn)
+	message (warn_for, "expecting function name as argument");
+      return ans;
+    }
+
+  char *fcn_name = arg.string_value ();
+  symbol_record *sr = global_sym_tab->lookup (fcn_name, 0, 0);
+
+  if (sr == (symbol_record *) NULL)
+    {
+      sr = global_sym_tab->lookup (fcn_name, 1, 0);
+      tree_identifier tmp (sr);
+      tmp.parse_m_file (0);
+    }
+  else if (symbol_out_of_date (sr))
+    {
+      tree_identifier tmp (sr);
+      tmp.parse_m_file (0);
+    }
+
+  ans = sr->def ();
+  if (ans == NULL_TREE || ! sr->is_function ())
+    {
+      if (warn)
+	message (warn_for, "the symbol `%s' is not valid as a function",
+		 fcn_name);
+      ans = NULL_TREE;
+    }
+
+  return ans;
+}
+
+/*
+ * Does this function take the right number of arguments?
+ */
+int
+takes_correct_nargs (tree *fcn, int expected_nargin, char *warn_for,
+		     int warn = 0) 
+{
+  int nargs = fcn->max_expected_args () - 1;
+  int e_nargs = expected_nargin - 1;
+  if (nargs != e_nargs)
+    {
+      if (warn)
+	message (warn_for, "expecting function to take %d argument%c", 
+		 e_nargs, s_plural (e_nargs));
+      return 0;
+    }
+  return 1;
+}
+
+char **
+make_name_list (void)
+{
+  int key_len = 0;
+  int glb_len = 0;
+  int top_len = 0;
+  int lcl_len = 0;
+  int mfl_len = 0;
+
+  char **key = (char **) NULL;
+  char **glb = (char **) NULL;
+  char **top = (char **) NULL;
+  char **lcl = (char **) NULL;
+  char **mfl = (char **) NULL;
+
+  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);
+  mfl = get_m_file_names (mfl_len, 1);
+
+  int total_len = key_len + glb_len + top_len + lcl_len + mfl_len;
+
+  char **list = new char * [total_len+1];
+  
+  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 < mfl_len; i++)
+    list[j++] = mfl[i];
+
+  list[j] = (char *) NULL;
+
+  delete [] key;
+  delete [] glb;
+  delete [] top;
+  delete [] lcl;
+  delete [] mfl;
+
+  return list;
+}
+
+/*
+;;; Local Variables: ***
+;;; mode: C++ ***
+;;; page-delimiter: "^/\\*" ***
+;;; End: ***
+*/