Initial revision

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@14772 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 383 insertions, 0 deletions

diff --git a/gcc/f/implic.c b/gcc/f/implic.c
new file mode 100644
index 00000000000..292f88f7410
--- /dev/null
+++ b/gcc/f/implic.c
@@ -0,0 +1,383 @@
+/* implic.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Related Modules:
+      None.
+
+   Description:
+      The GNU Fortran Front End.
+
+   Modifications:
+*/
+
+/* Include files. */
+
+#include "proj.h"
+#include <ctype.h>
+#include "implic.h"
+#include "info.h"
+#include "src.h"
+#include "symbol.h"
+#include "target.h"
+
+/* Externals defined here. */
+
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+    FFEIMPLIC_stateINITIAL_,
+    FFEIMPLIC_stateASSUMED_,
+    FFEIMPLIC_stateESTABLISHED_,
+    FFEIMPLIC_state
+  } ffeimplicState_;
+
+/* Internal typedefs. */
+
+typedef struct _ffeimplic_ *ffeimplic_;
+
+/* Private include files. */
+
+
+/* Internal structure definitions. */
+
+struct _ffeimplic_
+  {
+    ffeimplicState_ state;
+    ffeinfo info;
+  };
+
+/* Static objects accessed by functions in this module. */
+
+/* NOTE: This is definitely ASCII-specific!!  */
+
+static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1];
+
+/* Static functions (internal). */
+
+static ffeimplic_ ffeimplic_lookup_ (char c);
+
+/* Internal macros. */
+
+
+/* ffeimplic_lookup_ -- Look up implicit descriptor for initial character
+
+   ffeimplic_ imp;
+   if ((imp = ffeimplic_lookup_('A')) == NULL)
+       // error
+
+   Returns a pointer to an implicit descriptor block based on the character
+   passed, or NULL if it is not a valid initial character for an implicit
+   data type.  */
+
+static ffeimplic_
+ffeimplic_lookup_ (char c)
+{
+  /* NOTE: This is definitely ASCII-specific!!  */
+  if (isalpha (c) || (c == '_'))
+    return &ffeimplic_table_[c - 'A'];
+  return NULL;
+}
+
+/* ffeimplic_establish_initial -- Establish type of implicit initial letter
+
+   ffesymbol s;
+   if (!ffeimplic_establish_initial(s))
+       // error
+
+   Assigns implicit type information to the symbol based on the first
+   character of the symbol's name.  */
+
+bool
+ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
+		     ffeinfoKindtype kind_type, ffetargetCharacterSize size)
+{
+  ffeimplic_ imp;
+
+  imp = ffeimplic_lookup_ (c);
+  if (imp == NULL)
+    return FALSE;		/* Character not A-Z or some such thing. */
+  if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
+    return FALSE;		/* IMPLICIT NONE in effect here. */
+
+  switch (imp->state)
+    {
+    case FFEIMPLIC_stateINITIAL_:
+      imp->info = ffeinfo_new (basic_type,
+			       kind_type,
+			       0,
+			       FFEINFO_kindNONE,
+			       FFEINFO_whereNONE,
+			       size);
+      imp->state = FFEIMPLIC_stateESTABLISHED_;
+      return TRUE;
+
+    case FFEIMPLIC_stateASSUMED_:
+      if ((ffeinfo_basictype (imp->info) != basic_type)
+	  || (ffeinfo_kindtype (imp->info) != kind_type)
+	  || (ffeinfo_size (imp->info) != size))
+	return FALSE;
+      imp->state = FFEIMPLIC_stateESTABLISHED_;
+      return TRUE;
+
+    case FFEIMPLIC_stateESTABLISHED_:
+      return FALSE;
+
+    default:
+      assert ("Weird state for implicit object" == NULL);
+      return FALSE;
+    }
+}
+
+/* ffeimplic_establish_symbol -- Establish implicit type of a symbol
+
+   ffesymbol s;
+   if (!ffeimplic_establish_symbol(s))
+       // error
+
+   Assigns implicit type information to the symbol based on the first
+   character of the symbol's name.
+
+   If symbol already has a type, return TRUE.
+   Get first character of symbol's name.
+   Get ffeimplic_ object for it (return FALSE if NULL returned).
+   Return FALSE if object has no assigned type (IMPLICIT NONE).
+   Copy the type information from the object to the symbol.
+   If the object is state "INITIAL", set to state "ASSUMED" so no
+       subsequent IMPLICIT statement may change the state.
+   Return TRUE.	 */
+
+bool
+ffeimplic_establish_symbol (ffesymbol s)
+{
+  char c;
+  ffeimplic_ imp;
+
+  if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
+    return TRUE;
+
+  c = *(ffesymbol_text (s));
+  imp = ffeimplic_lookup_ (c);
+  if (imp == NULL)
+    return FALSE;		/* First character not A-Z or some such
+				   thing. */
+  if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
+    return FALSE;		/* IMPLICIT NONE in effect here. */
+
+  ffesymbol_signal_change (s);	/* Gonna change, save existing? */
+
+  /* Establish basictype, kindtype, size; preserve rank, kind, where. */
+
+  ffesymbol_set_info (s,
+		      ffeinfo_new (ffeinfo_basictype (imp->info),
+				   ffeinfo_kindtype (imp->info),
+				   ffesymbol_rank (s),
+				   ffesymbol_kind (s),
+				   ffesymbol_where (s),
+				   ffeinfo_size (imp->info)));
+
+  if (imp->state == FFEIMPLIC_stateINITIAL_)
+    imp->state = FFEIMPLIC_stateASSUMED_;
+
+  if (ffe_is_warn_implicit ())
+    {
+      ffebad_start_msg ("Implicit declaration of `%A' at %0",
+			FFEBAD_severityWARNING);
+      ffebad_here (0, ffesymbol_where_line (s),
+		   ffesymbol_where_column (s));
+      ffebad_string (ffesymbol_text (s));
+      ffebad_finish ();
+    }
+
+  return TRUE;
+}
+
+/* ffeimplic_init_2 -- Initialize table
+
+   ffeimplic_init_2();
+
+   Assigns initial type information to all initial letters.
+
+   Allows for holes in the sequence of letters (i.e. EBCDIC).  */
+
+void
+ffeimplic_init_2 ()
+{
+  ffeimplic_ imp;
+  char c;
+
+  for (c = 'A'; c <= 'z'; ++c)
+    {
+      imp = &ffeimplic_table_[c - 'A'];
+      imp->state = FFEIMPLIC_stateINITIAL_;
+      switch (c)
+	{
+	case 'A':
+	case 'B':
+	case 'C':
+	case 'D':
+	case 'E':
+	case 'F':
+	case 'G':
+	case 'H':
+	case 'O':
+	case 'P':
+	case 'Q':
+	case 'R':
+	case 'S':
+	case 'T':
+	case 'U':
+	case 'V':
+	case 'W':
+	case 'X':
+	case 'Y':
+	case 'Z':
+	case '_':
+	case 'a':
+	case 'b':
+	case 'c':
+	case 'd':
+	case 'e':
+	case 'f':
+	case 'g':
+	case 'h':
+	case 'o':
+	case 'p':
+	case 'q':
+	case 'r':
+	case 's':
+	case 't':
+	case 'u':
+	case 'v':
+	case 'w':
+	case 'x':
+	case 'y':
+	case 'z':
+	  imp->info = ffeinfo_new (FFEINFO_basictypeREAL,
+				   FFEINFO_kindtypeREALDEFAULT,
+				   0,
+				   FFEINFO_kindNONE,
+				   FFEINFO_whereNONE,
+				   FFETARGET_charactersizeNONE);
+	  break;
+
+	case 'I':
+	case 'J':
+	case 'K':
+	case 'L':
+	case 'M':
+	case 'N':
+	case 'i':
+	case 'j':
+	case 'k':
+	case 'l':
+	case 'm':
+	case 'n':
+	  imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER,
+				   FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE,
+				   FFETARGET_charactersizeNONE);
+	  break;
+
+	default:
+	  imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0,
+	  FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE);
+	  break;
+	}
+    }
+}
+
+/* ffeimplic_none -- Implement IMPLICIT NONE statement
+
+   ffeimplic_none();
+
+   Assigns null type information to all initial letters.  */
+
+void
+ffeimplic_none ()
+{
+  ffeimplic_ imp;
+
+  for (imp = &ffeimplic_table_[0];
+       imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)];
+       imp++)
+    {
+      imp->info = ffeinfo_new (FFEINFO_basictypeNONE,
+			       FFEINFO_kindtypeNONE,
+			       0,
+			       FFEINFO_kindNONE,
+			       FFEINFO_whereNONE,
+			       FFETARGET_charactersizeNONE);
+    }
+}
+
+/* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol
+
+   ffesymbol s;
+   char *name;	// name for s in case it is NULL, or NULL if s never NULL
+   if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER)
+       // is or will be a CHARACTER-typed name
+
+   Like establish_symbol, but doesn't change anything.
+
+   If symbol is non-NULL and already has a type, return it.
+   Get first character of symbol's name or from name arg if symbol is NULL.
+   Get ffeimplic_ object for it (return FALSE if NULL returned).
+   Return NONE if object has no assigned type (IMPLICIT NONE).
+   Return the data type indicated in the object.
+
+   24-Oct-91  JCB  2.0
+      Take a char * instead of ffelexToken, since the latter isn't always
+      needed anyway (as when ffecom calls it).	*/
+
+ffeinfoBasictype
+ffeimplic_peek_symbol_type (ffesymbol s, char *name)
+{
+  char c;
+  ffeimplic_ imp;
+
+  if (s == NULL)
+    c = *name;
+  else
+    {
+      if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
+	return ffesymbol_basictype (s);
+
+      c = *(ffesymbol_text (s));
+    }
+
+  imp = ffeimplic_lookup_ (c);
+  if (imp == NULL)
+    return FFEINFO_basictypeNONE;	/* First character not A-Z or
+					   something. */
+  return ffeinfo_basictype (imp->info);
+}
+
+/* ffeimplic_terminate_2 -- Terminate table
+
+   ffeimplic_terminate_2();
+
+   Kills info object for each entry in table.  */
+
+void
+ffeimplic_terminate_2 ()
+{
+}