f95-lang.c

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

  /* Record the BLOCK node just built as the subblock its enclosing scope.  */
  for (subblock_node = subblock_chain; subblock_node;
       subblock_node = TREE_CHAIN (subblock_node))
    BLOCK_SUPERCONTEXT (subblock_node) = block_node;

  /* Clear out the meanings of the local variables of this level.  */

  for (subblock_node = decl_chain; subblock_node;
       subblock_node = TREE_CHAIN (subblock_node))
    if (DECL_NAME (subblock_node) != 0)
      /* If the identifier was used or addressed via a local extern decl,
         don't forget that fact.  */
      if (DECL_EXTERNAL (subblock_node))
	{
	  if (TREE_USED (subblock_node))
	    TREE_USED (DECL_NAME (subblock_node)) = 1;
	  if (TREE_ADDRESSABLE (subblock_node))
	    TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
	}

  /* Pop the current level.  */
  current_binding_level = current_binding_level->level_chain;

  if (functionbody)
    {
      /* This is the top level block of a function. The ..._DECL chain stored
         in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
         leave them in the BLOCK because they are found in the FUNCTION_DECL
         instead.  */
      DECL_INITIAL (current_function_decl) = block_node;
      BLOCK_VARS (block_node) = 0;
    }
  else if (block_node)
    {
      current_binding_level->blocks
	= chainon (current_binding_level->blocks, block_node);
    }

  /* If we did not make a block for the level just exited, any blocks made for
     inner levels (since they cannot be recorded as subblocks in that level)
     must be carried forward so they will later become subblocks of something
     else.  */
  else if (subblock_chain)
    current_binding_level->blocks
      = chainon (current_binding_level->blocks, subblock_chain);
  if (block_node)
    TREE_USED (block_node) = 1;

  return block_node;
}

/* Insert BLOCK at the end of the list of subblocks of the
   current binding level.  This is used when a BIND_EXPR is expanded,
   to handle the BLOCK node inside the BIND_EXPR.  */

void
insert_block (tree block)
{
  TREE_USED (block) = 1;
  current_binding_level->blocks
    = chainon (current_binding_level->blocks, block);
}

/* Records a ..._DECL node DECL as belonging to the current lexical scope.
   Returns the ..._DECL node.  */

tree
pushdecl (tree decl)
{
  /* External objects aren't nested, other objects may be.  */
  if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
    DECL_CONTEXT (decl) = 0;
  else
    DECL_CONTEXT (decl) = current_function_decl;

  /* Put the declaration on the list.  The list of declarations is in reverse
     order. The list will be reversed later if necessary.  This needs to be
     this way for compatibility with the back-end.  */

  TREE_CHAIN (decl) = current_binding_level->names;
  current_binding_level->names = decl;

  /* For the declaration of a type, set its name if it is not already set.  */

  if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
    {
      if (DECL_SOURCE_LINE (decl) == 0)
	TYPE_NAME (TREE_TYPE (decl)) = decl;
      else
	TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
    }

  return decl;
}


/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */

tree
pushdecl_top_level (tree x)
{
  tree t;
  struct binding_level *b = current_binding_level;

  current_binding_level = global_binding_level;
  t = pushdecl (x);
  current_binding_level = b;
  return t;
}


/* Clear the binding stack.  */
static void
gfc_clear_binding_stack (void)
{
  while (!global_bindings_p ())
    poplevel (0, 0, 0);
}


#ifndef CHAR_TYPE_SIZE
#define CHAR_TYPE_SIZE BITS_PER_UNIT
#endif

#ifndef INT_TYPE_SIZE
#define INT_TYPE_SIZE BITS_PER_WORD
#endif

#undef SIZE_TYPE
#define SIZE_TYPE "long unsigned int"

/* Create tree nodes for the basic scalar types of Fortran 95,
   and some nodes representing standard constants (0, 1, (void *) 0).
   Initialize the global binding level.
   Make definitions for built-in primitive functions.  */
static void
gfc_init_decl_processing (void)
{
  current_function_decl = NULL;
  current_binding_level = NULL_BINDING_LEVEL;
  free_binding_level = NULL_BINDING_LEVEL;

  /* Make the binding_level structure for global names. We move all
     variables that are in a COMMON block to this binding level.  */
  pushlevel (0);
  global_binding_level = current_binding_level;

  /* Build common tree nodes. char_type_node is unsigned because we
     only use it for actual characters, not for INTEGER(1). Also, we
     want double_type_node to actually have double precision.  */
  build_common_tree_nodes (false, false);
  set_sizetype (long_unsigned_type_node);
  build_common_tree_nodes_2 (0);
  void_list_node = build_tree_list (NULL_TREE, void_type_node);

  /* Set up F95 type nodes.  */
  gfc_init_kinds ();
  gfc_init_types ();
}

/* Mark EXP saying that we need to be able to take the
   address of it; it should not be allocated in a register.
   In Fortran 95 this is only the case for variables with
   the TARGET attribute, but we implement it here for a
   likely future Cray pointer extension.
   Value is 1 if successful.  */
/* TODO: Check/fix mark_addressable.  */
bool
gfc_mark_addressable (tree exp)
{
  register tree x = exp;
  while (1)
    switch (TREE_CODE (x))
      {
      case COMPONENT_REF:
      case ADDR_EXPR:
      case ARRAY_REF:
      case REALPART_EXPR:
      case IMAGPART_EXPR:
	x = TREE_OPERAND (x, 0);
	break;

      case CONSTRUCTOR:
	TREE_ADDRESSABLE (x) = 1;
	return true;

      case VAR_DECL:
      case CONST_DECL:
      case PARM_DECL:
      case RESULT_DECL:
	if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
	  {
	    if (TREE_PUBLIC (x))
	      {
		error
		  ("global register variable %qs used in nested function",
		   IDENTIFIER_POINTER (DECL_NAME (x)));
		return false;
	      }
	    pedwarn ("register variable %qs used in nested function",
		     IDENTIFIER_POINTER (DECL_NAME (x)));
	  }
	else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
	  {
	    if (TREE_PUBLIC (x))
	      {
		error ("address of global register variable %qs requested",
		       IDENTIFIER_POINTER (DECL_NAME (x)));
		return true;
	      }

#if 0
	    /* If we are making this addressable due to its having
	       volatile components, give a different error message.  Also
	       handle the case of an unnamed parameter by not trying
	       to give the name.  */

	    else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
	      {
		error ("cannot put object with volatile field into register");
		return false;
	      }
#endif

	    pedwarn ("address of register variable %qs requested",
		     IDENTIFIER_POINTER (DECL_NAME (x)));
	  }

	/* drops in */
      case FUNCTION_DECL:
	TREE_ADDRESSABLE (x) = 1;

      default:
	return true;
      }
}

/* press the big red button - garbage (ggc) collection is on */

int ggc_p = 1;

/* Builtin function initialization.  */

/* Return a definition for a builtin function named NAME and whose data type
   is TYPE.  TYPE should be a function type with argument types.
   FUNCTION_CODE tells later passes how to compile calls to this function.
   See tree.h for its possible values.

   If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
   the name to be called if we can't opencode the function.  If
   ATTRS is nonzero, use that for the function's attribute list.  */

tree
builtin_function (const char *name,
		  tree type,
		  int function_code,
		  enum built_in_class class,
		  const char *library_name,
		  tree attrs)
{
  tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
  DECL_EXTERNAL (decl) = 1;
  TREE_PUBLIC (decl) = 1;
  if (library_name)
    SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
  make_decl_rtl (decl);
  pushdecl (decl);
  DECL_BUILT_IN_CLASS (decl) = class;
  DECL_FUNCTION_CODE (decl) = function_code;

  /* Possibly apply some default attributes to this built-in function.  */
  if (attrs)
    {
      /* FORNOW the only supported attribute is "const".  If others need
         to be supported then see the more general solution in procedure
         builtin_function in c-decl.c  */
      if (lookup_attribute ( "const", attrs ))
        TREE_READONLY (decl) = 1;
    }

  return decl;
}


static void
gfc_define_builtin (const char * name,
		    tree type,
		    int code,
		    const char * library_name,
		    bool const_p)
{
  tree decl;

  decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
			   library_name, NULL_TREE);
  if (const_p)
    TREE_READONLY (decl) = 1;

  built_in_decls[code] = decl;
  implicit_built_in_decls[code] = decl;
}


#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
    gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
                       BUILT_IN_ ## code ## L, name "l", true); \
    gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
			BUILT_IN_ ## code, name, true); \
    gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
			BUILT_IN_ ## code ## F, name "f", true);

#define DEFINE_MATH_BUILTIN(code, name, argtype) \
    DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)

#define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
    DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \
    DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)


/* Create function types for builtin functions.  */

static void
build_builtin_fntypes (tree * fntype, tree type)
{
  tree tmp;

  /* type (*) (type) */
  tmp = tree_cons (NULL_TREE, float_type_node, void_list_node);
  fntype[0] = build_function_type (type, tmp);
  /* type (*) (type, type) */
  tmp = tree_cons (NULL_TREE, float_type_node, tmp);
  fntype[1] = build_function_type (type, tmp);
  /* type (*) (int, type) */
  tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
  tmp = tree_cons (NULL_TREE, type, tmp);
  fntype[2] = build_function_type (type, tmp);
}


/* Initialization of builtin function nodes.  */

static void
gfc_init_builtin_functions (void)
{
  tree mfunc_float[3];
  tree mfunc_double[3];
  tree mfunc_longdouble[3];
  tree mfunc_cfloat[3];
  tree mfunc_cdouble[3];
  tree mfunc_clongdouble[3];
  tree func_cfloat_float;
  tree func_cdouble_double;
  tree func_clongdouble_longdouble;
  tree ftype;
  tree tmp;

  build_builtin_fntypes (mfunc_float, float_type_node);
  build_builtin_fntypes (mfunc_double, double_type_node);
  build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
  build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
  build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
  build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node);

  tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
  func_cfloat_float = build_function_type (float_type_node, tmp);

  tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
  func_cdouble_double = build_function_type (double_type_node, tmp);

  tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
  func_clongdouble_longdouble =
    build_function_type (long_double_type_node, tmp);

#include "mathbuiltins.def"

  /* We define these separately as the fortran versions have different
     semantics (they return an integer type) */
  gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], 
		      BUILT_IN_ROUNDL, "roundl", true);
  gfc_define_builtin ("__builtin_round", mfunc_double[0], 
		      BUILT_IN_ROUND, "round", true);
  gfc_define_builtin ("__builtin_roundf", mfunc_float[0], 
		      BUILT_IN_ROUNDF, "roundf", true);

  gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
		      BUILT_IN_TRUNCL, "truncl", true);
  gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
                      BUILT_IN_TRUNC, "trunc", true);
  gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
                      BUILT_IN_TRUNCF, "truncf", true);

  gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble, 
		      BUILT_IN_CABSL, "cabsl", true);
  gfc_define_builtin ("__builtin_cabs", func_cdouble_double, 
		      BUILT_IN_CABS, "cabs", true);
  gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, 
		      BUILT_IN_CABSF, "cabsf", true);
 
  gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1], 
		      BUILT_IN_COPYSIGNL, "copysignl", true);
  gfc_define_builtin ("__builtin_copysign", mfunc_double[1], 
		      BUILT_IN_COPYSIGN, "copysign", true);
  gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], 
		      BUILT_IN_COPYSIGNF, "copysignf", true);

  /* These are used to implement the ** operator.  */
  gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], 
		      BUILT_IN_POWL, "powl", true);
  gfc_define_builtin ("__builtin_pow", mfunc_double[1], 
		      BUILT_IN_POW, "pow", true);
  gfc_define_builtin ("__builtin_powf", mfunc_float[1], 
		      BUILT_IN_POWF, "powf", true);

  /* Other builtin functions we use.  */

  tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
  ftype = build_function_type (integer_type_node, tmp);
  gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
		      "__builtin_clz", true);

  tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
  ftype = build_function_type (integer_type_node, tmp);
  gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
		      "__builtin_clzl", true);

  tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node);
  ftype = build_function_type (integer_type_node, tmp);
  gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
		      "__builtin_clzll", true);

  tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
  tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
  ftype = build_function_type (long_integer_type_node, tmp);
  gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
		      "__builtin_expect", true);

  build_common_builtin_nodes ();
  targetm.init_builtins ();
}

#undef DEFINE_MATH_BUILTIN_C
#undef DEFINE_MATH_BUILTIN

#include "gt-fortran-f95-lang.h"
#include "gtype-fortran.h"