ste.c

gcc-2.95.3 Linux下最常用的C编译器

/* ste.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran 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 2, or (at your option)
any later version.

GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:
      ste.c

   Description:
      Implements the various statements and such like.

   Modifications:
*/

/* Include files. */

#include "proj.h"

#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "rtl.j"
#include "toplev.j"
#endif

#include "ste.h"
#include "bld.h"
#include "com.h"
#include "expr.h"
#include "lab.h"
#include "lex.h"
#include "sta.h"
#include "stp.h"
#include "str.h"
#include "sts.h"
#include "stt.h"
#include "stv.h"
#include "stw.h"
#include "symbol.h"

/* Externals defined here. */


/* Simple definitions and enumerations. */

typedef enum
  {
    FFESTE_stateletSIMPLE_,	/* Expecting simple/start. */
    FFESTE_stateletATTRIB_,	/* Expecting attrib/item/itemstart. */
    FFESTE_stateletITEM_,	/* Expecting item/itemstart/finish. */
    FFESTE_stateletITEMVALS_,	/* Expecting itemvalue/itemendvals. */
    FFESTE_
  } ffesteStatelet_;

/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module. */

static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffelab ffeste_label_formatdef_ = NULL;
static tree (*ffeste_io_driver_) (ffebld expr);	/* do?io. */
static ffecomGfrt ffeste_io_endgfrt_;	/* end function to call. */
static tree ffeste_io_abort_;	/* abort-io label or NULL_TREE. */
static bool ffeste_io_abort_is_temp_;	/* abort-io label is a temp. */
static tree ffeste_io_end_;	/* END= label or NULL_TREE. */
static tree ffeste_io_err_;	/* ERR= label or NULL_TREE. */
static tree ffeste_io_iostat_;	/* IOSTAT= var or NULL_TREE. */
static bool ffeste_io_iostat_is_temp_;	/* IOSTAT= var is a temp. */
#endif

/* Static functions (internal). */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
				  tree *xitersvar, ffebld var,
				  ffebld start, ffelexToken start_token,
				  ffebld end, ffelexToken end_token,
				  ffebld incr, ffelexToken incr_token,
				  const char *msg);
static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
				tree itersvar);
static void ffeste_io_call_ (tree call, bool do_check);
static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
static tree ffeste_io_dofio_ (ffebld expr);
static tree ffeste_io_dolio_ (ffebld expr);
static tree ffeste_io_douio_ (ffebld expr);
static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit,
			       ffebld unit_expr, int unit_dflt);
static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit,
			       ffebld unit_expr, int unit_dflt,
			       bool have_end, ffestvFormat format,
			       ffestpFile *format_spec, bool rec,
			       ffebld rec_expr);
static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr,
			       ffestpFile *stat_spec);
static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
				bool have_end, ffestvFormat format,
				ffestpFile *format_spec);
static tree ffeste_io_inlist_ (bool have_err,
			       ffestpFile *unit_spec,
			       ffestpFile *file_spec,
			       ffestpFile *exist_spec,
			       ffestpFile *open_spec,
			       ffestpFile *number_spec,
			       ffestpFile *named_spec,
			       ffestpFile *name_spec,
			       ffestpFile *access_spec,
			       ffestpFile *sequential_spec,
			       ffestpFile *direct_spec,
			       ffestpFile *form_spec,
			       ffestpFile *formatted_spec,
			       ffestpFile *unformatted_spec,
			       ffestpFile *recl_spec,
			       ffestpFile *nextrec_spec,
			       ffestpFile *blank_spec);
static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
			      ffestpFile *file_spec,
			      ffestpFile *stat_spec,
			      ffestpFile *access_spec,
			      ffestpFile *form_spec,
			      ffestpFile *recl_spec,
			      ffestpFile *blank_spec);
static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
#elif FFECOM_targetCURRENT == FFECOM_targetFFE
static void ffeste_subr_file_ (const char *kw, ffestpFile *spec);
#else
#error
#endif

/* Internal macros. */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define ffeste_emit_line_note_() \
  emit_line_note (input_filename, lineno)
#endif
#define ffeste_check_simple_() \
  assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
#define ffeste_check_start_() \
  assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
  ffeste_statelet_ = FFESTE_stateletATTRIB_
#define ffeste_check_attrib_() \
  assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
#define ffeste_check_item_() \
  assert(ffeste_statelet_ == FFESTE_stateletATTRIB_	 \
	 || ffeste_statelet_ == FFESTE_stateletITEM_); \
  ffeste_statelet_ = FFESTE_stateletITEM_
#define ffeste_check_item_startvals_() \
  assert(ffeste_statelet_ == FFESTE_stateletATTRIB_	 \
	 || ffeste_statelet_ == FFESTE_stateletITEM_); \
  ffeste_statelet_ = FFESTE_stateletITEMVALS_
#define ffeste_check_item_value_() \
  assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
#define ffeste_check_item_endvals_() \
  assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
  ffeste_statelet_ = FFESTE_stateletITEM_
#define ffeste_check_finish_() \
  assert(ffeste_statelet_ == FFESTE_stateletATTRIB_	 \
	 || ffeste_statelet_ == FFESTE_stateletITEM_); \
  ffeste_statelet_ = FFESTE_stateletSIMPLE_

#define ffeste_f2c_init_charnolen_(Exp,Init,Spec)			      \
  do									      \
    {									      \
      if ((Spec)->kw_or_val_present)					      \
	Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore);	      \
      else								      \
	Exp = null_pointer_node;					      \
      if (Exp)								      \
	Init = Exp;							      \
      else								      \
	{								      \
	  Init = null_pointer_node;					      \
	  constantp = FALSE;						      \
	}								      \
    } while(0)

#define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec)		      \
  do									      \
    {									      \
      if ((Spec)->kw_or_val_present)					      \
	Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp);	      \
      else								      \
	{								      \
	  Exp = null_pointer_node;					      \
	  Lenexp = ffecom_f2c_ftnlen_zero_node;				      \
	}								      \
      if (Exp)								      \
	Init = Exp;							      \
      else								      \
	{								      \
	  Init = null_pointer_node;					      \
	  constantp = FALSE;						      \
	}								      \
      if (Lenexp)							      \
	Leninit = Lenexp;						      \
      else								      \
	{								      \
	  Leninit = ffecom_f2c_ftnlen_zero_node;			      \
	  constantp = FALSE;						      \
	}								      \
    } while(0)

#define ffeste_f2c_init_flag_(Flag,Init)				      \
  do									      \
    {									      \
      Init = convert (ffecom_f2c_flag_type_node,			      \
		      (Flag) ? integer_one_node : integer_zero_node);	      \
    } while(0)

#define ffeste_f2c_init_format_(Exp,Init,Spec)				      \
  do									      \
    {									      \
      Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL);	      \
      if (Exp)								      \
	Init = Exp;							      \
      else								      \
	{								      \
	  Init = null_pointer_node;					      \
	  constantp = FALSE;						      \
	}								      \
    } while(0)

#define ffeste_f2c_init_int_(Exp,Init,Spec)				      \
  do									      \
    {									      \
      if ((Spec)->kw_or_val_present)					      \
	Exp = ffecom_const_expr ((Spec)->u.expr);			      \
      else								      \
	Exp = ffecom_integer_zero_node;					      \
      if (Exp)								      \
	Init = Exp;							      \
      else								      \
	{								      \
	  Init = ffecom_integer_zero_node;				      \
	  constantp = FALSE;						      \
	}								      \
    } while(0)

#define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec)			      \
  do									      \
    {									      \
      if ((Spec)->kw_or_val_present)					      \
	Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr);		      \
      else								      \
	Exp = null_pointer_node;					      \
      if (Exp)								      \
	Init = Exp;							      \
      else								      \
	{								      \
	  Init = null_pointer_node;					      \
	  constantp = FALSE;						      \
	}								      \
    } while(0)

#define ffeste_f2c_init_next_(Init)					      \
  do									      \
    {									      \
      TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)),     \
					    (Init));			      \
      initn = TREE_CHAIN(initn);					      \
    } while(0)

#define ffeste_f2c_prepare_charnolen_(Spec,Exp)				      \
  do									      \
    {									      \
      if (! (Exp))							      \
        ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr);		      \
    } while(0)

#define ffeste_f2c_prepare_char_(Spec,Exp)				      \
  do									      \
    {									      \
      if (! (Exp))							      \
        ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr);		      \
    } while(0)

#define ffeste_f2c_prepare_format_(Spec,Exp)				      \
  do									      \
    {									      \
      if (! (Exp))							      \
        ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr);		      \
    } while(0)

#define ffeste_f2c_prepare_int_(Spec,Exp)				      \
  do									      \
    {									      \
      if (! (Exp))							      \
        ffecom_prepare_expr ((Spec)->u.expr);				      \
    } while(0)

#define ffeste_f2c_prepare_ptrtoint_(Spec,Exp)				      \
  do									      \
    {									      \
      if (! (Exp))							      \
        ffecom_prepare_ptr_to_expr ((Spec)->u.expr);			      \
    } while(0)

#define ffeste_f2c_compile_(Field,Exp)					      \
  do									      \
    {									      \
      tree exz;								      \
      if ((Exp))							      \
	{								      \
	  exz = ffecom_modify (void_type_node,				      \
			       ffecom_2 (COMPONENT_REF, TREE_TYPE (Field),    \
					 t, (Field)),			      \
			       (Exp));					      \
	  expand_expr_stmt (exz);					      \
	}								      \
    } while(0)

#define ffeste_f2c_compile_charnolen_(Field,Spec,Exp)			      \
  do									      \
    {									      \
      tree exq;								      \
      if (! (Exp))							      \
	{								      \
	  exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore);	      \
	  ffeste_f2c_compile_ ((Field), exq);				      \
	}								      \
    } while(0)

#define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp)	      \
  do									      \
    {									      \
      tree exq = (Exp);							      \
      tree lenexq = (Lenexp);						      \
      int need_exq = (! exq);						      \
      int need_lenexq = (! lenexq); 					      \
      if (need_exq || need_lenexq)					      \
	{								      \
	  exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq);	      \
	  if (need_exq)							      \
	    ffeste_f2c_compile_ ((Field), exq);				      \
	  if (need_lenexq)						      \
	    ffeste_f2c_compile_ ((Lenfield), lenexq);			      \
	}								      \
    } while(0)

#define ffeste_f2c_compile_format_(Field,Spec,Exp)			      \
  do									      \
    {									      \
      tree exq;								      \
      if (! (Exp))							      \
	{								      \
	  exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL);		      \
	  ffeste_f2c_compile_ ((Field), exq);				      \
	}								      \
    } while(0)

#define ffeste_f2c_compile_int_(Field,Spec,Exp)				      \
  do									      \
    {									      \
      tree exq;								      \
      if (! (Exp))							      \
	{								      \
	  exq = ffecom_expr ((Spec)->u.expr);				      \
	  ffeste_f2c_compile_ ((Field), exq);				      \
	}								      \
    } while(0)

#define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp)			      \
  do									      \
    {									      \
      tree exq;								      \
      if (! (Exp))							      \
	{								      \
	  exq = ffecom_ptr_to_expr ((Spec)->u.expr);			      \
	  ffeste_f2c_compile_ ((Field), exq);				      \
	}								      \
    } while(0)

/* Start a Fortran block.  */

#ifdef ENABLE_CHECKING

typedef struct gbe_block
{
  struct gbe_block *outer;
  ffestw block;
  int lineno;
  char *input_filename;
  bool is_stmt;
} *gbe_block;

gbe_block ffeste_top_block_ = NULL;

static void
ffeste_start_block_ (ffestw block)
{
  gbe_block b = xmalloc (sizeof (*b));

  b->outer = ffeste_top_block_;
  b->block = block;
  b->lineno = lineno;
  b->input_filename = input_filename;
  b->is_stmt = FALSE;

  ffeste_top_block_ = b;

  ffecom_start_compstmt ();
}

/* End a Fortran block.  */

static void
ffeste_end_block_ (ffestw block)
{
  gbe_block b = ffeste_top_block_;

  assert (b);
  assert (! b->is_stmt);
  assert (b->block == block);
  assert (! b->is_stmt);

  ffeste_top_block_ = b->outer;

  free (b);