module.c

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

  mio_lparen ();
  mio_pool_string (&a->name);
  mio_expr (&a->expr);
  mio_rparen ();
}


static void
mio_actual_arglist (gfc_actual_arglist ** ap)
{
  gfc_actual_arglist *a, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (a = *ap; a; a = a->next)
	mio_actual_arg (a);

    }
  else
    {
      tail = NULL;

      for (;;)
	{
	  if (peek_atom () != ATOM_LPAREN)
	    break;

	  a = gfc_get_actual_arglist ();

	  if (tail == NULL)
	    *ap = a;
	  else
	    tail->next = a;

	  tail = a;
	  mio_actual_arg (a);
	}
    }

  mio_rparen ();
}


/* Read and write formal argument lists.  */

static void
mio_formal_arglist (gfc_symbol * sym)
{
  gfc_formal_arglist *f, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (f = sym->formal; f; f = f->next)
	mio_symbol_ref (&f->sym);

    }
  else
    {
      sym->formal = tail = NULL;

      while (peek_atom () != ATOM_RPAREN)
	{
	  f = gfc_get_formal_arglist ();
	  mio_symbol_ref (&f->sym);

	  if (sym->formal == NULL)
	    sym->formal = f;
	  else
	    tail->next = f;

	  tail = f;
	}
    }

  mio_rparen ();
}


/* Save or restore a reference to a symbol node.  */

void
mio_symbol_ref (gfc_symbol ** symp)
{
  pointer_info *p;

  p = mio_pointer_ref (symp);
  if (p->type == P_UNKNOWN)
    p->type = P_SYMBOL;

  if (iomode == IO_OUTPUT)
    {
      if (p->u.wsym.state == UNREFERENCED)
	p->u.wsym.state = NEEDS_WRITE;
    }
  else
    {
      if (p->u.rsym.state == UNUSED)
	p->u.rsym.state = NEEDED;
    }
}


/* Save or restore a reference to a symtree node.  */

static void
mio_symtree_ref (gfc_symtree ** stp)
{
  pointer_info *p;
  fixup_t *f;
  gfc_symtree * ns_st = NULL;

  if (iomode == IO_OUTPUT)
    {
      /* If this is a symtree for a symbol that came from a contained module
	 namespace, it has a unique name and we should look in the current
	 namespace to see if the required, non-contained symbol is available
	 yet. If so, the latter should be written.  */
      if ((*stp)->n.sym && check_unique_name((*stp)->name))
	ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
				    (*stp)->n.sym->name);

      /* On the other hand, if the existing symbol is the module name or the
	 new symbol is a dummy argument, do not do the promotion.  */
      if (ns_st && ns_st->n.sym
	    && ns_st->n.sym->attr.flavor != FL_MODULE
	    && !(*stp)->n.sym->attr.dummy)
	mio_symbol_ref (&ns_st->n.sym);
      else
	mio_symbol_ref (&(*stp)->n.sym);
    }
  else
    {
      require_atom (ATOM_INTEGER);
      p = get_integer (atom_int);
      if (p->type == P_UNKNOWN)
        p->type = P_SYMBOL;

      if (p->u.rsym.state == UNUSED)
	p->u.rsym.state = NEEDED;

      if (p->u.rsym.symtree != NULL)
        {
          *stp = p->u.rsym.symtree;
        }
      else
        {
          f = gfc_getmem (sizeof (fixup_t));

          f->next = p->u.rsym.stfixup;
          p->u.rsym.stfixup = f;

          f->pointer = (void **)stp;
        }
    }
}

static void
mio_iterator (gfc_iterator ** ip)
{
  gfc_iterator *iter;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      if (*ip == NULL)
	goto done;
    }
  else
    {
      if (peek_atom () == ATOM_RPAREN)
	{
	  *ip = NULL;
	  goto done;
	}

      *ip = gfc_get_iterator ();
    }

  iter = *ip;

  mio_expr (&iter->var);
  mio_expr (&iter->start);
  mio_expr (&iter->end);
  mio_expr (&iter->step);

done:
  mio_rparen ();
}



static void
mio_constructor (gfc_constructor ** cp)
{
  gfc_constructor *c, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (c = *cp; c; c = c->next)
	{
	  mio_lparen ();
	  mio_expr (&c->expr);
	  mio_iterator (&c->iterator);
	  mio_rparen ();
	}
    }
  else
    {

      *cp = NULL;
      tail = NULL;

      while (peek_atom () != ATOM_RPAREN)
	{
	  c = gfc_get_constructor ();

	  if (tail == NULL)
	    *cp = c;
	  else
	    tail->next = c;

	  tail = c;

	  mio_lparen ();
	  mio_expr (&c->expr);
	  mio_iterator (&c->iterator);
	  mio_rparen ();
	}
    }

  mio_rparen ();
}



static const mstring ref_types[] = {
    minit ("ARRAY", REF_ARRAY),
    minit ("COMPONENT", REF_COMPONENT),
    minit ("SUBSTRING", REF_SUBSTRING),
    minit (NULL, -1)
};


static void
mio_ref (gfc_ref ** rp)
{
  gfc_ref *r;

  mio_lparen ();

  r = *rp;
  r->type = MIO_NAME(ref_type) (r->type, ref_types);

  switch (r->type)
    {
    case REF_ARRAY:
      mio_array_ref (&r->u.ar);
      break;

    case REF_COMPONENT:
      mio_symbol_ref (&r->u.c.sym);
      mio_component_ref (&r->u.c.component, r->u.c.sym);
      break;

    case REF_SUBSTRING:
      mio_expr (&r->u.ss.start);
      mio_expr (&r->u.ss.end);
      mio_charlen (&r->u.ss.length);
      break;
    }

  mio_rparen ();
}


static void
mio_ref_list (gfc_ref ** rp)
{
  gfc_ref *ref, *head, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (ref = *rp; ref; ref = ref->next)
	mio_ref (&ref);
    }
  else
    {
      head = tail = NULL;

      while (peek_atom () != ATOM_RPAREN)
	{
	  if (head == NULL)
	    head = tail = gfc_get_ref ();
	  else
	    {
	      tail->next = gfc_get_ref ();
	      tail = tail->next;
	    }

	  mio_ref (&tail);
	}

      *rp = head;
    }

  mio_rparen ();
}


/* Read and write an integer value.  */

static void
mio_gmp_integer (mpz_t * integer)
{
  char *p;

  if (iomode == IO_INPUT)
    {
      if (parse_atom () != ATOM_STRING)
	bad_module ("Expected integer string");

      mpz_init (*integer);
      if (mpz_set_str (*integer, atom_string, 10))
	bad_module ("Error converting integer");

      gfc_free (atom_string);

    }
  else
    {
      p = mpz_get_str (NULL, 10, *integer);
      write_atom (ATOM_STRING, p);
      gfc_free (p);
    }
}


static void
mio_gmp_real (mpfr_t * real)
{
  mp_exp_t exponent;
  char *p;

  if (iomode == IO_INPUT)
    {
      if (parse_atom () != ATOM_STRING)
	bad_module ("Expected real string");

      mpfr_init (*real);
      mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
      gfc_free (atom_string);

    }
  else
    {
      p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
      atom_string = gfc_getmem (strlen (p) + 20);

      sprintf (atom_string, "0.%s@%ld", p, exponent);

      /* Fix negative numbers.  */
      if (atom_string[2] == '-')
	{
	  atom_string[0] = '-';
	  atom_string[1] = '0';
	  atom_string[2] = '.';
	}

      write_atom (ATOM_STRING, atom_string);

      gfc_free (atom_string);
      gfc_free (p);
    }
}


/* Save and restore the shape of an array constructor.  */

static void
mio_shape (mpz_t ** pshape, int rank)
{
  mpz_t *shape;
  atom_type t;
  int n;

  /* A NULL shape is represented by ().  */
  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      shape = *pshape;
      if (!shape)
	{
	  mio_rparen ();
	  return;
	}
    }
  else
    {
      t = peek_atom ();
      if (t == ATOM_RPAREN)
	{
	  *pshape = NULL;
	  mio_rparen ();
	  return;
	}

      shape = gfc_get_shape (rank);
      *pshape = shape;
    }

  for (n = 0; n < rank; n++)
    mio_gmp_integer (&shape[n]);

  mio_rparen ();
}


static const mstring expr_types[] = {
    minit ("OP", EXPR_OP),
    minit ("FUNCTION", EXPR_FUNCTION),
    minit ("CONSTANT", EXPR_CONSTANT),
    minit ("VARIABLE", EXPR_VARIABLE),
    minit ("SUBSTRING", EXPR_SUBSTRING),
    minit ("STRUCTURE", EXPR_STRUCTURE),
    minit ("ARRAY", EXPR_ARRAY),
    minit ("NULL", EXPR_NULL),
    minit (NULL, -1)
};

/* INTRINSIC_ASSIGN is missing because it is used as an index for
   generic operators, not in expressions.  INTRINSIC_USER is also
   replaced by the correct function name by the time we see it.  */

static const mstring intrinsics[] =
{
    minit ("UPLUS", INTRINSIC_UPLUS),
    minit ("UMINUS", INTRINSIC_UMINUS),
    minit ("PLUS", INTRINSIC_PLUS),
    minit ("MINUS", INTRINSIC_MINUS),
    minit ("TIMES", INTRINSIC_TIMES),
    minit ("DIVIDE", INTRINSIC_DIVIDE),
    minit ("POWER", INTRINSIC_POWER),
    minit ("CONCAT", INTRINSIC_CONCAT),
    minit ("AND", INTRINSIC_AND),
    minit ("OR", INTRINSIC_OR),
    minit ("EQV", INTRINSIC_EQV),
    minit ("NEQV", INTRINSIC_NEQV),
    minit ("EQ", INTRINSIC_EQ),
    minit ("NE", INTRINSIC_NE),
    minit ("GT", INTRINSIC_GT),
    minit ("GE", INTRINSIC_GE),
    minit ("LT", INTRINSIC_LT),
    minit ("LE", INTRINSIC_LE),
    minit ("NOT", INTRINSIC_NOT),
    minit ("PARENTHESES", INTRINSIC_PARENTHESES),
    minit (NULL, -1)
};

/* Read and write expressions.  The form "()" is allowed to indicate a
   NULL expression.  */

static void
mio_expr (gfc_expr ** ep)
{
  gfc_expr *e;
  atom_type t;
  int flag;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      if (*ep == NULL)
	{
	  mio_rparen ();
	  return;
	}

      e = *ep;
      MIO_NAME(expr_t) (e->expr_type, expr_types);

    }
  else
    {
      t = parse_atom ();
      if (t == ATOM_RPAREN)
	{
	  *ep = NULL;
	  return;
	}

      if (t != ATOM_NAME)
	bad_module ("Expected expression type");

      e = *ep = gfc_get_expr ();
      e->where = gfc_current_locus;
      e->expr_type = (expr_t) find_enum (expr_types);
    }

  mio_typespec (&e->ts);
  mio_integer (&e->rank);

  switch (e->expr_type)
    {
    case EXPR_OP:
      e->value.op.operator
	= MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);

      switch (e->value.op.operator)
	{
	case INTRINSIC_UPLUS:
	case INTRINSIC_UMINUS:
	case INTRINSIC_NOT:
	case INTRINSIC_PARENTHESES:
	  mio_expr (&e->value.op.op1);
	  break;

	case INTRINSIC_PLUS:
	case INTRINSIC_MINUS:
	case INTRINSIC_TIMES:
	case INTRINSIC_DIVIDE:
	case INTRINSIC_POWER:
	case INTRINSIC_CONCAT:
	case INTRINSIC_AND:
	case INTRINSIC_OR:
	case INTRINSIC_EQV:
	case INTRINSIC_NEQV:
	case INTRINSIC_EQ:
	case INTRINSIC_NE:
	case INTRINSIC_GT:
	case INTRINSIC_GE:
	case INTRINSIC_LT:
	case INTRINSIC_LE:
	  mio_expr (&e->value.op.op1);
	  mio_expr (&e->value.op.op2);
	  break;

	default:
	  bad_module ("Bad operator");
	}

      break;

    case EXPR_FUNCTION:
      mio_symtree_ref (&e->symtree);
      mio_actual_arglist (&e->value.function.actual);

      if (iomode == IO_OUTPUT)
	{
	  e->value.function.name
	    = mio_allocated_string (e->value.function.name);
	  flag = e->value.function.esym != NULL;
	  mio_integer (&flag);
	  if (flag)
	    mio_symbol_ref (&e->value.function.esym);
	  else
	    write_atom (ATOM_STRING, e->value.function.isym->name);

	}
      else
	{
	  require_atom (ATOM_STRING);
	  e->value.function.name = gfc_get_string (atom_string);
	  gfc_free (atom_string);

	  mio_integer (&flag);
	  if (flag)
	    mio_symbol_ref (&e->value.function.esym);
	  else
	    {
	      require_atom (ATOM_STRING);
	      e->value.function.isym = gfc_find_function (atom_string);
	      gfc_free (atom_string);
	    }
	}

      break;

    case EXPR_VARIABLE:
      mio_symtree_ref (&e->symtree);
      mio_ref_list (&e->ref);
      break;

    case EXPR_SUBSTRING:
      e->value.character.string = (char *)
	mio_allocated_string (e->value.character.string);
      mio_ref_list (&e->ref);
      break;

    case EXPR_STRUCTURE:
    case EXPR_ARRAY:
      mio_constructor (&e->value.constructor);
      mio_shape (&e->shape, e->rank);
      break;

    case EXPR_CONSTANT:
      switch (e->ts.type)
	{
	case BT_INTEGER:
	  mio_gmp_integer (&e->value.integer);
	  break;

	case BT_REAL:
          gfc_set_model_kind (e->ts.kind);
	  mio_gmp_real (&e->value.real);
	  break;

	case BT_COMPLEX:
          gfc_set_model_kind (e->ts.kind);
	  mio_gmp_real (&e->value.complex.r);
	  mio_gmp_real (&e->value.complex.i);
	  break;

	case BT_LOGICAL:
	  mio_integer (&e->value.logical);
	  break;

	case BT_CHARACTER:
	  mio_integer (&e->value.character.length);
	  e->value.character.string = (char *)
	    mio_allocated_string (e->value.character.string);
	  break;

	default:
	  bad_module ("Bad type in constant expression");
	}

      break;

    case EXPR_NULL:
      break;
    }

  mio_rparen ();
}


/* Read and write namelists */

static void
mio_namelist (gfc_symbol * sym)
{
  gfc_namelist *n, *m;
  const char *check_name;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (n = sym->namelist; n; n = n->next)
	mio_symbol_ref (&n->sym);
    }
  else