2011-07-17 Tobias Burnus <burnus@net-b.de>

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

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 1d25cb0..4043df2 100644 (file)
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -316,6 +316,13 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
   tree type = TREE_TYPE (base);
   tree tmp;
 
+  if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
+    {
+      gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+
+      return fold_convert (TYPE_MAIN_VARIANT (type), base);
+    }
+
   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
   type = TREE_TYPE (type);
 
@@ -578,7 +585,8 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
       return newmem;
     }  */
 tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
+gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
+                         bool coarray_lib)
 {
   stmtblock_t alloc_block;
   tree res, tmp, msg, cond;
@@ -609,14 +617,32 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 
   /* The allocation itself.  */
   gfc_start_block (&alloc_block);
-  gfc_add_modify (&alloc_block, res,
-                 fold_convert (prvoid_type_node,
-                               build_call_expr_loc (input_location,
-                                  built_in_decls[BUILT_IN_MALLOC], 1,
-                                       fold_build2_loc (input_location,
-                                           MAX_EXPR, size_type_node, size,
-                                           build_int_cst (size_type_node,
-                                                          1)))));
+  if (coarray_lib)
+    {
+      gfc_add_modify (&alloc_block, res,
+             fold_convert (prvoid_type_node,
+                   build_call_expr_loc (input_location,
+                        gfor_fndecl_caf_register, 6,
+                        fold_build2_loc (input_location,
+                                 MAX_EXPR, size_type_node, size,
+                                 build_int_cst (size_type_node, 1)),
+                        build_int_cst (integer_type_node,
+                                       GFC_CAF_COARRAY_ALLOC),
+                        null_pointer_node,  /* token  */
+                        null_pointer_node,  /* stat  */
+                        null_pointer_node,  /* errmsg, errmsg_len  */
+                        build_int_cst (integer_type_node, 0))));
+    }
+  else
+    {
+      gfc_add_modify (&alloc_block, res,
+             fold_convert (prvoid_type_node,
+                   build_call_expr_loc (input_location,
+                        built_in_decls[BUILT_IN_MALLOC], 1,
+                        fold_build2_loc (input_location,
+                                 MAX_EXPR, size_type_node, size,
+                                 build_int_cst (size_type_node, 1)))));
+    }
 
   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
                             ("Allocation would exceed memory limit"));
@@ -651,13 +677,13 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 
 
 /* Generate code for an ALLOCATE statement when the argument is an
-   allocatable array.  If the array is currently allocated, it is an
+   allocatable variable.  If the variable is currently allocated, it is an
    error to allocate it again.
  
    This function follows the following pseudo-code:
   
     void *
-    allocate_array (void *mem, size_t size, integer_type *stat)
+    allocate_allocatable (void *mem, size_t size, integer_type *stat)
     {
       if (mem == NULL)
        return allocate (size, stat);
@@ -678,8 +704,8 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
     expr must be set to the original expression being allocated for its locus
     and variable name in case a runtime error has to be printed.  */
 tree
-gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
-                               tree status, gfc_expr* expr)
+gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
+                                     tree status, gfc_expr* expr)
 {
   stmtblock_t alloc_block;
   tree res, tmp, null_mem, alloc, error;
@@ -690,16 +716,21 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 
   /* Create a variable to hold the result.  */
   res = gfc_create_var (type, NULL);
-  null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
-                             build_int_cst (type, 0));
+  null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+                                           boolean_type_node, mem,
+                                           build_int_cst (type, 0)));
 
   /* If mem is NULL, we call gfc_allocate_with_status.  */
   gfc_start_block (&alloc_block);
-  tmp = gfc_allocate_with_status (&alloc_block, size, status);
+  tmp = gfc_allocate_with_status (&alloc_block, size, status,
+                                 gfc_option.coarray == GFC_FCOARRAY_LIB
+                                 && gfc_expr_attr (expr).codimension);
+
   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
   alloc = gfc_finish_block (&alloc_block);
 
-  /* Otherwise, we issue a runtime error or set the status variable.  */
+  /* If mem is not NULL, we issue a runtime error or set the
+     status variable.  */
   if (expr)
     {
       tree varname;
@@ -729,7 +760,7 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
                             fold_convert (pvoid_type_node, mem));
       gfc_add_expr_to_block (&set_status_block, tmp);
 
-      tmp = gfc_allocate_with_status (&set_status_block, size, status);
+      tmp = gfc_allocate_with_status (&set_status_block, size, status, false);
       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 
       gfc_add_modify (&set_status_block,
@@ -744,7 +775,7 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
     }
 
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
-                        alloc, error);
+                        error, alloc);
   gfc_add_expr_to_block (block, tmp);
 
   return res;
@@ -1238,15 +1269,20 @@ trans_code (gfc_code * code, tree cond)
             dependency check, too.  */
          {
            bool is_mvbits = false;
+
+           if (code->resolved_isym)
+             {
+               res = gfc_conv_intrinsic_subroutine (code);
+               if (res != NULL_TREE)
+                 break;
+             }
+
            if (code->resolved_isym
                && code->resolved_isym->id == GFC_ISYM_MVBITS)
              is_mvbits = true;
-           if (code->resolved_isym
-               && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
-             res = gfc_conv_intrinsic_move_alloc (code);
-           else
-             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
-                                   NULL_TREE, false);
+
+           res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+                                 NULL_TREE, false);
          }
          break;
 
@@ -1305,6 +1341,11 @@ trans_code (gfc_code * code, tree cond)
          res = gfc_trans_sync (code, code->op);
          break;
 
+       case EXEC_LOCK:
+       case EXEC_UNLOCK:
+         res = gfc_trans_lock_unlock (code, code->op);
+         break;
+
        case EXEC_FORALL:
          res = gfc_trans_forall (code);
          break;