primary.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

/* Primary expression subroutines
   Copyright (C) 2000, 2001, 2002, 2004, 2005 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
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.

GCC 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 GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h"

/* Matches a kind-parameter expression, which is either a named
   symbolic constant or a nonnegative integer constant.  If
   successful, sets the kind value to the correct integer.  */

static match
match_kind_param (int *kind)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  const char *p;
  match m;
  int cnt;

  /* cnt is unused, here.  */
  m = gfc_match_small_literal_int (kind, &cnt);
  if (m != MATCH_NO)
    return m;

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    return m;

  if (gfc_find_symbol (name, NULL, 1, &sym))
    return MATCH_ERROR;

  if (sym == NULL)
    return MATCH_NO;

  if (sym->attr.flavor != FL_PARAMETER)
    return MATCH_NO;

  p = gfc_extract_int (sym->value, kind);
  if (p != NULL)
    return MATCH_NO;

  if (*kind < 0)
    return MATCH_NO;

  return MATCH_YES;
}


/* Get a trailing kind-specification for non-character variables.
   Returns:
      the integer kind value or:
      -1 if an error was generated
      -2 if no kind was found */

static int
get_kind (void)
{
  int kind;
  match m;

  if (gfc_match_char ('_') != MATCH_YES)
    return -2;

  m = match_kind_param (&kind);
  if (m == MATCH_NO)
    gfc_error ("Missing kind-parameter at %C");

  return (m == MATCH_YES) ? kind : -1;
}


/* Given a character and a radix, see if the character is a valid
   digit in that radix.  */

static int
check_digit (int c, int radix)
{
  int r;

  switch (radix)
    {
    case 2:
      r = ('0' <= c && c <= '1');
      break;

    case 8:
      r = ('0' <= c && c <= '7');
      break;

    case 10:
      r = ('0' <= c && c <= '9');
      break;

    case 16:
      r = ISXDIGIT (c);
      break;

    default:
      gfc_internal_error ("check_digit(): bad radix");
    }

  return r;
}


/* Match the digit string part of an integer if signflag is not set,
   the signed digit string part if signflag is set.  If the buffer 
   is NULL, we just count characters for the resolution pass.  Returns 
   the number of characters matched, -1 for no match.  */

static int
match_digits (int signflag, int radix, char *buffer)
{
  locus old_loc;
  int length, c;

  length = 0;
  c = gfc_next_char ();

  if (signflag && (c == '+' || c == '-'))
    {
      if (buffer != NULL)
	*buffer++ = c;
      gfc_gobble_whitespace ();
      c = gfc_next_char ();
      length++;
    }

  if (!check_digit (c, radix))
    return -1;

  length++;
  if (buffer != NULL)
    *buffer++ = c;

  for (;;)
    {
      old_loc = gfc_current_locus;
      c = gfc_next_char ();

      if (!check_digit (c, radix))
	break;

      if (buffer != NULL)
	*buffer++ = c;
      length++;
    }

  gfc_current_locus = old_loc;

  return length;
}


/* Match an integer (digit string and optional kind).  
   A sign will be accepted if signflag is set.  */

static match
match_integer_constant (gfc_expr ** result, int signflag)
{
  int length, kind;
  locus old_loc;
  char *buffer;
  gfc_expr *e;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  length = match_digits (signflag, 10, NULL);
  gfc_current_locus = old_loc;
  if (length == -1)
    return MATCH_NO;

  buffer = alloca (length + 1);
  memset (buffer, '\0', length + 1);

  gfc_gobble_whitespace ();

  match_digits (signflag, 10, buffer);

  kind = get_kind ();
  if (kind == -2)
    kind = gfc_default_integer_kind;
  if (kind == -1)
    return MATCH_ERROR;

  if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
    {
      gfc_error ("Integer kind %d at %C not available", kind);
      return MATCH_ERROR;
    }

  e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);

  if (gfc_range_check (e) != ARITH_OK)
    {
      gfc_error ("Integer too big for its kind at %C");

      gfc_free_expr (e);
      return MATCH_ERROR;
    }

  *result = e;
  return MATCH_YES;
}


/* Match a Hollerith constant.  */

static match
match_hollerith_constant (gfc_expr ** result)
{
  locus old_loc;
  gfc_expr * e = NULL;
  const char * msg;
  char * buffer;
  int num;
  int i;  

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  if (match_integer_constant (&e, 0) == MATCH_YES
	&& gfc_match_char ('h') == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_LEGACY,
		"Extension: Hollerith constant at %C")
		== FAILURE)
	goto cleanup;

      msg = gfc_extract_int (e, &num);
      if (msg != NULL)
	{
	  gfc_error (msg);
	  goto cleanup;
	}
      if (num == 0)
	{
	  gfc_error ("Invalid Hollerith constant: %L must contain at least one "
			"character", &old_loc);
	  goto cleanup;
	}
      if (e->ts.kind != gfc_default_integer_kind)
	{
	  gfc_error ("Invalid Hollerith constant: Interger kind at %L "
		"should be default", &old_loc);
	  goto cleanup;
	}
      else
	{
	  buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
	  for (i = 0; i < num; i++)
	    {
	      buffer[i] = gfc_next_char_literal (1);
	    }
	  gfc_free_expr (e);
	  e = gfc_constant_result (BT_HOLLERITH,
		gfc_default_character_kind, &gfc_current_locus);
	  e->value.character.string = gfc_getmem (num+1);
	  memcpy (e->value.character.string, buffer, num);
	  e->value.character.length = num;
	  *result = e;
	  return MATCH_YES;
	}
    }

  gfc_free_expr (e);
  gfc_current_locus = old_loc;
  return MATCH_NO;

cleanup:
  gfc_free_expr (e);
  return MATCH_ERROR;
}


/* Match a binary, octal or hexadecimal constant that can be found in
   a DATA statement.  The standard permits b'010...', o'73...', and
   z'a1...' where b, o, and z can be capital letters.  This function
   also accepts postfixed forms of the constants: '01...'b, '73...'o,
   and 'a1...'z.  An additional extension is the use of x for z.  */

static match
match_boz_constant (gfc_expr ** result)
{
  int post, radix, delim, length, x_hex, kind;
  locus old_loc, start_loc;
  char *buffer;
  gfc_expr *e;

  start_loc = old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  x_hex = 0;
  switch (post = gfc_next_char ())
    {
    case 'b':
      radix = 2;
      post = 0;
      break;
    case 'o':
      radix = 8;
      post = 0;
      break;
    case 'x':
      x_hex = 1;
      /* Fall through.  */
    case 'z':
      radix = 16;
      post = 0;
      break;
    case '\'':
      /* Fall through.  */
    case '\"':
      delim = post;
      post = 1;
      radix = 16;  /* Set to accept any valid digit string.  */
      break;
    default:
      goto backup;
    }

  /* No whitespace allowed here.  */

  if (post == 0)
    delim = gfc_next_char ();

  if (delim != '\'' && delim != '\"')
    goto backup;

  if (x_hex && pedantic
      && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
			  "constant at %C uses non-standard syntax.")
	  == FAILURE))
      return MATCH_ERROR;

  old_loc = gfc_current_locus;

  length = match_digits (0, radix, NULL);
  if (length == -1)
    {
      gfc_error ("Empty set of digits in BOZ constant at %C");
      return MATCH_ERROR;
    }

  if (gfc_next_char () != delim)
    {
      gfc_error ("Illegal character in BOZ constant at %C");
      return MATCH_ERROR;
    }

  if (post == 1)
    {
      switch (gfc_next_char ())
	{
	case 'b':
	  radix = 2;
	  break;
	case 'o':
	  radix = 8;
	  break;
	case 'x':
	  /* Fall through.  */
	case 'z':
	  radix = 16;
	  break;
	default:
	  goto backup;
	}
	gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
			"at %C uses non-standard postfix syntax.");
    }

  gfc_current_locus = old_loc;

  buffer = alloca (length + 1);
  memset (buffer, '\0', length + 1);

  match_digits (0, radix, buffer);
  gfc_next_char ();    /* Eat delimiter.  */
  if (post == 1)
    gfc_next_char ();  /* Eat postfixed b, o, z, or x.  */

  /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
     "If a data-stmt-constant is a boz-literal-constant, the corresponding
     variable shall be of type integer.  The boz-literal-constant is treated
     as if it were an int-literal-constant with a kind-param that specifies
     the representation method with the largest decimal exponent range
     supported by the processor."  */

  kind = gfc_max_integer_kind;
  e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);

  if (gfc_range_check (e) != ARITH_OK)
    {
      gfc_error ("Integer too big for integer kind %i at %C", kind);
      gfc_free_expr (e);
      return MATCH_ERROR;
    }

  *result = e;
  return MATCH_YES;

backup:
  gfc_current_locus = start_loc;
  return MATCH_NO;
}


/* Match a real constant of some sort.  Allow a signed constant if signflag
   is nonzero.  Allow integer constants if allow_int is true.  */

static match
match_real_constant (gfc_expr ** result, int signflag)
{
  int kind, c, count, seen_dp, seen_digits, exp_char;
  locus old_loc, temp_loc;
  char *p, *buffer;
  gfc_expr *e;
  bool negate;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  e = NULL;

  count = 0;
  seen_dp = 0;
  seen_digits = 0;
  exp_char = ' ';
  negate = FALSE;

  c = gfc_next_char ();
  if (signflag && (c == '+' || c == '-'))
    {
      if (c == '-')
	negate = TRUE;

      gfc_gobble_whitespace ();
      c = gfc_next_char ();
    }

  /* Scan significand.  */
  for (;; c = gfc_next_char (), count++)
    {
      if (c == '.')
	{
	  if (seen_dp)
	    goto done;

	  /* Check to see if "." goes with a following operator like ".eq.".  */
	  temp_loc = gfc_current_locus;
	  c = gfc_next_char ();

	  if (c == 'e' || c == 'd' || c == 'q')
	    {
	      c = gfc_next_char ();
	      if (c == '.')
		goto done;	/* Operator named .e. or .d.  */
	    }

	  if (ISALPHA (c))
	    goto done;		/* Distinguish 1.e9 from 1.eq.2 */

	  gfc_current_locus = temp_loc;
	  seen_dp = 1;
	  continue;
	}

      if (ISDIGIT (c))
	{
	  seen_digits = 1;
	  continue;
	}

      break;
    }

  if (!seen_digits
      || (c != 'e' && c != 'd' && c != 'q'))
    goto done;
  exp_char = c;

  /* Scan exponent.  */
  c = gfc_next_char ();
  count++;

  if (c == '+' || c == '-')
    {				/* optional sign */
      c = gfc_next_char ();
      count++;
    }

  if (!ISDIGIT (c))
    {
      gfc_error ("Missing exponent in real number at %C");
      return MATCH_ERROR;
    }

  while (ISDIGIT (c))
    {
      c = gfc_next_char ();
      count++;
    }

done:
  /* Check that we have a numeric constant.  */
  if (!seen_digits || (!seen_dp && exp_char == ' '))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  /* Convert the number.  */
  gfc_current_locus = old_loc;
  gfc_gobble_whitespace ();

  buffer = alloca (count + 1);
  memset (buffer, '\0', count + 1);

  p = buffer;
  c = gfc_next_char ();
  if (c == '+' || c == '-')
    {
      gfc_gobble_whitespace ();
      c = gfc_next_char ();
    }

  /* Hack for mpfr_set_str().  */
  for (;;)
    {
      if (c == 'd' || c == 'q')
	*p = 'e';
      else
	*p = c;
      p++;
      if (--count == 0)
	break;

      c = gfc_next_char ();
    }

  kind = get_kind ();
  if (kind == -1)
    goto cleanup;

  switch (exp_char)
    {
    case 'd':
      if (kind != -2)
	{
	  gfc_error
	    ("Real number at %C has a 'd' exponent and an explicit kind");
	  goto cleanup;
	}
      kind = gfc_default_double_kind;
      break;

    case 'q':
      if (kind != -2)
	{
	  gfc_error