CbC/CbC_gcc: gcc/fortran/module.c comparison

comparison gcc/fortran/module.c @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 /* Handle modules, which amounts to loading and saving symbols and
 their attendant structures.
-Copyright (C) 2000-2017 Free Software Foundation, Inc.
+Copyright (C) 2000-2018 Free Software Foundation, Inc.
 Contributed by Andy Vaught
 This file is part of GCC.
 GCC is free software; you can redistribute it and/or modify it under
 };
 typedef struct pointer_info
 {
 BBT_HEADER (pointer_info);
-int integer;
+HOST_WIDE_INT integer;
 pointer_t type;
 /* The first component of each member of the union is the pointer
 being stored.  */
 /* Given an integer during reading, find it in the pointer_info tree,
 creating the node if not found.  */
 static pointer_info *
-get_integer (int integer)
+get_integer (HOST_WIDE_INT integer)
 {
 pointer_info *p, t;
 int c;
 t.integer = integer;
 the reference has been actually stored, or nonzero if the reference
 must be fixed later (i.e., associate_integer_pointer must be called
 sometime later.  Returns the pointer_info structure.  */
 static pointer_info *
-add_fixup (int integer, void *gp)
+add_fixup (HOST_WIDE_INT integer, void *gp)
 {
 pointer_info *p;
 fixup_t *f;
 char **cp;
 number to be preserved (this can't be done by a decimal
 representation).  Worry about that later.  TODO!  */
 #define MAX_ATOM_SIZE 100
-static int atom_int;
+static HOST_WIDE_INT atom_int;
 static char *atom_string, atom_name[MAX_ATOM_SIZE];
 /* Report problems with a module.  Error reporting is not very
 elaborate, since this sorts of errors shouldn't really happen.
 atom_string = XRESIZEVEC (char, atom_string, len + 1);
 atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
 }
-/* Parse a small integer.  */
+/* Parse an integer. Should fit in a HOST_WIDE_INT.  */
 static void
 parse_integer (int c)
 {
 atom_int = c - '0';
 	  module_unget_char ();
 	  break;
 	}
 atom_int = 10 * atom_int + c - '0';
-if (atom_int > 99999999)
-	bad_module ("Integer overflow");
 }
 }
 the file really isn't meant to be read by people anyway.  */
 static void
 write_atom (atom_type atom, const void *v)
 {
-char buffer[20];
+char buffer[32];
 /* Workaround -Wmaybe-uninitialized false positive during
 profiledbootstrap by initializing them.  */
-int i = 0, len;
+int len;
+HOST_WIDE_INT i = 0;
 const char *p;
 switch (atom)
 {
 case ATOM_STRING:
 case ATOM_RPAREN:
 p = ")";
 break;
 case ATOM_INTEGER:
-i = *((const int *) v);
+i = *((const HOST_WIDE_INT *) v);
-if (i < 0)
-	gfc_internal_error ("write_atom(): Writing negative integer");
+snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i);
-sprintf (buffer, "%d", i);
 p = buffer;
 break;
 default:
 gfc_internal_error ("write_atom(): Trying to write dab atom");
 static void
 mio_integer (int *ip)
 {
 if (iomode == IO_OUTPUT)
-write_atom (ATOM_INTEGER, ip);
+{
+HOST_WIDE_INT hwi = *ip;
+write_atom (ATOM_INTEGER, &hwi);
+}
 else
 {
 require_atom (ATOM_INTEGER);
 *ip = atom_int;
 }
 }
+static void
+mio_hwi (HOST_WIDE_INT *hwi)
+{
+if (iomode == IO_OUTPUT)
+write_atom (ATOM_INTEGER, hwi);
+else
+{
+require_atom (ATOM_INTEGER);
+*hwi = atom_int;
+}
+}
 /* Read or write a gfc_intrinsic_op value.  */
 static void
 mio_intrinsic_op (gfc_intrinsic_op* op)
 {
 /* FIXME: Would be nicer to do this via the operators symbolic name.  */
 if (iomode == IO_OUTPUT)
 {
-int converted = (int) *op;
+HOST_WIDE_INT converted = (HOST_WIDE_INT) *op;
 write_atom (ATOM_INTEGER, &converted);
 }
 else
 {
 require_atom (ATOM_INTEGER);
 and cast it to/from an integer.  */
 if (iomode == IO_OUTPUT)
 {
 for (i = 0; i < ar->dimen; i++)
 	{
-	  int tmp = (int)ar->dimen_type[i];
+	  HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
 	  write_atom (ATOM_INTEGER, &tmp);
 	}
 }
 else
 {
 pointer_info *p;
 if (iomode == IO_OUTPUT)
 {
 p = get_pointer (*((char **) gp));
-write_atom (ATOM_INTEGER, &p->integer);
+HOST_WIDE_INT hwi = p->integer;
+write_atom (ATOM_INTEGER, &hwi);
 }
 else
 {
 require_atom (ATOM_INTEGER);
 p = add_fixup (atom_int, gp);
 static void
 mio_component (gfc_component *c, int vtype)
 {
 pointer_info *p;
-int n;
 mio_lparen ();
 if (iomode == IO_OUTPUT)
 {
 p = get_pointer (c);
-mio_integer (&p->integer);
+mio_hwi (&p->integer);
 }
 else
 {
-mio_integer (&n);
+HOST_WIDE_INT n;
+mio_hwi (&n);
 p = get_integer (n);
 associate_integer_pointer (p, c);
 }
 if (p->type == P_UNKNOWN)
 || strcmp (c->name, "_hash") == 0)
 mio_expr (&c->initializer);
 if (c->attr.proc_pointer)
 mio_typebound_proc (&c->tb);
+c->loc = gfc_current_locus;
 mio_rparen ();
 }
 NULL expression.  */
 static void
 mio_expr (gfc_expr **ep)
 {
+HOST_WIDE_INT hwi;
 gfc_expr *e;
 atom_type t;
 int flag;
 mio_lparen ();
 	case BT_LOGICAL:
 	  mio_integer (&e->value.logical);
 	  break;
 	case BT_CHARACTER:
-	  mio_integer (&e->value.character.length);
+	  hwi = e->value.character.length;
+	  mio_hwi (&hwi);
+	  e->value.character.length = hwi;
 	  e->value.character.string
 	    = CONST_CAST (gfc_char_t *,
 			  mio_allocated_wide_string (e->value.character.string,
 						     e->value.character.length));
 	  break;
 minit ("NOTINBRANCH", 1),
 minit ("SIMDLEN", 2),
 minit ("UNIFORM", 3),
 minit ("LINEAR", 4),
 minit ("ALIGNED", 5),
+minit ("LINEAR_REF", 33),
+minit ("LINEAR_VAL", 34),
+minit ("LINEAR_UVAL", 35),
 minit (NULL, -1)
 };
 /* Handle !$omp declare simd.  */
 	      mio_name (3, omp_declare_simd_clauses);
 	      mio_symbol_ref (&n->sym);
 	    }
 	  for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
 	    {
-	      mio_name (4, omp_declare_simd_clauses);
+	      if (n->u.linear_op == OMP_LINEAR_DEFAULT)
+		mio_name (4, omp_declare_simd_clauses);
+	      else
+		mio_name (32 + n->u.linear_op, omp_declare_simd_clauses);
 	      mio_symbol_ref (&n->sym);
 	      mio_expr (&n->expr);
 	    }
 	  for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
 	    {
 	    case 2: mio_expr (&ods->clauses->simdlen_expr); break;
 	    case 3:
 	    case 4:
 	    case 5:
 	      *ptrs[t - 3] = n = gfc_get_omp_namelist ();
+	    finish_namelist:
+	      n->where = gfc_current_locus;
 	      ptrs[t - 3] = &n->next;
 	      mio_symbol_ref (&n->sym);
 	      if (t != 3)
 		mio_expr (&n->expr);
 	      break;
+	    case 33:
+	    case 34:
+	    case 35:
+	      *ptrs[1] = n = gfc_get_omp_namelist ();
+	      n->u.linear_op = (enum gfc_omp_linear_op) (t - 32);
+	      t = 4;
+	      goto finish_namelist;
 	    }
 	}
 }
 mio_omp_declare_simd (ns, &ods->next);
 	{
 	  gfc_symtree *st;
 	  /* Decide if we need to load this one or not.  */
 	  p = find_use_name_n (name, &i, false);
-	  st = find_symbol (gfc_current_ns->sym_root,
-			    name, module_name, 1);
 	  if (!p || gfc_find_symbol (p, NULL, 0, &sym))
 	    {
 	      /* Skip the specific names for these cases.  */
 	      while (i == 1 && parse_atom () != ATOM_RPAREN);
 	      continue;
 	    }
+	  st = find_symbol (gfc_current_ns->sym_root,
+			    name, module_name, 1);
 	  /* If the symbol exists already and is being USEd without being
 	     in an ONLY clause, do not load a new symtree(11.3.2).  */
 	  if (!only_flag && st)
 	    sym = st->n.sym;
 mio_lparen ();
 mio_pool_string (&name);
 gfc_clear_ts (&ts);
 mio_typespec (&ts);
-if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
+if (gfc_str_startswith (name, "operator "))
 	{
 	  const char *p = name + sizeof ("operator ") - 1;
 	  if (strcmp (p, "+") == 0)
 	    rop = OMP_REDUCTION_PLUS;
 	  else if (strcmp (p, "*") == 0)
 	  if (p == NULL && strcmp (name, module_name) == 0)
 	    p = name;
 	  /* Exception: Always import vtabs & vtypes.  */
 	  if (p == NULL && name[0] == '_'
-	      && (strncmp (name, "__vtab_", 5) == 0
+	      && (gfc_str_startswith (name, "__vtab_")
-		  || strncmp (name, "__vtype_", 6) == 0))
+		  || gfc_str_startswith (name, "__vtype_")))
 	    p = name;
 	  /* Skip symtree nodes not in an ONLY clause, unless there
 	     is an existing symtree loaded from another USE statement.  */
 	  if (p == NULL)
 	      if (strcmp (name, p) != 0)
 		sym->attr.use_rename = 1;
 	      if (name[0] != '_'
-		  || (strncmp (name, "__vtab_", 5) != 0
+		  || (!gfc_str_startswith (name, "__vtab_")
-		      && strncmp (name, "__vtype_", 6) != 0))
+		      && !gfc_str_startswith (name, "__vtype_")))
 		sym->attr.use_only = only_flag;
 	      /* Store the symtree pointing to this symbol.  */
 	      info->u.rsym.symtree = st;
 if (p == NULL)
 gfc_internal_error ("write_symtree(): Symbol not written");
 mio_pool_string (&st->name);
 mio_integer (&st->ambiguous);
-mio_integer (&p->integer);
+mio_hwi (&p->integer);
 }
 static void
 write_module (void)
 module_fp = gzopen (filename_tmp, "w");
 if (module_fp == NULL)
 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
 		     filename_tmp, xstrerror (errno));
+/* Use lbasename to ensure module files are reproducible regardless
+of the build path (see the reproducible builds project).  */
 gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
-	    MOD_VERSION, gfc_source_file);
+	    MOD_VERSION, lbasename (gfc_source_file));
 /* Write the module itself.  */
 iomode = IO_OUTPUT;
 init_pi_tree ();

Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/module.c @ 131:84e7813d76e9