io.c

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

  if (m != MATCH_YES)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  cp = gfc_get_code ();
  cp->op = EXEC_TRANSFER;
  cp->expr = expr;

  *cpp = cp;
  return MATCH_YES;
}


/* Match an I/O list, building gfc_code structures as we go.  */

static match
match_io_list (io_kind k, gfc_code ** head_p)
{
  gfc_code *head, *tail, *new;
  match m;

  *head_p = head = tail = NULL;
  if (gfc_match_eos () == MATCH_YES)
    return MATCH_YES;

  for (;;)
    {
      m = match_io_element (k, &new);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      tail = gfc_append_code (tail, new);
      if (head == NULL)
	head = new;

      if (gfc_match_eos () == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

  *head_p = head;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));

cleanup:
  gfc_free_statements (head);
  return MATCH_ERROR;
}


/* Attach the data transfer end node.  */

static void
terminate_io (gfc_code * io_code)
{
  gfc_code *c;

  if (io_code == NULL)
    io_code = new_st.block;

  c = gfc_get_code ();
  c->op = EXEC_DT_END;

  /* Point to structure that is already there */
  c->ext.dt = new_st.ext.dt;
  gfc_append_code (io_code, c);
}


/* Check the constraints for a data transfer statement.  The majority of the
   constraints appearing in 9.4 of the standard appear here.  Some are handled
   in resolve_tag and others in gfc_resolve_dt.  */

static match
check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
{
#define io_constraint(condition,msg,arg)\
if (condition) \
  {\
    gfc_error(msg,arg);\
    m = MATCH_ERROR;\
  }

  match m;
  gfc_expr * expr;
  gfc_symbol * sym = NULL;

  m = MATCH_YES;

  expr = dt->io_unit;
  if (expr && expr->expr_type == EXPR_VARIABLE
	&& expr->ts.type == BT_CHARACTER)
    {
      sym = expr->symtree->n.sym;

      io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
		     "Internal file at %L must not be INTENT(IN)",
		     &expr->where);

      io_constraint (gfc_has_vector_index (dt->io_unit),
		     "Internal file incompatible with vector subscript at %L",
		     &expr->where);

      io_constraint (dt->rec != NULL,
		     "REC tag at %L is incompatible with internal file",
		     &dt->rec->where);

      io_constraint (dt->namelist != NULL,
		     "Internal file at %L is incompatible with namelist",
		     &expr->where);

      io_constraint (dt->advance != NULL,
		     "ADVANCE tag at %L is incompatible with internal file",
		     &dt->advance->where);
    }

  if (expr && expr->ts.type != BT_CHARACTER)
    {

      io_constraint (gfc_pure (NULL)
		       && (k == M_READ || k == M_WRITE),
		     "IO UNIT in %s statement at %C must be "
		     "an internal file in a PURE procedure",
		     io_kind_name (k));
    }


  if (k != M_READ)
    {
      io_constraint (dt->end,
		     "END tag not allowed with output at %L",
		     &dt->end_where);

      io_constraint (dt->eor,
		     "EOR tag not allowed with output at %L",
		     &dt->eor_where);

      io_constraint (k != M_READ && dt->size,
		     "SIZE=specifier not allowed with output at %L",
		     &dt->size->where);
    }
  else
    {
      io_constraint (dt->size && dt->advance == NULL,
		     "SIZE tag at %L requires an ADVANCE tag",
		     &dt->size->where);

      io_constraint (dt->eor && dt->advance == NULL,
		     "EOR tag at %L requires an ADVANCE tag",
		     &dt->eor_where);
    }



  if (dt->namelist)
    {
      io_constraint (io_code && dt->namelist,
		     "NAMELIST cannot be followed by IO-list at %L",
		     &io_code->loc);

      io_constraint (dt->format_expr,
		     "IO spec-list cannot contain both NAMELIST group name "
		     "and format specification at %L.",
		     &dt->format_expr->where);

      io_constraint (dt->format_label,
		     "IO spec-list cannot contain both NAMELIST group name "
		     "and format label at %L", spec_end);

      io_constraint (dt->rec,
		     "NAMELIST IO is not allowed with a REC=specifier "
		     "at %L.", &dt->rec->where);

      io_constraint (dt->advance,
		     "NAMELIST IO is not allowed with a ADVANCE=specifier "
		     "at %L.", &dt->advance->where);
    }

  if (dt->rec)
    {
      io_constraint (dt->end,
		     "An END tag is not allowed with a "
		     "REC=specifier at %L.", &dt->end_where);


      io_constraint (dt->format_label == &format_asterisk,
		     "FMT=* is not allowed with a REC=specifier "
		     "at %L.", spec_end);
    }

  if (dt->advance)
    {
      const char * advance;
      int not_yes, not_no;
      expr = dt->advance;
      advance = expr->value.character.string;

      io_constraint (dt->format_label == &format_asterisk,
		     "List directed format(*) is not allowed with a "
		     "ADVANCE=specifier at %L.", &expr->where);

      not_no = strncasecmp (advance, "no", 2) != 0;
      not_yes = strncasecmp (advance, "yes", 2) != 0;

      io_constraint (expr->expr_type == EXPR_CONSTANT
		       && not_no && not_yes,
		     "ADVANCE=specifier at %L must have value = "
		     "YES or NO.", &expr->where);

      io_constraint (dt->size && expr->expr_type == EXPR_CONSTANT
		       && not_no && k == M_READ,
		     "SIZE tag at %L requires an ADVANCE = 'NO'",
		     &dt->size->where);

      io_constraint (dt->eor && expr->expr_type == EXPR_CONSTANT 
		       && not_no && k == M_READ,
		     "EOR tag at %L requires an ADVANCE = 'NO'",
		     &dt->eor_where);      
    }

  expr = dt->format_expr;
  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
    check_format_string (expr);

  return m;
}
#undef io_constraint

/* Match a READ, WRITE or PRINT statement.  */

static match
match_io (io_kind k)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_code *io_code;
  gfc_symbol *sym;
  int comma_flag, c;
  locus where;
  locus spec_end;
  gfc_dt *dt;
  match m;

  where = gfc_current_locus;
  comma_flag = 0;
  current_dt = dt = gfc_getmem (sizeof (gfc_dt));
  if (gfc_match_char ('(') == MATCH_NO)
    {
      where = gfc_current_locus;
      if (k == M_WRITE)
	goto syntax;
      else if (k == M_PRINT)
	{
	  /* Treat the non-standard case of PRINT namelist.  */
	  if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
	      && gfc_match_name (name) == MATCH_YES)
	    {
	      gfc_find_symbol (name, NULL, 1, &sym);
	      if (sym && sym->attr.flavor == FL_NAMELIST)
		{
		  if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
				      "%C is an extension") == FAILURE)
		    {
		      m = MATCH_ERROR;
		      goto cleanup;
		    }

		  dt->io_unit = default_unit (k);
		  dt->namelist = sym;
		  goto get_io_list;
		}
	      else
		gfc_current_locus = where;
	    }
	}

      if (gfc_current_form == FORM_FREE)
	{
	  c = gfc_peek_char();
	  if (c != ' ' && c != '*' && c != '\'' && c != '"')
	    {
	      m = MATCH_NO;
	      goto cleanup;
	    }
	}

      m = match_dt_format (dt);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      comma_flag = 1;
      dt->io_unit = default_unit (k);
      goto get_io_list;
    }

  /* Match a control list */
  if (match_dt_element (k, dt) == MATCH_YES)
    goto next;
  if (match_dt_unit (k, dt) != MATCH_YES)
    goto loop;

  if (gfc_match_char (')') == MATCH_YES)
    goto get_io_list;
  if (gfc_match_char (',') != MATCH_YES)
    goto syntax;

  m = match_dt_element (k, dt);
  if (m == MATCH_YES)
    goto next;
  if (m == MATCH_ERROR)
    goto cleanup;

  m = match_dt_format (dt);
  if (m == MATCH_YES)
    goto next;
  if (m == MATCH_ERROR)
    goto cleanup;

  where = gfc_current_locus;

  m = gfc_match_name (name);
  if (m == MATCH_YES)
    {
      gfc_find_symbol (name, NULL, 1, &sym);
      if (sym && sym->attr.flavor == FL_NAMELIST)
	{
	  dt->namelist = sym;
	  if (k == M_READ && check_namelist (sym))
	    {
	      m = MATCH_ERROR;
	      goto cleanup;
	    }
	  goto next;
	}
    }

  gfc_current_locus = where;

  goto loop;			/* No matches, try regular elements */

next:
  if (gfc_match_char (')') == MATCH_YES)
    goto get_io_list;
  if (gfc_match_char (',') != MATCH_YES)
    goto syntax;

loop:
  for (;;)
    {
      m = match_dt_element (k, dt);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto cleanup;

      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;
    }

get_io_list:

  /* Used in check_io_constraints, where no locus is available.  */
  spec_end = gfc_current_locus;

  /* Optional leading comma (non-standard).  */
  if (!comma_flag
      && gfc_match_char (',') == MATCH_YES
      && k == M_WRITE
      && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before output "
			 "item list at %C is an extension") == FAILURE)
    return MATCH_ERROR;

  io_code = NULL;
  if (gfc_match_eos () != MATCH_YES)
    {
      if (comma_flag && gfc_match_char (',') != MATCH_YES)
	{
	  gfc_error ("Expected comma in I/O list at %C");
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      m = match_io_list (k, &io_code);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;
    }

  /* A full IO statement has been matched.  Check the constraints.  spec_end is
     supplied for cases where no locus is supplied.  */
  m = check_io_constraints (k, dt, io_code, &spec_end);

  if (m == MATCH_ERROR)
    goto cleanup;

  new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
  new_st.ext.dt = dt;
  new_st.block = gfc_get_code ();
  new_st.block->op = new_st.op;
  new_st.block->next = io_code;

  terminate_io (io_code);

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
  m = MATCH_ERROR;

cleanup:
  gfc_free_dt (dt);
  return m;
}


match
gfc_match_read (void)
{
  return match_io (M_READ);
}

match
gfc_match_write (void)
{
  return match_io (M_WRITE);
}

match
gfc_match_print (void)
{
  match m;

  m = match_io (M_PRINT);
  if (m != MATCH_YES)
    return m;

  if (gfc_pure (NULL))
    {
      gfc_error ("PRINT statement at %C not allowed within PURE procedure");
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Free a gfc_inquire structure.  */

void
gfc_free_inquire (gfc_inquire * inquire)
{

  if (inquire == NULL)
    return;

  gfc_free_expr (inquire->unit);
  gfc_free_expr (inquire->file);
  gfc_free_expr (inquire->iomsg);
  gfc_free_expr (inquire->iostat);
  gfc_free_expr (inquire->exist);
  gfc_free_expr (inquire->opened);
  gfc_free_expr (inquire->number);
  gfc_free_expr (inquire->named);
  gfc_free_expr (inquire->name);
  gfc_free_expr (inquire->access);
  gfc_free_expr (inquire->sequential);
  gfc_free_expr (inquire->direct);
  gfc_free_expr (inquire->form);
  gfc_free_expr (inquire->formatted);
  gfc_free_expr (inquire->unformatted);
  gfc_free_expr (inquire->recl);
  gfc_free_expr (inquire->nextrec);
  gfc_free_expr (inquire->blank);
  gfc_free_expr (inquire->position);
  gfc_free_expr (inquire->action);
  gfc_free_expr (inquire->read);
  gfc_free_expr (inquire->write);
  gfc_free_expr (inquire->readwrite);
  gfc_free_expr (inquire->delim);
  gfc_free_expr (inquire->pad);
  gfc_free_expr (inquire->iolength);
  gfc_free_expr (inquire->convert);

  gfc_free (inquire);
}


/* Match an element of an INQUIRE statement.  */

#define RETM   if (m != MATCH_NO) return m;

static match
match_inquire_element (gfc_inquire * inquire)
{
  match m;

  m = match_etag (&tag_unit, &inquire->unit);
  RETM m = match_etag (&tag_file, &inquire->file);
  RETM m = match_ltag (&tag_err, &inquire->err);
  RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
  RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
  RETM m = match_vtag (&tag_exist, &inquire->exist);
  RETM m = match_vtag (&tag_opened, &inquire->opened);
  RETM m = match_vtag (&tag_named, &inquire->named);
  RETM m = match_vtag (&tag_name, &inquire->name);
  RETM m = match_out_tag (&tag_number, &inquire->number);
  RETM m = match_vtag (&tag_s_access, &inquire->access);
  RETM m = match_vtag (&tag_sequential, &inquire->sequential);
  RETM m = match_vtag (&tag_direct, &inquire->direct);
  RETM m = match_vtag (&tag_s_form, &inquire->form);
  RETM m = match_vtag (&tag_formatted, &inquire->formatted);
  RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
  RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
  RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
  RETM m = match_vtag (&tag_s_blank, &inquire->blank);
  RETM m = match_vtag (&tag_s_position, &inquire->position);
  RETM m = match_vtag (&tag_s_action, &inquire->action);
  RETM m = match_vtag (&tag_read, &inquire->read);
  RETM m = match_vtag (&tag_write, &inquire->write);
  RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
  RETM m = match_vtag (&tag_s_delim, &inquire->delim);
  RETM m = match_vtag (&tag_s_pad, &inquire->pad);
  RETM m = match_vtag (&tag_iolength, &inquire->iolength);
  RETM m = match_vtag (&tag_convert, &inquire->convert);
  RETM return MATCH_NO;
}

#undef RETM


match
gfc_match_inquire (void)
{
  gfc_inquire *inquire;
  gfc_code *code;
  match m;
  locus loc;

  m = gfc_match_char ('(');
  if (m == MATCH_NO)
    return m;

  inquire = gfc_getmem (sizeof (gfc_inquire));

  loc = gfc_current_locus;

  m = match_inquire_element (inquire);
  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    {
      m = gfc_match_expr (&inquire->unit);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;
    }

  /* See if we have the IOLENGTH form of the inquire statement.  */
  if (inquire->iolength != NULL)
    {
      if (gfc_match_char (')') != MATCH_YES)
	goto syntax;

      m = match_io_list (M_INQUIRE, &code);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      new_st.op = EXEC_IOLENGTH;
      new_st.expr = inquire->iolength;
      new_st.ext.inquire = inquire;

      if (gfc_pure (NULL))
	{
	  gfc_free_statements (code);
	  gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
	  return MATCH_ERROR;
	}

      new_st.block = gfc_get_code ();
      new_st.block->op = EXEC_IOLENGTH;
      terminate_io (code);
      new_st.block->next = code;
      return MATCH_YES;
    }

  /* At this point, we have the non-IOLENGTH inquire statement.  */
  for (;;)
    {
      if (gfc_match_char (')') == MATCH_YES)
	break;
      if (gfc_match_char (',') != MATCH_YES)
	goto syntax;

      m = match_inquire_element (inquire);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;

      if (inquire->iolength != NULL)
	{
	  gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
	  goto cleanup;
	}
    }

  if (gfc_match_eos () != MATCH_YES)
    goto syntax;

  if (inquire->unit != NULL && inquire->file != NULL)
    {
      gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
		 " UNIT specifiers", &loc);
      goto cleanup;
    }

  if (inquire->unit == NULL && inquire->file == NULL)
    {
      gfc_error ("INQUIRE statement at %L requires either FILE or"
		     " UNIT specifier", &loc);
      goto cleanup;
    }

  if (gfc_pure (NULL))
    {
      gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
      goto cleanup;
    }

  new_st.op = EXEC_INQUIRE;
  new_st.ext.inquire = inquire;
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_INQUIRE);

cleanup:
  gfc_free_inquire (inquire);
  return MATCH_ERROR;
}


/* Resolve everything in a gfc_inquire structure.  */

try
gfc_resolve_inquire (gfc_inquire * inquire)
{

  RESOLVE_TAG (&tag_unit, inquire->unit);
  RESOLVE_TAG (&tag_file, inquire->file);
  RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
  RESOLVE_TAG (&tag_iostat, inquire->iostat);
  RESOLVE_TAG (&tag_exist, inquire->exist);
  RESOLVE_TAG (&tag_opened, inquire->opened);
  RESOLVE_TAG (&tag_number, inquire->number);
  RESOLVE_TAG (&tag_named, inquire->named);
  RESOLVE_TAG (&tag_name, inquire->name);
  RESOLVE_TAG (&tag_s_access, inquire->access);
  RESOLVE_TAG (&tag_sequential, inquire->sequential);
  RESOLVE_TAG (&tag_direct, inquire->direct);
  RESOLVE_TAG (&tag_s_form, inquire->form);
  RESOLVE_TAG (&tag_formatted, inquire->formatted);
  RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
  RESOLVE_TAG (&tag_s_recl, inquire->recl);
  RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
  RESOLVE_TAG (&tag_s_blank, inquire->blank);
  RESOLVE_TAG (&tag_s_position, inquire->position);
  RESOLVE_TAG (&tag_s_action, inquire->action);
  RESOLVE_TAG (&tag_read, inquire->read);
  RESOLVE_TAG (&tag_write, inquire->write);
  RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
  RESOLVE_TAG (&tag_s_delim, inquire->delim);
  RESOLVE_TAG (&tag_s_pad, inquire->pad);
  RESOLVE_TAG (&tag_iolength, inquire->iolength);
  RESOLVE_TAG (&tag_convert, inquire->convert);

  if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
    return FAILURE;

  return SUCCESS;
}