/* Write a constant expression in binary form to a buffer.  */
int
gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
			size_t buffer_size)
{
  if (source == NULL)
    return 0;

  if (source->expr_type == EXPR_ARRAY)
    return encode_array (source, buffer, buffer_size);

  gcc_assert (source->expr_type == EXPR_CONSTANT
	      || source->expr_type == EXPR_STRUCTURE
	      || source->expr_type == EXPR_SUBSTRING);

  /* If we already have a target-memory representation, we use that rather 
     than recreating one.  */
  if (source->representation.string)
    {
      memcpy (buffer, source->representation.string,
	      source->representation.length);
      return source->representation.length;
    }

  switch (source->ts.type)
    {
    case BT_INTEGER:
      return encode_integer (source->ts.kind, source->value.integer, buffer,
			     buffer_size);
    case BT_REAL:
      return encode_float (source->ts.kind, source->value.real, buffer,
			   buffer_size);
    case BT_COMPLEX:
      return encode_complex (source->ts.kind, source->value.complex.r,
			     source->value.complex.i, buffer, buffer_size);
    case BT_LOGICAL:
      return encode_logical (source->ts.kind, source->value.logical, buffer,
			     buffer_size);
    case BT_CHARACTER:
      if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
	return encode_character (source->value.character.length,
			         source->value.character.string, buffer,
			         buffer_size);
      else
	{
	  int start, end;

	  gcc_assert (source->expr_type == EXPR_SUBSTRING);
	  gfc_extract_int (source->ref->u.ss.start, &start);
	  gfc_extract_int (source->ref->u.ss.end, &end);
	  return encode_character (MAX(end - start + 1, 0),
				   &source->value.character.string[start-1],
				   buffer, buffer_size);
	}
    case BT_DERIVED:
      return encode_derived (source, buffer, buffer_size);
    default:
      gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
      return 0;
    }
}
Beispiel #2
0
size_t
gfc_target_expr_size (gfc_expr *e)
{
  tree type;

  gcc_assert (e != NULL);

  if (e->expr_type == EXPR_ARRAY)
    return size_array (e);

  switch (e->ts.type)
    {
    case BT_INTEGER:
      return size_integer (e->ts.kind);
    case BT_REAL:
      return size_float (e->ts.kind);
    case BT_COMPLEX:
      return size_complex (e->ts.kind);
    case BT_LOGICAL:
      return size_logical (e->ts.kind);
    case BT_CHARACTER:
      if (e->expr_type == EXPR_SUBSTRING && e->ref)
        {
          int start, end;

          gfc_extract_int (e->ref->u.ss.start, &start);
          gfc_extract_int (e->ref->u.ss.end, &end);
          return size_character (MAX(end - start + 1, 0), e->ts.kind);
        }
      else
        return size_character (e->value.character.length, e->ts.kind);
    case BT_HOLLERITH:
      return e->representation.length;
    case BT_DERIVED:
      type = gfc_typenode_for_spec (&e->ts);
      return int_size_in_bytes (type);
    default:
      gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
      return 0;
    }
}
Beispiel #3
0
static gfc_expr *
create_character_intializer (gfc_expr * init, gfc_typespec * ts,
                             gfc_ref * ref, gfc_expr * rvalue)
{
    int len;
    int start;
    int end;
    char *dest;

    gfc_extract_int (ts->cl->length, &len);

    if (init == NULL)
    {
        /* Create a new initializer.  */
        init = gfc_get_expr ();
        init->expr_type = EXPR_CONSTANT;
        init->ts = *ts;

        dest = gfc_getmem (len + 1);
        dest[len] = '\0';
        init->value.character.length = len;
        init->value.character.string = dest;
        /* Blank the string if we're only setting a substring.  */
        if (ref != NULL)
            memset (dest, ' ', len);
    }
    else
        dest = init->value.character.string;

    if (ref)
    {
        gfc_expr *start_expr, *end_expr;

        gcc_assert (ref->type == REF_SUBSTRING);

        /* Only set a substring of the destination.  Fortran substring bounds
           are one-based [start, end], we want zero based [start, end).  */
        start_expr = gfc_copy_expr (ref->u.ss.start);
        end_expr = gfc_copy_expr (ref->u.ss.end);

        if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
                || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
        {
            gfc_error ("failure to simplify substring reference in DATA"
                       "statement at %L", &ref->u.ss.start->where);
            return NULL;
        }

        gfc_extract_int (start_expr, &start);
        start--;
        gfc_extract_int (end_expr, &end);
    }
    else
    {
        /* Set the whole string.  */
        start = 0;
        end = len;
    }

    /* Copy the initial value.  */
    len = rvalue->value.character.length;
    if (len > end - start)
    {
        len = end - start;
        gfc_warning_now ("initialization string truncated to match variable "
                         "at %L", &rvalue->where);
    }

    memcpy (&dest[start], rvalue->value.character.string, len);

    /* Pad with spaces.  Substrings will already be blanked.  */
    if (len < end - start && ref == NULL)
        memset (&dest[start + len], ' ', end - (start + len));

    if (rvalue->ts.type == BT_HOLLERITH)
        init->from_H = 1;

    return init;
}
Beispiel #4
0
static gfc_expr *
create_character_initializer (gfc_expr *init, gfc_typespec *ts,
			      gfc_ref *ref, gfc_expr *rvalue)
{
  int len, start, end, tlen;
  gfc_char_t *dest;
  bool alloced_init = false;
	    
  gfc_extract_int (ts->u.cl->length, &len);

  if (init == NULL)
    {
      /* Create a new initializer.  */
      init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
      init->ts = *ts;
      alloced_init = true;
    }

  dest = init->value.character.string;

  if (ref)
    {
      gfc_expr *start_expr, *end_expr;

      gcc_assert (ref->type == REF_SUBSTRING);

      /* Only set a substring of the destination.  Fortran substring bounds
	 are one-based [start, end], we want zero based [start, end).  */
      start_expr = gfc_copy_expr (ref->u.ss.start);
      end_expr = gfc_copy_expr (ref->u.ss.end);

      if ((!gfc_simplify_expr(start_expr, 1))
	  || !(gfc_simplify_expr(end_expr, 1)))
	{
	  gfc_error ("failure to simplify substring reference in DATA "
		     "statement at %L", &ref->u.ss.start->where);
	  gfc_free_expr (start_expr);
	  gfc_free_expr (end_expr);
	  if (alloced_init)
	    gfc_free_expr (init);
	  return NULL;
	}

      gfc_extract_int (start_expr, &start);
      gfc_free_expr (start_expr);
      start--;
      gfc_extract_int (end_expr, &end);
      gfc_free_expr (end_expr);
    }
  else
    {
      /* Set the whole string.  */
      start = 0;
      end = len;
    }

  /* Copy the initial value.  */
  if (rvalue->ts.type == BT_HOLLERITH)
    len = rvalue->representation.length - rvalue->ts.u.pad;
  else
    len = rvalue->value.character.length;

  tlen = end - start;
  if (len > tlen)
    {
      if (tlen < 0)
	{
	  gfc_warning_now (0, "Unused initialization string at %L because "
			   "variable has zero length", &rvalue->where);
	  len = 0;
	}
      else
	{
	  gfc_warning_now (0, "Initialization string at %L was truncated to "
			   "fit the variable (%d/%d)", &rvalue->where,
			   tlen, len);
	  len = tlen;
	}
    }

  if (rvalue->ts.type == BT_HOLLERITH)
    {
      int i;
      for (i = 0; i < len; i++)
	dest[start+i] = rvalue->representation.string[i];
    }
  else
    memcpy (&dest[start], rvalue->value.character.string,
	    len * sizeof (gfc_char_t));

  /* Pad with spaces.  Substrings will already be blanked.  */
  if (len < tlen && ref == NULL)
    gfc_wide_memset (&dest[start + len], ' ', end - (start + len));

  if (rvalue->ts.type == BT_HOLLERITH)
    {
      init->representation.length = init->value.character.length;
      init->representation.string
	= gfc_widechar_to_char (init->value.character.string,
				init->value.character.length);
    }

  return init;
}
Beispiel #5
0
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
{
  gfc_omp_clauses *c = gfc_get_omp_clauses ();
  locus old_loc;
  bool needs_space = true, first = true;

  *cp = NULL;
  while (1)
    {
      if ((first || gfc_match_char (',') != MATCH_YES)
	  && (needs_space && gfc_match_space () != MATCH_YES))
	break;
      needs_space = false;
      first = false;
      gfc_gobble_whitespace ();
      if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
	  && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
	  && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_PRIVATE)
	  && gfc_match_omp_variable_list ("private (",
					  &c->lists[OMP_LIST_PRIVATE], true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
	  && gfc_match_omp_variable_list ("firstprivate (",
					  &c->lists[OMP_LIST_FIRSTPRIVATE],
					  true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_LASTPRIVATE)
	  && gfc_match_omp_variable_list ("lastprivate (",
					  &c->lists[OMP_LIST_LASTPRIVATE],
					  true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_COPYPRIVATE)
	  && gfc_match_omp_variable_list ("copyprivate (",
					  &c->lists[OMP_LIST_COPYPRIVATE],
					  true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_SHARED)
	  && gfc_match_omp_variable_list ("shared (",
					  &c->lists[OMP_LIST_SHARED], true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_COPYIN)
	  && gfc_match_omp_variable_list ("copyin (",
					  &c->lists[OMP_LIST_COPYIN], true)
	     == MATCH_YES)
	continue;
      old_loc = gfc_current_locus;
      if ((mask & OMP_CLAUSE_REDUCTION)
	  && gfc_match ("reduction ( ") == MATCH_YES)
	{
	  int reduction = OMP_LIST_NUM;
	  char buffer[GFC_MAX_SYMBOL_LEN + 1];
	  if (gfc_match_char ('+') == MATCH_YES)
	    reduction = OMP_LIST_PLUS;
	  else if (gfc_match_char ('*') == MATCH_YES)
	    reduction = OMP_LIST_MULT;
	  else if (gfc_match_char ('-') == MATCH_YES)
	    reduction = OMP_LIST_SUB;
	  else if (gfc_match (".and.") == MATCH_YES)
	    reduction = OMP_LIST_AND;
	  else if (gfc_match (".or.") == MATCH_YES)
	    reduction = OMP_LIST_OR;
	  else if (gfc_match (".eqv.") == MATCH_YES)
	    reduction = OMP_LIST_EQV;
	  else if (gfc_match (".neqv.") == MATCH_YES)
	    reduction = OMP_LIST_NEQV;
	  else if (gfc_match_name (buffer) == MATCH_YES)
	    {
	      gfc_symbol *sym;
	      const char *n = buffer;

	      gfc_find_symbol (buffer, NULL, 1, &sym);
	      if (sym != NULL)
		{
		  if (sym->attr.intrinsic)
		    n = sym->name;
		  else if ((sym->attr.flavor != FL_UNKNOWN
			    && sym->attr.flavor != FL_PROCEDURE)
			   || sym->attr.external
			   || sym->attr.generic
			   || sym->attr.entry
			   || sym->attr.result
			   || sym->attr.dummy
			   || sym->attr.subroutine
			   || sym->attr.pointer
			   || sym->attr.target
			   || sym->attr.cray_pointer
			   || sym->attr.cray_pointee
			   || (sym->attr.proc != PROC_UNKNOWN
			       && sym->attr.proc != PROC_INTRINSIC)
			   || sym->attr.if_source != IFSRC_UNKNOWN
			   || sym == sym->ns->proc_name)
		    {
		      gfc_error_now ("%s is not INTRINSIC procedure name "
				     "at %C", buffer);
		      sym = NULL;
		    }
		  else
		    n = sym->name;
		}
	      if (strcmp (n, "max") == 0)
		reduction = OMP_LIST_MAX;
	      else if (strcmp (n, "min") == 0)
		reduction = OMP_LIST_MIN;
	      else if (strcmp (n, "iand") == 0)
		reduction = OMP_LIST_IAND;
	      else if (strcmp (n, "ior") == 0)
		reduction = OMP_LIST_IOR;
	      else if (strcmp (n, "ieor") == 0)
		reduction = OMP_LIST_IEOR;
	      if (reduction != OMP_LIST_NUM
		  && sym != NULL
		  && ! sym->attr.intrinsic
		  && ! sym->attr.use_assoc
		  && ((sym->attr.flavor == FL_UNKNOWN
		       && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
					  sym->name, NULL) == FAILURE)
		      || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
		{
		  gfc_free_omp_clauses (c);
		  return MATCH_ERROR;
		}
	    }
	  if (reduction != OMP_LIST_NUM
	      && gfc_match_omp_variable_list (" :", &c->lists[reduction],
					      false)
		 == MATCH_YES)
	    continue;
	  else
	    gfc_current_locus = old_loc;
	}
      if ((mask & OMP_CLAUSE_DEFAULT)
	  && c->default_sharing == OMP_DEFAULT_UNKNOWN)
	{
	  if (gfc_match ("default ( shared )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_SHARED;
	  else if (gfc_match ("default ( private )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_PRIVATE;
	  else if (gfc_match ("default ( none )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_NONE;
	  else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
	  if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
	    continue;
	}
      old_loc = gfc_current_locus;
      if ((mask & OMP_CLAUSE_SCHEDULE)
	  && c->sched_kind == OMP_SCHED_NONE
	  && gfc_match ("schedule ( ") == MATCH_YES)
	{
	  if (gfc_match ("static") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_STATIC;
	  else if (gfc_match ("dynamic") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_DYNAMIC;
	  else if (gfc_match ("guided") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_GUIDED;
	  else if (gfc_match ("runtime") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_RUNTIME;
	  else if (gfc_match ("auto") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_AUTO;
	  if (c->sched_kind != OMP_SCHED_NONE)
	    {
	      match m = MATCH_NO;
	      if (c->sched_kind != OMP_SCHED_RUNTIME
		  && c->sched_kind != OMP_SCHED_AUTO)
		m = gfc_match (" , %e )", &c->chunk_size);
	      if (m != MATCH_YES)
		m = gfc_match_char (')');
	      if (m != MATCH_YES)
		c->sched_kind = OMP_SCHED_NONE;
	    }
	  if (c->sched_kind != OMP_SCHED_NONE)
	    continue;
	  else
	    gfc_current_locus = old_loc;
	}
      if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
	  && gfc_match ("ordered") == MATCH_YES)
	{
	  c->ordered = needs_space = true;
	  continue;
	}
      if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
	  && gfc_match ("untied") == MATCH_YES)
	{
	  c->untied = needs_space = true;
	  continue;
	}
      if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
	{
	  gfc_expr *cexpr = NULL;
	  match m = gfc_match ("collapse ( %e )", &cexpr);

	  if (m == MATCH_YES)
	    {
	      int collapse;
	      const char *p = gfc_extract_int (cexpr, &collapse);
	      if (p)
		{
		  gfc_error_now (p);
		  collapse = 1;
		}
	      else if (collapse <= 0)
		{
		  gfc_error_now ("COLLAPSE clause argument not"
				 " constant positive integer at %C");
		  collapse = 1;
		}
	      c->collapse = collapse;
	      gfc_free_expr (cexpr);
	      continue;
	    }
	}

      break;
    }

  if (gfc_match_omp_eos () != MATCH_YES)
    {
      gfc_free_omp_clauses (c);
      return MATCH_ERROR;
    }

  *cp = c;
  return MATCH_YES;
}