trans-decl.c

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

  /* String functions.  */
  gfor_fndecl_copy_string =
    gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
				     void_type_node,
				     4,
				     gfc_charlen_type_node, pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node);

  gfor_fndecl_compare_string =
    gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
				     gfc_int4_type_node,
				     4,
				     gfc_charlen_type_node, pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node);

  gfor_fndecl_concat_string =
    gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
				     void_type_node,
				     6,
				     gfc_charlen_type_node, pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node);

  gfor_fndecl_string_len_trim =
    gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
				     gfc_int4_type_node,
				     2, gfc_charlen_type_node,
				     pchar_type_node);

  gfor_fndecl_string_index =
    gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
				     gfc_int4_type_node,
				     5, gfc_charlen_type_node, pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node,
                                     gfc_logical4_type_node);

  gfor_fndecl_string_scan =
    gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
                                     gfc_int4_type_node,
                                     5, gfc_charlen_type_node, pchar_type_node,
                                     gfc_charlen_type_node, pchar_type_node,
                                     gfc_logical4_type_node);

  gfor_fndecl_string_verify =
    gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
                                     gfc_int4_type_node,
                                     5, gfc_charlen_type_node, pchar_type_node,
                                     gfc_charlen_type_node, pchar_type_node,
                                     gfc_logical4_type_node);

  gfor_fndecl_string_trim = 
    gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
                                     void_type_node,
                                     4,
                                     build_pointer_type (gfc_charlen_type_node),
                                     ppvoid_type_node,
                                     gfc_charlen_type_node,
                                     pchar_type_node);

  gfor_fndecl_string_repeat =
    gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
                                     void_type_node,
                                     4,
                                     pchar_type_node,
                                     gfc_charlen_type_node,
                                     pchar_type_node,
                                     gfc_int4_type_node);

  gfor_fndecl_ttynam =
    gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
                                     void_type_node,
                                     3,
                                     pchar_type_node,
                                     gfc_charlen_type_node,
                                     gfc_c_int_type_node);

  gfor_fndecl_fdate =
    gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
                                     void_type_node,
                                     2,
                                     pchar_type_node,
                                     gfc_charlen_type_node);

  gfor_fndecl_ctime =
    gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
                                     void_type_node,
                                     3,
                                     pchar_type_node,
                                     gfc_charlen_type_node,
                                     gfc_int8_type_node);

  gfor_fndecl_adjustl =
    gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
				     void_type_node,
				     3,
				     pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node);

  gfor_fndecl_adjustr =
    gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
				     void_type_node,
				     3,
				     pchar_type_node,
				     gfc_charlen_type_node, pchar_type_node);

  gfor_fndecl_si_kind =
    gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
                                     gfc_int4_type_node,
                                     1,
                                     pvoid_type_node);

  gfor_fndecl_sr_kind =
    gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
                                     gfc_int4_type_node,
                                     2, pvoid_type_node,
                                     pvoid_type_node);

  /* Power functions.  */
  {
    tree ctype, rtype, itype, jtype;
    int rkind, ikind, jkind;
#define NIKINDS 3
#define NRKINDS 4
    static int ikinds[NIKINDS] = {4, 8, 16};
    static int rkinds[NRKINDS] = {4, 8, 10, 16};
    char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */

    for (ikind=0; ikind < NIKINDS; ikind++)
      {
	itype = gfc_get_int_type (ikinds[ikind]);

	for (jkind=0; jkind < NIKINDS; jkind++)
	  {
	    jtype = gfc_get_int_type (ikinds[jkind]);
	    if (itype && jtype)
	      {
		sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
			ikinds[jkind]);
		gfor_fndecl_math_powi[jkind][ikind].integer =
		  gfc_build_library_function_decl (get_identifier (name),
		    jtype, 2, jtype, itype);
	      }
	  }

	for (rkind = 0; rkind < NRKINDS; rkind ++)
	  {
	    rtype = gfc_get_real_type (rkinds[rkind]);
	    if (rtype && itype)
	      {
		sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
			ikinds[ikind]);
		gfor_fndecl_math_powi[rkind][ikind].real =
		  gfc_build_library_function_decl (get_identifier (name),
		    rtype, 2, rtype, itype);
	      }

	    ctype = gfc_get_complex_type (rkinds[rkind]);
	    if (ctype && itype)
	      {
		sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
			ikinds[ikind]);
		gfor_fndecl_math_powi[rkind][ikind].cmplx =
		  gfc_build_library_function_decl (get_identifier (name),
		    ctype, 2,ctype, itype);
	      }
	  }
      }
#undef NIKINDS
#undef NRKINDS
  }

  gfor_fndecl_math_cpowf =
    gfc_build_library_function_decl (get_identifier ("cpowf"),
				     gfc_complex4_type_node,
				     1, gfc_complex4_type_node);
  gfor_fndecl_math_cpow =
    gfc_build_library_function_decl (get_identifier ("cpow"),
				     gfc_complex8_type_node,
				     1, gfc_complex8_type_node);
  if (gfc_complex10_type_node)
    gfor_fndecl_math_cpowl10 =
      gfc_build_library_function_decl (get_identifier ("cpowl"),
				       gfc_complex10_type_node, 1,
				       gfc_complex10_type_node);
  if (gfc_complex16_type_node)
    gfor_fndecl_math_cpowl16 =
      gfc_build_library_function_decl (get_identifier ("cpowl"),
				       gfc_complex16_type_node, 1,
				       gfc_complex16_type_node);

  gfor_fndecl_math_ishftc4 =
    gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
				     gfc_int4_type_node,
				     3, gfc_int4_type_node,
				     gfc_int4_type_node, gfc_int4_type_node);
  gfor_fndecl_math_ishftc8 =
    gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
				     gfc_int8_type_node,
				     3, gfc_int8_type_node,
				     gfc_int4_type_node, gfc_int4_type_node);
  if (gfc_int16_type_node)
    gfor_fndecl_math_ishftc16 =
      gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
				       gfc_int16_type_node, 3,
				       gfc_int16_type_node,
				       gfc_int4_type_node,
				       gfc_int4_type_node);

  gfor_fndecl_math_exponent4 =
    gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
				     gfc_int4_type_node,
				     1, gfc_real4_type_node);
  gfor_fndecl_math_exponent8 =
    gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
				     gfc_int4_type_node,
				     1, gfc_real8_type_node);
  if (gfc_real10_type_node)
    gfor_fndecl_math_exponent10 =
      gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
				       gfc_int4_type_node, 1,
				       gfc_real10_type_node);
  if (gfc_real16_type_node)
    gfor_fndecl_math_exponent16 =
      gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
				       gfc_int4_type_node, 1,
				       gfc_real16_type_node);

  /* Other functions.  */
  gfor_fndecl_size0 =
    gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
				     gfc_array_index_type,
				     1, pvoid_type_node);
  gfor_fndecl_size1 =
    gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
				     gfc_array_index_type,
				     2, pvoid_type_node,
				     gfc_array_index_type);

  gfor_fndecl_iargc =
    gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
				     gfc_int4_type_node,
				     0);
}


/* Make prototypes for runtime library functions.  */

void
gfc_build_builtin_function_decls (void)
{
  tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
  tree gfc_int4_type_node = gfc_get_int_type (4);
  tree gfc_int8_type_node = gfc_get_int_type (8);
  tree gfc_logical4_type_node = gfc_get_logical_type (4);
  tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);

  /* Treat these two internal malloc wrappers as malloc.  */
  gfor_fndecl_internal_malloc =
    gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
				     pvoid_type_node, 1, gfc_int4_type_node);
  DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;

  gfor_fndecl_internal_malloc64 =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("internal_malloc64")),
				     pvoid_type_node, 1, gfc_int8_type_node);
  DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;

  gfor_fndecl_internal_realloc =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("internal_realloc")),
				     pvoid_type_node, 2, pvoid_type_node,
				     gfc_int4_type_node);

  gfor_fndecl_internal_realloc64 =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("internal_realloc64")),
				     pvoid_type_node, 2, pvoid_type_node,
				     gfc_int8_type_node);

  gfor_fndecl_internal_free =
    gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
				     void_type_node, 1, pvoid_type_node);

  gfor_fndecl_allocate =
    gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
				     void_type_node, 2, ppvoid_type_node,
				     gfc_int4_type_node);

  gfor_fndecl_allocate64 =
    gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
				     void_type_node, 2, ppvoid_type_node,
				     gfc_int8_type_node);

  gfor_fndecl_deallocate =
    gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
				     void_type_node, 2, ppvoid_type_node,
				     gfc_pint4_type_node);

  gfor_fndecl_stop_numeric =
    gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
				     void_type_node, 1, gfc_int4_type_node);

  /* Stop doesn't return.  */
  TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;

  gfor_fndecl_stop_string =
    gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
				     void_type_node, 2, pchar_type_node,
                                     gfc_int4_type_node);
  /* Stop doesn't return.  */
  TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;

  gfor_fndecl_pause_numeric =
    gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
				     void_type_node, 1, gfc_int4_type_node);

  gfor_fndecl_pause_string =
    gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
				     void_type_node, 2, pchar_type_node,
                                     gfc_int4_type_node);

  gfor_fndecl_select_string =
    gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
                                     pvoid_type_node, 0);

  gfor_fndecl_runtime_error =
    gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
				     void_type_node,
				     3,
				     pchar_type_node, pchar_type_node,
				     gfc_int4_type_node);
  /* The runtime_error function does not return.  */
  TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;

  gfor_fndecl_set_fpe =
    gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
				    void_type_node, 1, gfc_c_int_type_node);

  gfor_fndecl_set_std =
    gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
				    void_type_node,
				    3,
				    gfc_int4_type_node,
				    gfc_int4_type_node,
				    gfc_int4_type_node);

  gfor_fndecl_set_convert =
    gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
				     void_type_node, 1, gfc_c_int_type_node);

  gfor_fndecl_in_pack = gfc_build_library_function_decl (
        get_identifier (PREFIX("internal_pack")),
        pvoid_type_node, 1, pvoid_type_node);

  gfor_fndecl_in_unpack = gfc_build_library_function_decl (
        get_identifier (PREFIX("internal_unpack")),
        pvoid_type_node, 1, pvoid_type_node);

  gfor_fndecl_associated =
    gfc_build_library_function_decl (
                                     get_identifier (PREFIX("associated")),
                                     gfc_logical4_type_node,
                                     2,
                                     ppvoid_type_node,
                                     ppvoid_type_node);

  gfc_build_intrinsic_function_decls ();
  gfc_build_intrinsic_lib_fndecls ();
  gfc_build_io_library_fndecls ();
}


/* Evaluate the length of dummy character variables.  */

static tree
gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
{
  stmtblock_t body;

  gfc_finish_decl (cl->backend_decl, NULL_TREE);

  gfc_start_block (&body);

  /* Evaluate the string length expression.  */
  gfc_trans_init_string_length (cl, &body);
  
  gfc_add_expr_to_block (&body, fnbody);
  return gfc_finish_block (&body);
}


/* Allocate and cleanup an automatic character variable.  */

static tree
gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
{
  stmtblock_t body;
  tree decl;
  tree tmp;

  gcc_assert (sym->backend_decl);
  gcc_assert (sym->ts.cl && sym->ts.cl->length);

  gfc_start_block (&body);

  /* Evaluate the string length expression.  */
  gfc_trans_init_string_length (sym->ts.cl, &body);

  decl = sym->backend_decl;

  /* Emit a DECL_EXPR for this variable, which will cause the
     gimplifier to allocate storage, and all that good stuff.  */
  tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
  gfc_add_expr_to_block (&body, tmp);

  gfc_add_expr_to_block (&body, fnbody);
  return gfc_finish_block (&body);
}

/* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */

static tree
gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
{
  stmtblock_t body;

  gcc_assert (sym->backend_decl);
  gfc_start_block (&body);

  /* Set the initial value to length. See the comments in
     function gfc_add_assign_aux_vars in this file.  */
  gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
		       build_int_cst (NULL_TREE, -2));

  gfc_add_expr_to_block (&body, fnbody);
  return gfc_finish_block (&body);
}


/* Generate function entry and exit code, and add it to the function body.
   This includes:
    Allocation and initialization of array variables.
    Allocation of character string variables.
    Initialization and possibly repacking of dummy arrays.
    Initialization