intrinsic.c

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

/* Build up a list of intrinsic subroutines and functions for the
   name-resolution stage.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   Inc.
   Contributed by Andy Vaught & Katherine Holcomb

This file is part of GCC.

GCC 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.

GCC 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 GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"


/* Namespace to hold the resolved symbols for intrinsic subroutines.  */
static gfc_namespace *gfc_intrinsic_namespace;

int gfc_init_expr = 0;

/* Pointers to an intrinsic function and its argument names that are being
   checked.  */

const char *gfc_current_intrinsic;
const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
locus *gfc_current_intrinsic_where;

static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
static gfc_intrinsic_arg *next_arg;

static int nfunc, nsub, nargs, nconv;

static enum
{ SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
sizing;

#define REQUIRED	0
#define OPTIONAL	1

/* Return a letter based on the passed type.  Used to construct the
   name of a type-dependent subroutine.  */

char
gfc_type_letter (bt type)
{
  char c;

  switch (type)
    {
    case BT_LOGICAL:
      c = 'l';
      break;
    case BT_CHARACTER:
      c = 's';
      break;
    case BT_INTEGER:
      c = 'i';
      break;
    case BT_REAL:
      c = 'r';
      break;
    case BT_COMPLEX:
      c = 'c';
      break;

    case BT_HOLLERITH:
      c = 'h';
      break;

    default:
      c = 'u';
      break;
    }

  return c;
}


/* Get a symbol for a resolved name.  */

gfc_symbol *
gfc_get_intrinsic_sub_symbol (const char * name)
{
  gfc_symbol *sym;

  gfc_get_symbol (name, gfc_intrinsic_namespace, &sym);
  sym->attr.always_explicit = 1;
  sym->attr.subroutine = 1;
  sym->attr.flavor = FL_PROCEDURE;
  sym->attr.proc = PROC_INTRINSIC;

  return sym;
}


/* Return a pointer to the name of a conversion function given two
   typespecs.  */

static const char *
conv_name (gfc_typespec * from, gfc_typespec * to)
{
  static char name[30];

  sprintf (name, "__convert_%c%d_%c%d", gfc_type_letter (from->type),
	   from->kind, gfc_type_letter (to->type), to->kind);

  return gfc_get_string (name);
}


/* Given a pair of typespecs, find the gfc_intrinsic_sym node that
   corresponds to the conversion.  Returns NULL if the conversion
   isn't found.  */

static gfc_intrinsic_sym *
find_conv (gfc_typespec * from, gfc_typespec * to)
{
  gfc_intrinsic_sym *sym;
  const char *target;
  int i;

  target = conv_name (from, to);
  sym = conversion;

  for (i = 0; i < nconv; i++, sym++)
    if (strcmp (target, sym->name) == 0)
      return sym;

  return NULL;
}


/* Interface to the check functions.  We break apart an argument list
   and call the proper check function rather than forcing each
   function to manipulate the argument list.  */

static try
do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
{
  gfc_expr *a1, *a2, *a3, *a4, *a5;

  if (arg == NULL)
    return (*specific->check.f0) ();

  a1 = arg->expr;
  arg = arg->next;
  if (arg == NULL)
    return (*specific->check.f1) (a1);

  a2 = arg->expr;
  arg = arg->next;
  if (arg == NULL)
    return (*specific->check.f2) (a1, a2);

  a3 = arg->expr;
  arg = arg->next;
  if (arg == NULL)
    return (*specific->check.f3) (a1, a2, a3);

  a4 = arg->expr;
  arg = arg->next;
  if (arg == NULL)
    return (*specific->check.f4) (a1, a2, a3, a4);

  a5 = arg->expr;
  arg = arg->next;
  if (arg == NULL)
    return (*specific->check.f5) (a1, a2, a3, a4, a5);

  gfc_internal_error ("do_check(): too many args");
}


/*********** Subroutines to build the intrinsic list ****************/

/* Add a single intrinsic symbol to the current list.

   Argument list:
      char *     name of function
      int        whether function is elemental
      int        If the function can be used as an actual argument
      bt         return type of function
      int        kind of return type of function
      int        Fortran standard version
      check      pointer to check function
      simplify   pointer to simplification function
      resolve    pointer to resolution function

   Optional arguments come in multiples of four:
      char *    name of argument
      bt        type of argument
      int       kind of argument
      int       arg optional flag (1=optional, 0=required)

   The sequence is terminated by a NULL name.

   TODO: Are checks on actual_ok implemented elsewhere, or is that just
   missing here?  */

static void
add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED,
	 bt type, int kind, int standard, gfc_check_f check,
	 gfc_simplify_f simplify, gfc_resolve_f resolve, ...)
{
  char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0'  */
  int optional, first_flag;
  va_list argp;

  /* 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)
    {
    case SZ_SUBS:
      nsub++;
      break;

    case SZ_FUNCS:
      nfunc++;
      break;

    case SZ_NOTHING:
      next_sym->name = gfc_get_string (name);

      strcpy (buf, "_gfortran_");
      strcat (buf, name);
      next_sym->lib_name = gfc_get_string (buf);

      next_sym->elemental = elemental;
      next_sym->ts.type = type;
      next_sym->ts.kind = kind;
      next_sym->standard = standard;
      next_sym->simplify = simplify;
      next_sym->check = check;
      next_sym->resolve = resolve;
      next_sym->specific = 0;
      next_sym->generic = 0;
      break;

    default:
      gfc_internal_error ("add_sym(): Bad sizing mode");
    }

  va_start (argp, resolve);

  first_flag = 1;

  for (;;)
    {
      name = va_arg (argp, char *);
      if (name == NULL)
	break;

      type = (bt) va_arg (argp, int);
      kind = va_arg (argp, int);
      optional = va_arg (argp, int);

      if (sizing != SZ_NOTHING)
	nargs++;
      else
	{
	  next_arg++;

	  if (first_flag)
	    next_sym->formal = next_arg;
	  else
	    (next_arg - 1)->next = next_arg;

	  first_flag = 0;

	  strcpy (next_arg->name, name);
	  next_arg->ts.type = type;
	  next_arg->ts.kind = kind;
	  next_arg->optional = optional;
	}
    }

  va_end (argp);

  next_sym++;
}


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

static void
add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
		       int kind, int standard,
		       try (*check)(void),
		       gfc_expr *(*simplify)(void),
	   void (*resolve)(gfc_expr *))
{
  gfc_simplify_f sf;
  gfc_check_f cf;
  gfc_resolve_f rf;

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

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
	   (void*)0);
}


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

static void
add_sym_0s (const char * name, int actual_ok, int standard,
	    void (*resolve)(gfc_code *))
{
  gfc_check_f cf;
  gfc_simplify_f sf;
  gfc_resolve_f rf;

  cf.f1 = NULL;
  sf.f1 = NULL;
  rf.s1 = resolve;

  add_sym (name, 1, actual_ok, BT_UNKNOWN, 0, standard, cf, sf, rf,
	   (void*)0);
}


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

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

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

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


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

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

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

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


/* Add a symbol from the MAX/MIN family of intrinsic functions to the
   function.  MAX et al take 2 or more arguments.  */

static void
add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
			int kind, int standard,
			try (*check)(gfc_actual_arglist *),
			gfc_expr *(*simplify)(gfc_expr *),
			void (*resolve)(gfc_expr *,gfc_actual_arglist *),
			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.f1m = check;
  sf.f1 = simplify;
  rf.f1m = resolve;

  add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,