diff gcc/fortran/dump-parse-tree.c @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
line wrap: on
line diff
--- a/gcc/fortran/dump-parse-tree.c	Fri Oct 27 22:46:09 2017 +0900
+++ b/gcc/fortran/dump-parse-tree.c	Thu Oct 25 07:37:49 2018 +0900
@@ -1,5 +1,5 @@
 /* Parse tree dumper
-   Copyright (C) 2003-2017 Free Software Foundation, Inc.
+   Copyright (C) 2003-2018 Free Software Foundation, Inc.
    Contributed by Steven Bosscher
 
 This file is part of GCC.
@@ -348,12 +348,10 @@
 
 
 static void
-show_char_const (const gfc_char_t *c, int length)
+show_char_const (const gfc_char_t *c, gfc_charlen_t length)
 {
-  int i;
-
   fputc ('\'', dumpfile);
-  for (i = 0; i < length; i++)
+  for (size_t i = 0; i < (size_t) length; i++)
     {
       if (c[i] == '\'')
 	fputs ("''", dumpfile);
@@ -465,7 +463,8 @@
 	  break;
 
 	case BT_HOLLERITH:
-	  fprintf (dumpfile, "%dH", p->representation.length);
+	  fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H",
+		   p->representation.length);
 	  c = p->representation.string;
 	  for (i = 0; i < p->representation.length; i++, c++)
 	    {
@@ -717,6 +716,8 @@
     fputs (" ELEMENTAL", dumpfile);
   if (attr->pure)
     fputs (" PURE", dumpfile);
+  if (attr->implicit_pure)
+    fputs (" IMPLICIT_PURE", dumpfile);
   if (attr->recursive)
     fputs (" RECURSIVE", dumpfile);
 
@@ -1383,21 +1384,26 @@
 	const char *type = NULL;
 	switch (list_type)
 	  {
-	  case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
-	  case OMP_LIST_DEVICE_RESIDENT: type = "USE_DEVICE"; break;
-	  case OMP_LIST_CACHE: type = ""; break;
 	  case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
 	  case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
 	  case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+	  case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break;
 	  case OMP_LIST_SHARED: type = "SHARED"; break;
 	  case OMP_LIST_COPYIN: type = "COPYIN"; break;
 	  case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
 	  case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
 	  case OMP_LIST_LINEAR: type = "LINEAR"; break;
+	  case OMP_LIST_DEPEND: type = "DEPEND"; break;
+	  case OMP_LIST_MAP: type = "MAP"; break;
+	  case OMP_LIST_TO: type = "TO"; break;
+	  case OMP_LIST_FROM: type = "FROM"; break;
 	  case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
+	  case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break;
+	  case OMP_LIST_LINK: type = "LINK"; break;
+	  case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break;
+	  case OMP_LIST_CACHE: type = "CACHE"; break;
 	  case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break;
 	  case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break;
-	  case OMP_LIST_DEPEND: type = "DEPEND"; break;
 	  default:
 	    gcc_unreachable ();
 	  }
@@ -1869,6 +1875,22 @@
       fputs ("FAIL IMAGE ", dumpfile);
       break;
 
+    case EXEC_CHANGE_TEAM:
+      fputs ("CHANGE TEAM", dumpfile);
+      break;
+
+    case EXEC_END_TEAM:
+      fputs ("END TEAM", dumpfile);
+      break;
+
+    case EXEC_FORM_TEAM:
+      fputs ("FORM TEAM", dumpfile);
+      break;
+
+    case EXEC_SYNC_TEAM:
+      fputs ("SYNC TEAM", dumpfile);
+      break;
+
     case EXEC_SYNC_ALL:
       fputs ("SYNC ALL ", dumpfile);
       if (c->expr2 != NULL)
@@ -3007,7 +3029,6 @@
   *type_name = "<error>";
   if (ts->type == BT_REAL || ts->type == BT_INTEGER)
     {
- 
       if (ts->is_c_interop && ts->interop_kind)
 	{
 	  *type_name = ts->interop_kind->name + 2;
@@ -3022,8 +3043,7 @@
 	{
 	  /* The user did not specify a C interop type.  Let's look through
 	     the available table and use the first one, but warn.  */
-	  int i;
-	  for (i=0; i<ISOCBINDING_NUMBER; i++)
+	  for (int i = 0; i < ISOCBINDING_NUMBER; i++)
 	    {
 	      if (c_interop_kinds_table[i].f90_type == ts->type
 		  && c_interop_kinds_table[i].value == ts->kind)
@@ -3040,6 +3060,48 @@
 	    }
 	}
     }
+  else if (ts->type == BT_LOGICAL)
+    {
+      if (ts->is_c_interop && ts->interop_kind)
+	{
+	  *type_name = "_Bool";
+	  ret = T_OK;
+	}
+      else
+	{
+	  /* Let's select an appropriate int, with a warning. */
+	  for (int i = 0; i < ISOCBINDING_NUMBER; i++)
+	    {
+	      if (c_interop_kinds_table[i].f90_type == BT_INTEGER
+		  && c_interop_kinds_table[i].value == ts->kind)
+		{
+		  *type_name = c_interop_kinds_table[i].name + 2;
+		  ret = T_WARN;
+		}
+	    }
+	}
+    }
+  else if (ts->type == BT_CHARACTER)
+    {
+      if (ts->is_c_interop)
+	{
+	  *type_name = "char";
+	  ret = T_OK;
+	}
+      else
+	{
+	  /* Let's select an appropriate int, with a warning. */
+	  for (int i = 0; i < ISOCBINDING_NUMBER; i++)
+	    {
+	      if (c_interop_kinds_table[i].f90_type == BT_INTEGER
+		  && c_interop_kinds_table[i].value == ts->kind)
+		{
+		  *type_name = c_interop_kinds_table[i].name + 2;
+		  ret = T_WARN;
+		}
+	    }
+	}
+    }
   else if (ts->type == BT_DERIVED)
     {
       if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
@@ -3083,24 +3145,32 @@
 /* Write out a declaration.  */
 static void
 write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
-	    bool func_ret)
+	    bool func_ret, locus *where)
 {
-    const char *pre, *type_name, *post;
-    bool asterisk;
-    enum type_return rok;
-
-    rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
-    gcc_assert (rok != T_ERROR);
-    fputs (type_name, dumpfile);
-    fputs (pre, dumpfile);
-    if (asterisk)
-      fputs ("*", dumpfile);
-
-    fputs (sym_name, dumpfile);
-    fputs (post, dumpfile);
+  const char *pre, *type_name, *post;
+  bool asterisk;
+  enum type_return rok;
+
+  rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret);
+  if (rok == T_ERROR)
+    {
+      gfc_error_now ("Cannot convert %qs to interoperable type at %L",
+		     gfc_typename (ts), where);
+      fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */",
+	       gfc_typename (ts));
+      return;
+    }
+  fputs (type_name, dumpfile);
+  fputs (pre, dumpfile);
+  if (asterisk)
+    fputs ("*", dumpfile);
+
+  fputs (sym_name, dumpfile);
+  fputs (post, dumpfile);
     
-    if (rok == T_WARN)
-      fputs(" /* WARNING: non-interoperable KIND */", dumpfile);
+  if (rok == T_WARN)
+    fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
+	     gfc_typename (ts));
 }
 
 /* Write out an interoperable type.  It will be written as a typedef
@@ -3115,7 +3185,7 @@
   for (c = sym->components; c; c = c->next)
     {
       fputs ("    ", dumpfile);
-      write_decl (&(c->ts), c->as, c->name, false);
+      write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at);
       fputs (";\n", dumpfile);
     }
 
@@ -3137,7 +3207,7 @@
     sym_name = sym->name;
 
   fputs ("extern ", dumpfile);
-  write_decl (&(sym->ts), sym->as, sym_name, false);
+  write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at);
   fputs (";\n", dumpfile);
 }
 
@@ -3164,7 +3234,7 @@
       fputs (sym_name, dumpfile);
     }
   else
-    write_decl (&(sym->ts), sym->as, sym->name, true);
+    write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at);
 
   fputs (" (", dumpfile);
 
@@ -3174,7 +3244,14 @@
       s = f->sym;
       rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk,
 			     &post, false);
-      gcc_assert (rok != T_ERROR);
+      if (rok == T_ERROR)
+	{
+	  gfc_error_now ("Cannot convert %qs to interoperable type at %L",
+			 gfc_typename (&s->ts), &s->declared_at);
+	  fprintf (stderr, "/* Cannot convert '%s' to interoperable type */",
+		   gfc_typename (&s->ts));
+	  return;
+	}
 
       if (!s->attr.value)
 	asterisk = true;
@@ -3195,9 +3272,10 @@
       if (rok == T_WARN)
 	fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile);
 
-      fputs (f->next ? ", " : ")", dumpfile);
+      if (f->next)
+	fputs(", ", dumpfile);
     }
-  fputs (";\n", dumpfile);
+  fputs (");\n", dumpfile);
 }