2012-01-30 Pascal Obry <obry@adacore.com>

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

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index f7f0e05..38bcb27 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1,7 +1,7 @@
 /* Build up a list of intrinsic subroutines and functions for the
    name-resolution stage.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010
+   2009, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
@@ -51,7 +51,7 @@ sizing;
 
 enum klass
 { CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
-  CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
+  CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC };
 
 #define ACTUAL_NO      0
 #define ACTUAL_YES     1
@@ -1557,8 +1557,8 @@ add_functions (void)
 
   make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
 
-  add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
-            NULL, NULL, NULL,
+  add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO,
+            BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL,
             a, BT_COMPLEX, dd, REQUIRED);
 
   make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
@@ -1663,7 +1663,8 @@ add_functions (void)
 
   add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
             ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
-            gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
+            gfc_check_same_type_as, gfc_simplify_extends_type_of,
+            gfc_resolve_extends_type_of,
             a, BT_UNKNOWN, 0, REQUIRED,
             mo, BT_UNKNOWN, 0, REQUIRED);
 
@@ -2357,7 +2358,8 @@ add_functions (void)
 
   make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
 
-  add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+  add_sym_0 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
+            BT_INTEGER, di, GFC_STD_F2008,
             NULL, gfc_simplify_num_images, NULL);
 
   add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
@@ -2431,6 +2433,11 @@ add_functions (void)
 
   make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
 
+  add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
+            GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, NULL,
+            a, BT_REAL, dr, REQUIRED);
+  make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TS);
+
   add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
             gfc_check_real, gfc_simplify_real, gfc_resolve_real,
             a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
@@ -2481,7 +2488,7 @@ add_functions (void)
 
   add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
             BT_LOGICAL, dl, GFC_STD_F2003,
-            gfc_check_same_type_as, NULL, NULL,
+            gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
             a, BT_UNKNOWN, 0, REQUIRED,
             b, BT_UNKNOWN, 0, REQUIRED);
 
@@ -2540,9 +2547,10 @@ add_functions (void)
 
   make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
 
-  add_sym_1 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+  add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
             gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
-            src, BT_REAL, dr, REQUIRED);
+            src, BT_REAL, dr, REQUIRED,
+            kind, BT_INTEGER, di, OPTIONAL);
 
   make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
 
@@ -2586,7 +2594,7 @@ add_functions (void)
 
   add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
             di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal,
-            num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
+            num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED);
 
   make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
 
@@ -2872,6 +2880,18 @@ add_subroutines (void)
 
   make_noreturn();
 
+  add_sym_2s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
+             BT_UNKNOWN, 0, GFC_STD_F2008,
+             gfc_check_atomic_def, NULL, gfc_resolve_atomic_def,
+             "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+             "value", BT_INTEGER, di, REQUIRED, INTENT_IN);
+
+  add_sym_2s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
+             BT_UNKNOWN, 0, GFC_STD_F2008,
+             gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref,
+             "value", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+             "atom", BT_INTEGER, di, REQUIRED, INTENT_IN);
+
   add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
              GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
              tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
@@ -3405,9 +3425,9 @@ gfc_intrinsic_init_1 (void)
 void
 gfc_intrinsic_done_1 (void)
 {
-  gfc_free (functions);
-  gfc_free (conversion);
-  gfc_free (char_conversions);
+  free (functions);
+  free (conversion);
+  free (char_conversions);
   gfc_free_namespace (gfc_intrinsic_namespace);
 }
 
@@ -3622,7 +3642,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
                                 : NULL);
 
          /* No pointer arguments for intrinsics.  */
-         if (gfc_check_vardef_context (actual->expr, false, context)
+         if (gfc_check_vardef_context (actual->expr, false, false, context)
                == FAILURE)
            return FAILURE;
        }
@@ -3969,6 +3989,10 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
       symstd_msg = "new in Fortran 2008";
       break;
 
+    case GFC_STD_F2008_TS:
+      symstd_msg = "new in TS 29113";
+      break;
+
     case GFC_STD_GNU:
       symstd_msg = "a GNU Fortran extension";
       break;
@@ -4193,7 +4217,7 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
       c->resolved_sym->attr.elemental = isym->elemental;
     }
 
-  if (gfc_pure (NULL) && !isym->elemental)
+  if (gfc_pure (NULL) && !isym->pure)
     {
       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
                 &c->loc);
@@ -4365,7 +4389,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
 
   *expr = *new_expr;
 
-  gfc_free (new_expr);
+  free (new_expr);
   expr->ts = *ts;
 
   if (gfc_is_constant_expr (expr->value.function.actual->expr)
@@ -4434,7 +4458,7 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
 
   *expr = *new_expr;
 
-  gfc_free (new_expr);
+  free (new_expr);
   expr->ts = *ts;
 
   if (gfc_is_constant_expr (expr->value.function.actual->expr)