[gcc] GCC 4.5.0=>4.5.1

gcc/gcc/fortran/trans.c

 /* Code translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
-   Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
    Contributed by Paul Brook
 
 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 3, or (at your option) any later
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
@@ skipping 26 matching lines @@
 /* Naming convention for backend interface code:
 
    gfc_trans_*  translate gfc_code into STMT trees.
 
    gfc_conv_*   expression conversion
 
    gfc_get_*    get a backend tree representation of a decl or type  */
 
 static gfc_file *gfc_current_backend_file;
 
-const char gfc_msg_bounds[] = N_("Array bound mismatch");
 const char gfc_msg_fault[] = N_("Array reference out of bounds");
 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
 
 
 /* Advance along TREE_CHAIN n times.  */
 
 tree
 gfc_advance_chain (tree t, int n)
 {
   for (; n > 0; n--)
@@ skipping 91 matching lines @@
 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.  
    A MODIFY_EXPR is an assignment:
    LHS <- RHS.  */
 
 void
 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
 {
   tree tmp;
 
 #ifdef ENABLE_CHECKING
+  tree t1, t2;
+  t1 = TREE_TYPE (rhs);
+  t2 = TREE_TYPE (lhs);
   /* Make sure that the types of the rhs and the lhs are the same
      for scalar assignments.  We should probably have something
      similar for aggregates, but right now removing that check just
      breaks everything.  */
-  gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
+  gcc_assert (t1 == t2
               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 #endif
 
   tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
   gfc_add_expr_to_block (pblock, tmp);
 }
 
 
 /* Create a new scope/binding level and initialize a block.  Care must be
    taken when translating expressions as any temporaries will be placed in
@@ skipping 54 matching lines @@
 
 tree
 gfc_finish_block (stmtblock_t * stmtblock)
 {
   tree decl;
   tree expr;
   tree block;
 
   expr = stmtblock->head;
   if (!expr)
-    expr = build_empty_stmt ();
+    expr = build_empty_stmt (input_location);
 
   stmtblock->head = NULL_TREE;
 
   if (stmtblock->has_scope)
     {
       decl = getdecls ();
 
       if (decl)
         {
           block = poplevel (1, 0, 0);
@@ skipping 34 matching lines @@
 
   if (TREE_CODE (t) == INDIRECT_REF)
     {
       if (!type)
         type = natural_type;
       t = TREE_OPERAND (t, 0);
       natural_type = TREE_TYPE (t);
     }
   else
     {
-      if (DECL_P (t))
-        TREE_ADDRESSABLE (t) = 1;
+      tree base = get_base_address (t);
+      if (base && DECL_P (base))
+        TREE_ADDRESSABLE (base) = 1;
       t = fold_build1 (ADDR_EXPR, natural_type, t);
     }
 
   if (type && natural_type != type)
     t = convert (type, t);
 
   return t;
 }
 
 
@@ skipping 23 matching lines @@
         && GFC_DECL_SUBREF_ARRAY_P (decl)
         && !integer_zerop (GFC_DECL_SPAN(decl)))
     {
       offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
                             offset, GFC_DECL_SPAN(decl));
       tmp = gfc_build_addr_expr (pvoid_type_node, base);
       tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
                          tmp, fold_convert (sizetype, offset));
       tmp = fold_convert (build_pointer_type (type), tmp);
       if (!TYPE_STRING_FLAG (type))
-        tmp = build_fold_indirect_ref (tmp);
+        tmp = build_fold_indirect_ref_loc (input_location, tmp);
       return tmp;
     }
   else
     /* Otherwise use a straightforward array reference.  */
     return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 }
 
 
 /* Generate a call to print a runtime error possibly including multiple
    arguments and a locus.  */
@@ skipping 53 matching lines @@
 
   /* Build the argument array.  */
   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
   argarray[0] = arg;
   argarray[1] = arg2;
   for (i = 0; i < nargs; i++)
     argarray[2 + i] = va_arg (ap, tree);
   va_end (ap);
   
   /* Build the function call to runtime_(warning,error)_at; because of the
-     variable number of arguments, we can't use build_call_expr directly.  */
+     variable number of arguments, we can't use build_call_expr_loc dinput_location,
+     irectly.  */
   if (error)
     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
   else
     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
 
-  tmp = fold_builtin_call_array (TREE_TYPE (fntype),
+  tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),
                                  fold_build1 (ADDR_EXPR,
                                               build_pointer_type (fntype),
                                               error
                                               ? gfor_fndecl_runtime_error_at
                                               : gfor_fndecl_runtime_warning_at),
                                  nargs + 2, argarray);
   gfc_add_expr_to_block (&block, tmp);
 
   return gfc_finish_block (&block);
 }
@@ skipping 42 matching lines @@
   else
     {
       /* Tell the compiler that this isn't likely.  */
       if (once)
         cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
                             cond);
       else
         cond = fold_convert (long_integer_type_node, cond);
 
       tmp = build_int_cst (long_integer_type_node, 0);
-      cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+      cond = build_call_expr_loc (input_location,
+                              built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
       cond = fold_convert (boolean_type_node, cond);
 
-      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
+      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
       gfc_add_expr_to_block (pblock, tmp);
     }
 }
 
 
 /* Call malloc to allocate size bytes of memory, with special conditions:
-      + if size < 0, generate a runtime error,
-      + if size == 0, return a malloced area of size 1,
+      + if size <= 0, return a malloced area of size 1,
       + if malloc returns NULL, issue a runtime error.  */
 tree
 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 {
-  tree tmp, msg, negative, malloc_result, null_result, res;
+  tree tmp, msg, malloc_result, null_result, res;
   stmtblock_t block2;
 
   size = gfc_evaluate_now (size, block);
 
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
     size = fold_convert (size_type_node, size);
 
   /* Create a variable to hold the result.  */
-  res = gfc_create_var (pvoid_type_node, NULL);
+  res = gfc_create_var (prvoid_type_node, NULL);
 
-  /* size < 0 ?  */
-  negative = fold_build2 (LT_EXPR, boolean_type_node, size,
-                          build_int_cst (size_type_node, 0));
-  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
-      ("Attempt to allocate a negative amount of memory."));
-  tmp = fold_build3 (COND_EXPR, void_type_node, negative,
-                     build_call_expr (gfor_fndecl_runtime_error, 1, msg),
-                     build_empty_stmt ());
-  gfc_add_expr_to_block (block, tmp);
-
-  /* Call malloc and check the result.  */
+  /* Call malloc.  */
   gfc_start_block (&block2);
 
   size = fold_build2 (MAX_EXPR, size_type_node, size,
                       build_int_cst (size_type_node, 1));
 
   gfc_add_modify (&block2, res,
-                       build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
-                       size));
-  null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
-                             build_int_cst (pvoid_type_node, 0));
-  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
-      ("Memory allocation failed"));
-  tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
-                     build_call_expr (gfor_fndecl_os_error, 1, msg),
-                     build_empty_stmt ());
-  gfc_add_expr_to_block (&block2, tmp);
+                  fold_convert (prvoid_type_node,
+                                build_call_expr_loc (input_location,
+                                   built_in_decls[BUILT_IN_MALLOC], 1, size)));
+
+  /* Optionally check whether malloc was successful.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
+    {
+      null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
+                                 build_int_cst (pvoid_type_node, 0));
+      msg = gfc_build_addr_expr (pchar_type_node,
+              gfc_build_localized_cstring_const ("Memory allocation failed"));
+      tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
+              build_call_expr_loc (input_location,
+                                   gfor_fndecl_os_error, 1, msg),
+                                   build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block2, tmp);
+    }
+
   malloc_result = gfc_finish_block (&block2);
 
   gfc_add_expr_to_block (block, malloc_result);
 
   if (type != NULL)
     res = fold_convert (type, res);
   return res;
 }
 
+
 /* Allocate memory, using an optional status argument.
  
    This function follows the following pseudo-code:
 
     void *
     allocate (size_t size, integer_type* stat)
     {
       void *newmem;
     
       if (stat)
@@ skipping 31 matching lines @@
   stmtblock_t alloc_block;
   tree res, tmp, error, msg, cond;
   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 
   /* Evaluate size only once, and make sure it has the right type.  */
   size = gfc_evaluate_now (size, block);
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
     size = fold_convert (size_type_node, size);
 
   /* Create a variable to hold the result.  */
-  res = gfc_create_var (pvoid_type_node, NULL);
+  res = gfc_create_var (prvoid_type_node, NULL);
 
   /* Set the optional status variable to zero.  */
   if (status != NULL_TREE && !integer_zerop (status))
     {
       tmp = fold_build2 (MODIFY_EXPR, status_type,
                          fold_build1 (INDIRECT_REF, status_type, status),
                          build_int_cst (status_type, 0));
       tmp = fold_build3 (COND_EXPR, void_type_node,
-                         fold_build2 (NE_EXPR, boolean_type_node,
-                                      status, build_int_cst (status_type, 0)),
-                         tmp, build_empty_stmt ());
+                         fold_build2 (NE_EXPR, boolean_type_node, status,
+                                      build_int_cst (TREE_TYPE (status), 0)),
+                         tmp, build_empty_stmt (input_location));
       gfc_add_expr_to_block (block, tmp);
     }
 
   /* Generate the block of code handling (size < 0).  */
   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
                         ("Attempt to allocate negative amount of memory. "
                          "Possible integer overflow"));
-  error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+  error = build_call_expr_loc (input_location,
+                           gfor_fndecl_runtime_error, 1, msg);
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
       /* Set the status variable if it's present.  */
       stmtblock_t set_status_block;
 
       gfc_start_block (&set_status_block);
       gfc_add_modify (&set_status_block,
-                           fold_build1 (INDIRECT_REF, status_type, status),
+                      fold_build1 (INDIRECT_REF, status_type, status),
                            build_int_cst (status_type, LIBERROR_ALLOCATION));
       gfc_add_modify (&set_status_block, res,
-                           build_int_cst (pvoid_type_node, 0));
+                           build_int_cst (prvoid_type_node, 0));
 
       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
-                         build_int_cst (status_type, 0));
+                         build_int_cst (TREE_TYPE (status), 0));
       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
                            gfc_finish_block (&set_status_block));
     }
 
   /* The allocation itself.  */
   gfc_start_block (&alloc_block);
   gfc_add_modify (&alloc_block, res,
-                       build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
+                  fold_convert (prvoid_type_node,
+                                build_call_expr_loc (input_location,
+                                   built_in_decls[BUILT_IN_MALLOC], 1,
                                         fold_build2 (MAX_EXPR, size_type_node,
                                                      size,
-                                                     build_int_cst (size_type_node, 1))));
+                                                     build_int_cst (size_type_node, 1)))));
 
   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
                                                 ("Out of memory"));
-  tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
+  tmp = build_call_expr_loc (input_location,
+                         gfor_fndecl_os_error, 1, msg);
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
       /* Set the status variable if it's present.  */
       tree tmp2;
 
       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
-                          build_int_cst (status_type, 0));
+                          build_int_cst (TREE_TYPE (status), 0));
       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
                           fold_build1 (INDIRECT_REF, status_type, status),
                           build_int_cst (status_type, LIBERROR_ALLOCATION));
       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
                          tmp2);
     }
 
   tmp = fold_build3 (COND_EXPR, void_type_node,
                      fold_build2 (EQ_EXPR, boolean_type_node, res,
-                                  build_int_cst (pvoid_type_node, 0)),
-                     tmp, build_empty_stmt ());
+                                  build_int_cst (prvoid_type_node, 0)),
+                     tmp, build_empty_stmt (input_location));
   gfc_add_expr_to_block (&alloc_block, tmp);
 
   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
                       build_int_cst (TREE_TYPE (size), 0));
   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
                      gfc_finish_block (&alloc_block));
   gfc_add_expr_to_block (block, tmp);
 
   return res;
 }
@@ skipping 14 matching lines @@
       {
         if (stat)
         {
           free (mem);
           mem = allocate (size, stat);
           *stat = LIBERROR_ALLOCATION;
           return mem;
         }
         else
           runtime_error ("Attempting to allocate already allocated array");
+      }
     }
     
     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)
 {
   stmtblock_t alloc_block;
   tree res, tmp, null_mem, alloc, error;
   tree type = TREE_TYPE (mem);
 
   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
     size = fold_convert (size_type_node, size);
 
   /* Create a variable to hold the result.  */
-  res = gfc_create_var (pvoid_type_node, NULL);
+  res = gfc_create_var (type, NULL);
   null_mem = fold_build2 (EQ_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);
   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.  */
@@ skipping 14 matching lines @@
     error = gfc_trans_runtime_error (true, NULL,
                                      "Attempting to allocate already allocated"
                                      "array");
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
       tree status_type = TREE_TYPE (TREE_TYPE (status));
       stmtblock_t set_status_block;
 
       gfc_start_block (&set_status_block);
-      tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
+      tmp = build_call_expr_loc (input_location,
+                             built_in_decls[BUILT_IN_FREE], 1,
                              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);
       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 
       gfc_add_modify (&set_status_block,
                            fold_build1 (INDIRECT_REF, status_type, status),
                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 
@@ skipping 17 matching lines @@
   stmtblock_t block;
   tree tmp, cond, call;
 
   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
     var = fold_convert (pvoid_type_node, var);
 
   gfc_start_block (&block);
   var = gfc_evaluate_now (var, &block);
   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
                       build_int_cst (pvoid_type_node, 0));
-  call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
+  call = build_call_expr_loc (input_location,
+                          built_in_decls[BUILT_IN_FREE], 1, var);
   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
-                     build_empty_stmt ());
+                     build_empty_stmt (input_location));
   gfc_add_expr_to_block (&block, tmp);
 
   return gfc_finish_block (&block);
 }
 
 
 
 /* User-deallocate; we emit the code directly from the front-end, and the
    logic is the same as the previous library function:
 
@@ skipping 43 matching lines @@
       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 
       varname = gfc_build_cstring_const (expr->symtree->name);
       varname = gfc_build_addr_expr (pchar_type_node, varname);
 
       error = gfc_trans_runtime_error (true, &expr->where,
                                        "Attempt to DEALLOCATE unallocated '%s'",
                                        varname);
     }
   else
-    error = build_empty_stmt ();
+    error = build_empty_stmt (input_location);
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
       tree status_type = TREE_TYPE (TREE_TYPE (status));
       tree cond2;
 
       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
                            build_int_cst (TREE_TYPE (status), 0));
       tmp = fold_build2 (MODIFY_EXPR, status_type,
                          fold_build1 (INDIRECT_REF, status_type, status),
                          build_int_cst (status_type, 1));
       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
     }
 
   gfc_add_expr_to_block (&null, error);
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
-  tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
+  tmp = build_call_expr_loc (input_location,
+                         built_in_decls[BUILT_IN_FREE], 1,
                          fold_convert (pvoid_type_node, pointer));
   gfc_add_expr_to_block (&non_null, tmp);
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
       /* We set STATUS to zero if it is present.  */
       tree status_type = TREE_TYPE (TREE_TYPE (status));
       tree cond2;
 
       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
                            build_int_cst (TREE_TYPE (status), 0));
       tmp = fold_build2 (MODIFY_EXPR, status_type,
                          fold_build1 (INDIRECT_REF, status_type, status),
                          build_int_cst (status_type, 0));
       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
-                         build_empty_stmt ());
+                         build_empty_stmt (input_location));
       gfc_add_expr_to_block (&non_null, tmp);
     }
 
   return fold_build3 (COND_EXPR, void_type_node, cond,
                       gfc_finish_block (&null), gfc_finish_block (&non_null));
 }
 
 
 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
    following pseudo-code:
@@ skipping 25 matching lines @@
 
   /* Create a variable to hold the result.  */
   res = gfc_create_var (type, NULL);
 
   /* size < 0 ?  */
   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
                           build_int_cst (size_type_node, 0));
   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
       ("Attempt to allocate a negative amount of memory."));
   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
-                     build_call_expr (gfor_fndecl_runtime_error, 1, msg),
-                     build_empty_stmt ());
+                     build_call_expr_loc (input_location,
+                                      gfor_fndecl_runtime_error, 1, msg),
+                     build_empty_stmt (input_location));
   gfc_add_expr_to_block (block, tmp);
 
   /* Call realloc and check the result.  */
-  tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
+  tmp = build_call_expr_loc (input_location,
+                         built_in_decls[BUILT_IN_REALLOC], 2,
                          fold_convert (pvoid_type_node, mem), size);
   gfc_add_modify (block, res, fold_convert (type, tmp));
   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
                              build_int_cst (pvoid_type_node, 0));
   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
                          build_int_cst (size_type_node, 0));
   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
                              nonzero);
   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
                                                 ("Out of memory"));
   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
-                     build_call_expr (gfor_fndecl_os_error, 1, msg),
-                     build_empty_stmt ());
+                     build_call_expr_loc (input_location,
+                                      gfor_fndecl_os_error, 1, msg),
+                     build_empty_stmt (input_location));
   gfc_add_expr_to_block (block, tmp);
 
   /* if (size == 0) then the result is NULL.  */
   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
-                     build_empty_stmt ());
+                     build_empty_stmt (input_location));
   gfc_add_expr_to_block (block, tmp);
 
   return res;
 }
 
 /* Add a statement to a block.  */
 
 void
 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 {
@@ skipping 48 matching lines @@
 /* Set the current locus.  */
 
 void
 gfc_set_backend_locus (locus * loc)
 {
   gfc_current_backend_file = loc->lb->file;
   input_location = loc->lb->location;
 }
 
 
-/* Translate an executable statement.  */
+/* Translate an executable statement. The tree cond is used by gfc_trans_do.
+   This static function is wrapped by gfc_trans_code_cond and
+   gfc_trans_code.  */
 
-tree
-gfc_trans_code (gfc_code * code)
+static tree
+trans_code (gfc_code * code, tree cond)
 {
   stmtblock_t block;
   tree res;
 
   if (!code)
-    return build_empty_stmt ();
+    return build_empty_stmt (input_location);
 
   gfc_start_block (&block);
 
   /* Translate statements one by one into GENERIC trees until we reach
      the end of this gfc_code branch.  */
   for (; code; code = code->next)
     {
       if (code->here != 0)
         {
           res = gfc_trans_label_here (code);
           gfc_add_expr_to_block (&block, res);
         }
 
       switch (code->op)
         {
         case EXEC_NOP:
+        case EXEC_END_BLOCK:
+        case EXEC_END_PROCEDURE:
           res = NULL_TREE;
           break;
 
         case EXEC_ASSIGN:
-          res = gfc_trans_assign (code);
+          if (code->expr1->ts.type == BT_CLASS)
+            res = gfc_trans_class_assign (code);
+          else
+            res = gfc_trans_assign (code);
           break;
 
         case EXEC_LABEL_ASSIGN:
           res = gfc_trans_label_assign (code);
           break;
 
         case EXEC_POINTER_ASSIGN:
-          res = gfc_trans_pointer_assign (code);
+          if (code->expr1->ts.type == BT_CLASS)
+            res = gfc_trans_class_assign (code);
+          else
+            res = gfc_trans_pointer_assign (code);
           break;
 
         case EXEC_INIT_ASSIGN:
-          res = gfc_trans_init_assign (code);
+          if (code->expr1->ts.type == BT_CLASS)
+            res = gfc_trans_class_assign (code);
+          else
+            res = gfc_trans_init_assign (code);
           break;
 
         case EXEC_CONTINUE:
           res = NULL_TREE;
           break;
 
         case EXEC_CYCLE:
           res = gfc_trans_cycle (code);
           break;
 
@@ skipping 23 matching lines @@
           {
             bool is_mvbits = false;
             if (code->resolved_isym
                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
               is_mvbits = true;
             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
                                   NULL_TREE, false);
           }
           break;
 
+        case EXEC_CALL_PPC:
+          res = gfc_trans_call (code, false, NULL_TREE,
+                                NULL_TREE, false);
+          break;
+
         case EXEC_ASSIGN_CALL:
           res = gfc_trans_call (code, true, NULL_TREE,
                                 NULL_TREE, false);
           break;
 
         case EXEC_RETURN:
           res = gfc_trans_return (code);
           break;
 
         case EXEC_IF:
           res = gfc_trans_if (code);
           break;
 
         case EXEC_ARITHMETIC_IF:
           res = gfc_trans_arithmetic_if (code);
           break;
 
+        case EXEC_BLOCK:
+          res = gfc_trans_block_construct (code);
+          break;
+
         case EXEC_DO:
-          res = gfc_trans_do (code);
+          res = gfc_trans_do (code, cond);
           break;
 
         case EXEC_DO_WHILE:
           res = gfc_trans_do_while (code);
           break;
 
         case EXEC_SELECT:
           res = gfc_trans_select (code);
           break;
 
+        case EXEC_SELECT_TYPE:
+          /* Do nothing. SELECT TYPE statements should be transformed into
+          an ordinary SELECT CASE at resolution stage.
+          TODO: Add an error message here once this is done.  */
+          res = NULL_TREE;
+          break;
+
         case EXEC_FLUSH:
           res = gfc_trans_flush (code);
           break;
 
         case EXEC_FORALL:
           res = gfc_trans_forall (code);
           break;
 
         case EXEC_WHERE:
           res = gfc_trans_where (code);
@@ skipping 75 matching lines @@
           break;
 
         default:
           internal_error ("gfc_trans_code(): Bad statement code");
         }
 
       gfc_set_backend_locus (&code->loc);
 
       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
         {
-          if (TREE_CODE (res) == STATEMENT_LIST)
-            tree_annotate_all_with_location (&res, input_location);
-          else
+          if (TREE_CODE (res) != STATEMENT_LIST)
             SET_EXPR_LOCATION (res, input_location);
             
           /* Add the new statement to the block.  */
           gfc_add_expr_to_block (&block, res);
         }
     }
 
   /* Return the finished block.  */
   return gfc_finish_block (&block);
 }
 
 
+/* Translate an executable statement with condition, cond.  The condition is
+   used by gfc_trans_do to test for IO result conditions inside implied
+   DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
+
+tree
+gfc_trans_code_cond (gfc_code * code, tree cond)
+{
+  return trans_code (code, cond);
+}
+
+/* Translate an executable statement without condition.  */
+
+tree
+gfc_trans_code (gfc_code * code)
+{
+  return trans_code (code, NULL_TREE);
+}
+
+
 /* This function is called after a complete program unit has been parsed
    and resolved.  */
 
 void
 gfc_generate_code (gfc_namespace * ns)
 {
+  ompws_flags = 0;
   if (ns->is_block_data)
     {
       gfc_generate_block_data (ns);
       return;
     }
 
   gfc_generate_function_code (ns);
 }
 
 
 /* This function is called after a complete module has been parsed
    and resolved.  */
 
 void
 gfc_generate_module_code (gfc_namespace * ns)
 {
   gfc_namespace *n;
   struct module_htab_entry *entry;
 
   gcc_assert (ns->proc_name->backend_decl == NULL);
   ns->proc_name->backend_decl
-    = build_decl (NAMESPACE_DECL, get_identifier (ns->proc_name->name),
+    = build_decl (ns->proc_name->declared_at.lb->location,
+                  NAMESPACE_DECL, get_identifier (ns->proc_name->name),
                   void_type_node);
-  gfc_set_decl_location (ns->proc_name->backend_decl,
-                         &ns->proc_name->declared_at);
   entry = gfc_find_module (ns->proc_name->name);
   if (entry->namespace_decl)
     /* Buggy sourcecode, using a module before defining it?  */
     htab_empty (entry->decls);
   entry->namespace_decl = ns->proc_name->backend_decl;
 
   gfc_generate_module_vars (ns);
 
   /* We need to generate all module function prototypes first, to allow
      sibling calls.  */
@@ skipping 18 matching lines @@
 
   for (n = ns->contained; n; n = n->sibling)
     {
       if (!n->proc_name)
         continue;
 
       gfc_generate_function_code (n);
     }
 }