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

comparison gcc/fortran/primary.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
 /* Primary expression subroutines
-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
 {
 ref = gfc_get_ref ();
 ref->type = REF_SUBSTRING;
 if (start == NULL)
-	start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+	start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
 ref->u.ss.start = start;
 if (end == NULL && cl)
 	end = gfc_copy_expr (cl->length);
 ref->u.ss.end = end;
 ref->u.ss.length = cl;
 static match
 match_string_constant (gfc_expr **result)
 {
 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
-int i, kind, length, save_warn_ampersand, ret;
+size_t length;
+int kind,save_warn_ampersand, ret;
 locus old_locus, start_locus;
 gfc_symbol *sym;
 gfc_expr *e;
 match m;
 gfc_char_t c, delimiter, *p;
 been printed in the loop above.  */
 save_warn_ampersand = warn_ampersand;
 warn_ampersand = false;
 p = e->value.character.string;
-for (i = 0; i < length; i++)
+for (size_t i = 0; i < length; i++)
 {
 c = next_string_char (delimiter, &ret);
 if (!gfc_check_character_range (c, kind))
 	{
 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
 return MATCH_NO;
 if (sym->attr.flavor != FL_PARAMETER)
 {
-gfc_error ("Expected PARAMETER symbol in complex constant at %C");
+/* Give the matcher for implied do-loops a chance to run.  This yields
-return MATCH_ERROR;
+	 a much saner error message for "write(*,*) (i, i=1, 6" where the
+	 right parenthesis is missing.  */
+char c;
+gfc_gobble_whitespace ();
+c = gfc_peek_ascii_char ();
+if (c == '=' || c == ',')
+	{
+	  m = MATCH_NO;
+	}
+else
+	{
+	  gfc_error ("Expected PARAMETER symbol in complex constant at %C");
+	  m = MATCH_ERROR;
+	}
+return m;
 }
 if (!sym->value)
 goto error;
 if (name[0] != '\0')
 {
 switch (name[0])
 	{
 	case 'l':
-	  if (strncmp (name, "loc", 3) == 0)
+	  if (gfc_str_startswith (name, "loc"))
 	    {
 	      result->name = "%LOC";
 	      break;
 	    }
 	  /* FALLTHRU */
 	case 'r':
-	  if (strncmp (name, "ref", 3) == 0)
+	  if (gfc_str_startswith (name, "ref"))
 	    {
 	      result->name = "%REF";
 	      break;
 	    }
 	  /* FALLTHRU */
 	case 'v':
-	  if (strncmp (name, "val", 3) == 0)
+	  if (gfc_str_startswith (name, "val"))
 	    {
 	      result->name = "%VAL";
 	      break;
 	    }
 	  /* FALLTHRU */
 /* See if there is a usable typespec in the "no IMPLICIT type" error.  */
 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
 {
 bool permissible;
-/* These target expressions can ge resolved at any time.  */
+/* These target expressions can be resolved at any time.  */
 permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
 		    && (tgt_expr->symtree->n.sym->attr.use_assoc
 			|| tgt_expr->symtree->n.sym->attr.host_assoc
 			|| tgt_expr->symtree->n.sym->attr.if_source
 								== IFSRC_DECL);
 /* Here we can check if a component name is given which does not
 	 correspond to any component of the defined structure.  */
 if (!this_comp)
 	goto cleanup;
+/* For a constant string constructor, make sure the length is
+	 correct; truncate of fill with blanks if needed.  */
+if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
+	  && this_comp->ts.u.cl && this_comp->ts.u.cl->length
+	  && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	  && actual->expr->ts.type == BT_CHARACTER
+	  && actual->expr->expr_type == EXPR_CONSTANT)
+	{
+	  ptrdiff_t c, e;
+	  c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
+	  e = actual->expr->value.character.length;
+	  if (c != e)
+	    {
+	      ptrdiff_t i, to;
+	      gfc_char_t *dest;
+	      dest = gfc_get_wide_string (c + 1);
+	      to = e < c ? e : c;
+	      for (i = 0; i < to; i++)
+		dest[i] = actual->expr->value.character.string[i];
+	      for (i = e; i < c; i++)
+		dest[i] = ' ';
+	      dest[c] = '\0';
+	      free (actual->expr->value.character.string);
+	      actual->expr->value.character.length = c;
+	      actual->expr->value.character.string = dest;
+	    }
+	}
 comp_tail->val = actual->expr;
 if (actual->expr != NULL)
 	comp_tail->where = actual->expr->where;
 actual->expr = NULL;

Mercurial > hg > CbC > CbC_gcc

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