intrinsic.c

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

	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   (void*)0);
}


/* Add a symbol to the function list where the function takes
   2 arguments.  */

static void
add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
		       int kind, int standard,
		       try (*check)(gfc_expr *,gfc_expr *),
		       gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
		       void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *),
		       const char* a1, bt type1, int kind1, int optional1,
	   const char* a2, bt type2, int kind2, int optional2)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f2 = check;
  sf.f2 = simplify;
  rf.f2 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   (void*)0);
}


/* Add a symbol to the subroutine list where the subroutine takes
   2 arguments.  */

static void
add_sym_2s (const char *name, int elemental, int actual_ok, bt type,
			int kind, int standard,
		       try (*check)(gfc_expr *,gfc_expr *),
		       gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
		       void (*resolve)(gfc_code *),
		       const char* a1, bt type1, int kind1, int optional1,
	    const char* a2, bt type2, int kind2, int optional2)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f2 = check;
  sf.f2 = simplify;
  rf.s1 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   (void*)0);
}


/* Add a symbol to the function list where the function takes
   3 arguments.  */

static void
add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
		       int kind, int standard,
		       try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
		       gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
		       void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
		       const char* a1, bt type1, int kind1, int optional1,
		       const char* a2, bt type2, int kind2, int optional2,
	   const char* a3, bt type3, int kind3, int optional3)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f3 = check;
  sf.f3 = simplify;
  rf.f3 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   (void*)0);
}


/* MINLOC and MAXLOC get special treatment because their argument
   might have to be reordered.  */

static void
add_sym_3ml (const char *name, int elemental, 
			 int actual_ok, bt type, int kind, int standard,
			 try (*check)(gfc_actual_arglist *),
			 gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
			 void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
			 const char* a1, bt type1, int kind1, int optional1,
			 const char* a2, bt type2, int kind2, int optional2,
	     const char* a3, bt type3, int kind3, int optional3)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f3ml = check;
  sf.f3 = simplify;
  rf.f3 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   (void*)0);
}


/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
   their argument also might have to be reordered.  */

static void
add_sym_3red (const char *name, int elemental, 
                          int actual_ok, bt type, int kind, int standard,
                          try (*check)(gfc_actual_arglist *),
                          gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
                          void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
                          const char* a1, bt type1, int kind1, int optional1,
                          const char* a2, bt type2, int kind2, int optional2,
	      const char* a3, bt type3, int kind3, int optional3)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f3red = check;
  sf.f3 = simplify;
  rf.f3 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   (void*)0);
}


/* Add a symbol to the subroutine list where the subroutine takes
   3 arguments.  */

static void
add_sym_3s (const char *name, int elemental, int actual_ok, bt type,
			int kind, int standard,
		       try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
		       gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
		       void (*resolve)(gfc_code *),
		       const char* a1, bt type1, int kind1, int optional1,
		       const char* a2, bt type2, int kind2, int optional2,
	    const char* a3, bt type3, int kind3, int optional3)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f3 = check;
  sf.f3 = simplify;
  rf.s1 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   (void*)0);
}


/* Add a symbol to the function list where the function takes
   4 arguments.  */

static void
add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
		       int kind, int standard,
		       try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
		       gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
		       void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
		       const char* a1, bt type1, int kind1, int optional1,
		       const char* a2, bt type2, int kind2, int optional2,
		       const char* a3, bt type3, int kind3, int optional3,
	   const char* a4, bt type4, int kind4, int optional4 )
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f4 = check;
  sf.f4 = simplify;
  rf.f4 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   a4, type4, kind4, optional4,
	   (void*)0);
}


/* Add a symbol to the subroutine list where the subroutine takes
   4 arguments.  */

static void
add_sym_4s (const char *name, int elemental, int actual_ok,
			bt type, int kind, int standard,
    try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
    gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
    void (*resolve)(gfc_code *),
    const char* a1, bt type1, int kind1, int optional1,
    const char* a2, bt type2, int kind2, int optional2,
    const char* a3, bt type3, int kind3, int optional3,
    const char* a4, bt type4, int kind4, int optional4)
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f4 = check;
  sf.f4 = simplify;
  rf.s1 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   a4, type4, kind4, optional4,
	   (void*)0);
}


/* Add a symbol to the subroutine list where the subroutine takes
   5 arguments.  */

static void
add_sym_5s (const char *name, int elemental, int actual_ok, 
 bt type, int kind, int standard,
 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 void (*resolve)(gfc_code *),
 const char* a1, bt type1, int kind1, int optional1,
 const char* a2, bt type2, int kind2, int optional2,
 const char* a3, bt type3, int kind3, int optional3,
 const char* a4, bt type4, int kind4, int optional4,
 const char* a5, bt type5, int kind5, int optional5) 
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f5 = check;
  sf.f5 = simplify;
  rf.s1 = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   a1, type1, kind1, optional1,
	   a2, type2, kind2, optional2,
	   a3, type3, kind3, optional3,
	   a4, type4, kind4, optional4,
	   a5, type5, kind5, optional5,
	   (void*)0);
}


/* Locate an intrinsic symbol given a base pointer, number of elements
   in the table and a pointer to a name.  Returns the NULL pointer if
   a name is not found.  */

static gfc_intrinsic_sym *
find_sym (gfc_intrinsic_sym * start, int n, const char *name)
{

  while (n > 0)
    {
      if (strcmp (name, start->name) == 0)
	return start;

      start++;
      n--;
    }

  return NULL;
}


/* Given a name, find a function in the intrinsic function table.
   Returns NULL if not found.  */

gfc_intrinsic_sym *
gfc_find_function (const char *name)
{
  gfc_intrinsic_sym *sym;

  sym = find_sym (functions, nfunc, name);
  if (!sym)
    sym = find_sym (conversion, nconv, name);

  return sym;
}


/* Given a name, find a function in the intrinsic subroutine table.
   Returns NULL if not found.  */

static gfc_intrinsic_sym *
find_subroutine (const char *name)
{

  return find_sym (subroutines, nsub, name);
}


/* Given a string, figure out if it is the name of a generic intrinsic
   function or not.  */

int
gfc_generic_intrinsic (const char *name)
{
  gfc_intrinsic_sym *sym;

  sym = gfc_find_function (name);
  return (sym == NULL) ? 0 : sym->generic;
}


/* Given a string, figure out if it is the name of a specific
   intrinsic function or not.  */

int
gfc_specific_intrinsic (const char *name)
{
  gfc_intrinsic_sym *sym;

  sym = gfc_find_function (name);
  return (sym == NULL) ? 0 : sym->specific;
}


/* Given a string, figure out if it is the name of an intrinsic
   subroutine or function.  There are no generic intrinsic
   subroutines, they are all specific.  */

int
gfc_intrinsic_name (const char *name, int subroutine_flag)
{

  return subroutine_flag ?
    find_subroutine (name) != NULL : gfc_find_function (name) != NULL;
}


/* Collect a set of intrinsic functions into a generic collection.
   The first argument is the name of the generic function, which is
   also the name of a specific function.  The rest of the specifics
   currently in the table are placed into the list of specific
   functions associated with that generic.  */

static void
make_generic (const char *name, gfc_generic_isym_id generic_id, int standard)
{
  gfc_intrinsic_sym *g;

  if (!(gfc_option.allow_std & standard))
    return;

  if (sizing != SZ_NOTHING)
    return;

  g = gfc_find_function (name);
  if (g == NULL)
    gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
			name);

  g->generic = 1;
  g->specific = 1;
  g->generic_id = generic_id;
  if ((g + 1)->name != NULL)
    g->specific_head = g + 1;
  g++;

  while (g->name != NULL)
    {
      g->next = g + 1;
      g->specific = 1;
      g->generic_id = generic_id;
      g++;
    }

  g--;
  g->next = NULL;
}


/* Create a duplicate intrinsic function entry for the current
   function, the only difference being the alternate name.  Note that
   we use argument lists more than once, but all argument lists are
   freed as a single block.  */

static void
make_alias (const char *name, int standard)
{

  /* First check that the intrinsic belongs to the selected standard.
     If not, don't add it to the symbol list.  */
  if (!(gfc_option.allow_std & standard))
    return;

  switch (sizing)