* trans-types.c (gfc_sym_type): Use pointer types for optional args.

[pf3gnuchains/gcc-fork.git] / gcc / fortran / primary.c

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index e1f4049..eb5dc33 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1,5 +1,5 @@
 /* Primary expression subroutines
-   Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GNU G95.
@@ -235,7 +235,7 @@ match_integer_constant (gfc_expr ** result, int signflag)
 static match
 match_boz_constant (gfc_expr ** result)
 {
-  int radix, delim, length;
+  int radix, delim, length, x_hex;
   locus old_loc;
   char *buffer;
   gfc_expr *e;
@@ -244,6 +244,7 @@ match_boz_constant (gfc_expr ** result)
   old_loc = gfc_current_locus;
   gfc_gobble_whitespace ();
 
+  x_hex = 0;
   switch (gfc_next_char ())
     {
     case 'b':
@@ -255,12 +256,7 @@ match_boz_constant (gfc_expr ** result)
       rname = "octal";
       break;
     case 'x':
-      if (pedantic
-         && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
-                            "constant at %C uses non-standard syntax.")
-             == FAILURE))
-       goto backup;
-
+      x_hex = 1;
       /* Fall through.  */
     case 'z':
       radix = 16;
@@ -310,6 +306,16 @@ match_boz_constant (gfc_expr ** result)
       return MATCH_ERROR;
     }
 
+  if (x_hex
+      && pedantic
+      && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
+                         "constant at %C uses non-standard syntax.")
+         == FAILURE))
+    {
+      gfc_free_expr (e);
+      return MATCH_ERROR;
+    }
+
   *result = e;
   return MATCH_YES;
 
@@ -430,7 +436,7 @@ done:
   buffer = alloca (count + 1);
   memset (buffer, '\0', count + 1);
 
-  /* Hack for mpf_init_set_str().  */
+  /* Hack for mpfr_set_str().  */
   p = buffer;
   while (count > 0)
     {
@@ -491,7 +497,7 @@ done:
     case ARITH_UNDERFLOW:
       if (gfc_option.warn_underflow)
         gfc_warning ("Real constant underflows its kind at %C");
-      mpf_set_ui(e->value.real, 0);
+      mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
       break;
 
     default:
@@ -1070,12 +1076,12 @@ done:
   buffer = alloca (count + 1);
   memset (buffer, '\0', count + 1);
 
-  /* Hack for mpf_init_set_str().  */
+  /* Hack for mpfr_set_str().  */
   p = buffer;
   while (count > 0)
     {
       c = gfc_next_char ();
-      if (c == 'd')
+      if (c == 'd' || c == 'q')
        c = 'e';
       *p++ = c;
       count--;
@@ -1400,7 +1406,8 @@ cleanup:
    the opening parenthesis to the closing parenthesis.  The argument
    list is assumed to allow keyword arguments because we don't know if
    the symbol associated with the procedure has an implicit interface
-   or not.  We make sure keywords are unique.  */
+   or not.  We make sure keywords are unique. If SUB_FLAG is set,
+   we're matching the argument list of a subroutine.  */
 
 match
 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
@@ -1839,13 +1846,13 @@ match
 gfc_match_rvalue (gfc_expr ** result)
 {
   gfc_actual_arglist *actual_arglist;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
   gfc_state_data *st;
   gfc_symbol *sym;
   gfc_symtree *symtree;
-  locus where;
+  locus where, old_loc;
   gfc_expr *e;
-  match m;
+  match m, m2;
   int i;
 
   m = gfc_match_name (name);
@@ -2044,35 +2051,46 @@ gfc_match_rvalue (gfc_expr ** result)
          break;
        }
 
-      /* See if this could possibly be a substring reference of a name
-         that we're not sure is a variable yet.  */
+      /* See if this is a function reference with a keyword argument
+        as first argument. We do this because otherwise a spurious
+        symbol would end up in the symbol table.  */
+
+      old_loc = gfc_current_locus;
+      m2 = gfc_match (" ( %n =", argname);
+      gfc_current_locus = old_loc;
 
       e = gfc_get_expr ();
       e->symtree = symtree;
 
-      if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
-         && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
+      if (m2 != MATCH_YES)
        {
+         /* See if this could possibly be a substring reference of a name
+            that we're not sure is a variable yet.  */
 
-         e->expr_type = EXPR_VARIABLE;
-
-         if (sym->attr.flavor != FL_VARIABLE
-             && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
+         if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
+             && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
            {
-             m = MATCH_ERROR;
-             break;
-           }
 
-         if (sym->ts.type == BT_UNKNOWN
-             && gfc_set_default_type (sym, 1, NULL) == FAILURE)
-           {
-             m = MATCH_ERROR;
+             e->expr_type = EXPR_VARIABLE;
+
+             if (sym->attr.flavor != FL_VARIABLE
+                 && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
+               {
+                 m = MATCH_ERROR;
+                 break;
+               }
+
+             if (sym->ts.type == BT_UNKNOWN
+                 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
+               {
+                 m = MATCH_ERROR;
+                 break;
+               }
+
+             e->ts = sym->ts;
+             m = MATCH_YES;
              break;
            }
-
-         e->ts = sym->ts;
-         m = MATCH_YES;
-         break;
        }
 
       /* Give up, assume we have a function.  */