trans-decl.c

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

      strcpy (&name[1], f->sym->name);
      name[0] = '_';
      length = build_decl (PARM_DECL, get_identifier (name), type);

      arglist = chainon (arglist, length);
      DECL_CONTEXT (length) = fndecl;
      DECL_ARTIFICIAL (length) = 1;
      DECL_ARG_TYPE (length) = type;
      TREE_READONLY (length) = 1;
      gfc_finish_decl (length, NULL_TREE);

      /* TODO: Check string lengths when -fbounds-check.  */

      /* Use the passed value for assumed length variables.  */
      if (!f->sym->ts.cl->length)
	{
	  TREE_USED (length) = 1;
	  if (!f->sym->ts.cl->backend_decl)
	    f->sym->ts.cl->backend_decl = length;
	  else
	    {
	      /* there is already another variable using this
		 gfc_charlen node, build a new one for this variable
		 and chain it into the list of gfc_charlens.
		 This happens for e.g. in the case
		 CHARACTER(*)::c1,c2
		 since CHARACTER declarations on the same line share
		 the same gfc_charlen node.  */
	      gfc_charlen *cl;
	      
	      cl = gfc_get_charlen ();
	      cl->backend_decl = length;
	      cl->next = f->sym->ts.cl->next;
	      f->sym->ts.cl->next = cl;
	      f->sym->ts.cl = cl;
	    }
	}

      parm = TREE_CHAIN (parm);
      typelist = TREE_CHAIN (typelist);
    }

  gcc_assert (TREE_VALUE (typelist) == void_type_node);
  DECL_ARGUMENTS (fndecl) = arglist;
}

/* Convert FNDECL's code to GIMPLE and handle any nested functions.  */

static void
gfc_gimplify_function (tree fndecl)
{
  struct cgraph_node *cgn;

  gimplify_function_tree (fndecl);
  dump_function (TDI_generic, fndecl);

  /* Convert all nested functions to GIMPLE now.  We do things in this order
     so that items like VLA sizes are expanded properly in the context of the
     correct function.  */
  cgn = cgraph_node (fndecl);
  for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
    gfc_gimplify_function (cgn->decl);
}


/* Do the setup necessary before generating the body of a function.  */

static void
trans_function_start (gfc_symbol * sym)
{
  tree fndecl;

  fndecl = sym->backend_decl;

  /* Let GCC know the current scope is this function.  */
  current_function_decl = fndecl;

  /* Let the world know what we're about to do.  */
  announce_function (fndecl);

  if (DECL_CONTEXT (fndecl) == NULL_TREE)
    {
      /* Create RTL for function declaration.  */
      rest_of_decl_compilation (fndecl, 1, 0);
    }

  /* Create RTL for function definition.  */
  make_decl_rtl (fndecl);

  init_function_start (fndecl);

  /* Even though we're inside a function body, we still don't want to
     call expand_expr to calculate the size of a variable-sized array.
     We haven't necessarily assigned RTL to all variables yet, so it's
     not safe to try to expand expressions involving them.  */
  cfun->x_dont_save_pending_sizes_p = 1;

  /* function.c requires a push at the start of the function.  */
  pushlevel (0);
}

/* Create thunks for alternate entry points.  */

static void
build_entry_thunks (gfc_namespace * ns)
{
  gfc_formal_arglist *formal;
  gfc_formal_arglist *thunk_formal;
  gfc_entry_list *el;
  gfc_symbol *thunk_sym;
  stmtblock_t body;
  tree thunk_fndecl;
  tree args;
  tree string_args;
  tree tmp;
  locus old_loc;

  /* This should always be a toplevel function.  */
  gcc_assert (current_function_decl == NULL_TREE);

  gfc_get_backend_locus (&old_loc);
  for (el = ns->entries; el; el = el->next)
    {
      thunk_sym = el->sym;
      
      build_function_decl (thunk_sym);
      create_function_arglist (thunk_sym);

      trans_function_start (thunk_sym);

      thunk_fndecl = thunk_sym->backend_decl;

      gfc_start_block (&body);

      /* Pass extra parameter identifying this entry point.  */
      tmp = build_int_cst (gfc_array_index_type, el->id);
      args = tree_cons (NULL_TREE, tmp, NULL_TREE);
      string_args = NULL_TREE;

      if (thunk_sym->attr.function)
	{
	  if (gfc_return_by_reference (ns->proc_name))
	    {
	      tree ref = DECL_ARGUMENTS (current_function_decl);
	      args = tree_cons (NULL_TREE, ref, args);
	      if (ns->proc_name->ts.type == BT_CHARACTER)
		args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
				  args);
	    }
	}

      for (formal = ns->proc_name->formal; formal; formal = formal->next)
	{
	  /* Ignore alternate returns.  */
	  if (formal->sym == NULL)
	    continue;

	  /* We don't have a clever way of identifying arguments, so resort to
	     a brute-force search.  */
	  for (thunk_formal = thunk_sym->formal;
	       thunk_formal;
	       thunk_formal = thunk_formal->next)
	    {
	      if (thunk_formal->sym == formal->sym)
		break;
	    }

	  if (thunk_formal)
	    {
	      /* Pass the argument.  */
	      args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
				args);
	      if (formal->sym->ts.type == BT_CHARACTER)
		{
		  tmp = thunk_formal->sym->ts.cl->backend_decl;
		  string_args = tree_cons (NULL_TREE, tmp, string_args);
		}
	    }
	  else
	    {
	      /* Pass NULL for a missing argument.  */
	      args = tree_cons (NULL_TREE, null_pointer_node, args);
	      if (formal->sym->ts.type == BT_CHARACTER)
		{
		  tmp = convert (gfc_charlen_type_node, integer_zero_node);
		  string_args = tree_cons (NULL_TREE, tmp, string_args);
		}
	    }
	}

      /* Call the master function.  */
      args = nreverse (args);
      args = chainon (args, nreverse (string_args));
      tmp = ns->proc_name->backend_decl;
      tmp = gfc_build_function_call (tmp, args);
      if (ns->proc_name->attr.mixed_entry_master)
	{
	  tree union_decl, field;
	  tree master_type = TREE_TYPE (ns->proc_name->backend_decl);

	  union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
				   TREE_TYPE (master_type));
	  DECL_ARTIFICIAL (union_decl) = 1;
	  DECL_EXTERNAL (union_decl) = 0;
	  TREE_PUBLIC (union_decl) = 0;
	  TREE_USED (union_decl) = 1;
	  layout_decl (union_decl, 0);
	  pushdecl (union_decl);

	  DECL_CONTEXT (union_decl) = current_function_decl;
	  tmp = build2 (MODIFY_EXPR,
			TREE_TYPE (union_decl),
			union_decl, tmp);
	  gfc_add_expr_to_block (&body, tmp);

	  for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
	       field; field = TREE_CHAIN (field))
	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
		thunk_sym->result->name) == 0)
	      break;
	  gcc_assert (field != NULL_TREE);
	  tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
			NULL_TREE);
	  tmp = build2 (MODIFY_EXPR,
			TREE_TYPE (DECL_RESULT (current_function_decl)),
			DECL_RESULT (current_function_decl), tmp);
	  tmp = build1_v (RETURN_EXPR, tmp);
	}
      else if (TREE_TYPE (DECL_RESULT (current_function_decl))
	       != void_type_node)
	{
	  tmp = build2 (MODIFY_EXPR,
			TREE_TYPE (DECL_RESULT (current_function_decl)),
			DECL_RESULT (current_function_decl), tmp);
	  tmp = build1_v (RETURN_EXPR, tmp);
	}
      gfc_add_expr_to_block (&body, tmp);

      /* Finish off this function and send it for code generation.  */
      DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
      poplevel (1, 0, 1);
      BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;

      /* Output the GENERIC tree.  */
      dump_function (TDI_original, thunk_fndecl);

      /* Store the end of the function, so that we get good line number
	 info for the epilogue.  */
      cfun->function_end_locus = input_location;

      /* We're leaving the context of this function, so zap cfun.
	 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
	 tree_rest_of_compilation.  */
      cfun = NULL;

      current_function_decl = NULL_TREE;

      gfc_gimplify_function (thunk_fndecl);
      cgraph_finalize_function (thunk_fndecl, false);

      /* We share the symbols in the formal argument list with other entry
	 points and the master function.  Clear them so that they are
	 recreated for each function.  */
      for (formal = thunk_sym->formal; formal; formal = formal->next)
	if (formal->sym != NULL)  /* Ignore alternate returns.  */
	  {
	    formal->sym->backend_decl = NULL_TREE;
	    if (formal->sym->ts.type == BT_CHARACTER)
	      formal->sym->ts.cl->backend_decl = NULL_TREE;
	  }

      if (thunk_sym->attr.function)
	{
	  if (thunk_sym->ts.type == BT_CHARACTER)
	    thunk_sym->ts.cl->backend_decl = NULL_TREE;
	  if (thunk_sym->result->ts.type == BT_CHARACTER)
	    thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
	}
    }

  gfc_set_backend_locus (&old_loc);
}


/* Create a decl for a function, and create any thunks for alternate entry
   points.  */

void
gfc_create_function_decl (gfc_namespace * ns)
{
  /* Create a declaration for the master function.  */
  build_function_decl (ns->proc_name);

  /* Compile the entry thunks.  */
  if (ns->entries)
    build_entry_thunks (ns);

  /* Now create the read argument list.  */
  create_function_arglist (ns->proc_name);
}

/* Return the decl used to hold the function return value.  */

tree
gfc_get_fake_result_decl (gfc_symbol * sym)
{
  tree decl;
  tree length;

  char name[GFC_MAX_SYMBOL_LEN + 10];

  if (sym
      && sym->ns->proc_name->backend_decl == current_function_decl
      && sym->ns->proc_name->attr.mixed_entry_master
      && sym != sym->ns->proc_name)
    {
      decl = gfc_get_fake_result_decl (sym->ns->proc_name);
      if (decl)
	{
	  tree field;

	  for (field = TYPE_FIELDS (TREE_TYPE (decl));
	       field; field = TREE_CHAIN (field))
	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
		sym->name) == 0)
	      break;

	  gcc_assert (field != NULL_TREE);
	  decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
			 NULL_TREE);
	}
      return decl;
    }

  if (current_fake_result_decl != NULL_TREE)
    return current_fake_result_decl;

  /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
     sym is NULL.  */
  if (!sym)
    return NULL_TREE;

  if (sym->ts.type == BT_CHARACTER
      && !sym->ts.cl->backend_decl)
    {
      length = gfc_create_string_length (sym);
      gfc_finish_var_decl (length, sym);
    }

  if (gfc_return_by_reference (sym))
    {
      decl = DECL_ARGUMENTS (current_function_decl);

      if (sym->ns->proc_name->backend_decl == current_function_decl
	  && sym->ns->proc_name->attr.entry_master)
	decl = TREE_CHAIN (decl);

      TREE_USED (decl) = 1;
      if (sym->as)
	decl = gfc_build_dummy_array_decl (sym, decl);
    }
  else
    {
      sprintf (name, "__result_%.20s",
	       IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));

      decl = build_decl (VAR_DECL, get_identifier (name),
			 TREE_TYPE (TREE_TYPE (current_function_decl)));

      DECL_ARTIFICIAL (decl) = 1;
      DECL_EXTERNAL (decl) = 0;
      TREE_PUBLIC (decl) = 0;
      TREE_USED (decl) = 1;

      layout_decl (decl, 0);

      gfc_add_decl_to_function (decl);
    }

  current_fake_result_decl = decl;

  return decl;
}


/* Builds a function decl.  The remaining parameters are the types of the
   function arguments.  Negative nargs indicates a varargs function.  */

tree
gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
{
  tree arglist;
  tree argtype;
  tree fntype;
  tree fndecl;
  va_list p;
  int n;

  /* Library functions must be declared with global scope.  */
  gcc_assert (current_function_decl == NULL_TREE);

  va_start (p, nargs);


  /* Create a list of the argument types.  */
  for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
    {
      argtype = va_arg (p, tree);
      arglist = gfc_chainon_list (arglist, argtype);
    }

  if (nargs >= 0)
    {
      /* Terminate the list.  */
      arglist = gfc_chainon_list (arglist, void_type_node);
    }

  /* Build the function type and decl.  */
  fntype = build_function_type (rettype, arglist);
  fndecl = build_decl (FUNCTION_DECL, name, fntype);

  /* Mark this decl as external.  */
  DECL_EXTERNAL (fndecl) = 1;
  TREE_PUBLIC (fndecl) = 1;

  va_end (p);

  pushdecl (fndecl);

  rest_of_decl_compilation (fndecl, 1, 0);

  return fndecl;
}

static void
gfc_build_intrinsic_function_decls (void)
{
  tree gfc_int4_type_node = gfc_get_int_type (4);
  tree gfc_int8_type_node = gfc_get_int_type (8);
  tree gfc_int16_type_node = gfc_get_int_type (16);
  tree gfc_logical4_type_node = gfc_get_logical_type (4);
  tree gfc_real4_type_node = gfc_get_real_type (4);
  tree gfc_real8_type_node = gfc_get_real_type (8);
  tree gfc_real10_type_node = gfc_get_real_type (10);
  tree gfc_real16_type_node = gfc_get_real_type (16);
  tree gfc_complex4_type_node = gfc_get_complex_type (4);
  tree gfc_complex8_type_node = gfc_get_complex_type (8);
  tree gfc_complex10_type_node = gfc_get_complex_type (10);
  tree gfc_complex16_type_node = gfc_get_complex_type (16);
  tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);