intrinsic.c

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

    {
    case SZ_FUNCS:
      nfunc++;
      break;

    case SZ_SUBS:
      nsub++;
      break;

    case SZ_NOTHING:
      next_sym[0] = next_sym[-1];
      next_sym->name = gfc_get_string (name);
      next_sym++;
      break;

    default:
      break;
    }
}

/* Make the current subroutine noreturn.  */

static void
make_noreturn(void)
{
  if (sizing == SZ_NOTHING)
      next_sym[-1].noreturn = 1;
}

/* Add intrinsic functions.  */

static void
add_functions (void)
{

  /* Argument names as in the standard (to be used as argument keywords).  */
  const char
    *a = "a", *f = "field", *pt = "pointer", *tg = "target",
    *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
    *c = "c", *n = "ncopies", *pos = "pos", *bck = "back",
    *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
    *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
    *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
    *p = "p", *ar = "array", *shp = "shape", *src = "source",
    *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
    *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
    *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
    *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
    *z = "z", *ln = "len", *ut = "unit", *han = "handler",
    *num = "number", *tm = "time";

  int di, dr, dd, dl, dc, dz, ii;

  di = gfc_default_integer_kind;
  dr = gfc_default_real_kind;
  dd = gfc_default_double_kind;
  dl = gfc_default_logical_kind;
  dc = gfc_default_character_kind;
  dz = gfc_default_complex_kind;
  ii = gfc_index_integer_kind;

  add_sym_1 ("abs", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
	     a, BT_REAL, dr, REQUIRED);

  add_sym_1 ("iabs", 1, 1, BT_INTEGER, di, GFC_STD_F77,
	     NULL, gfc_simplify_abs, gfc_resolve_abs,
	     a, BT_INTEGER, di, REQUIRED);

  add_sym_1 ("dabs", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_abs, gfc_resolve_abs,
	     a, BT_REAL, dd, REQUIRED);

  add_sym_1 ("cabs", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     NULL, gfc_simplify_abs, gfc_resolve_abs,
	     a, BT_COMPLEX, dz, REQUIRED);

  add_sym_1 ("zabs", 1, 1, BT_REAL, dd, GFC_STD_GNU, 
	     NULL, gfc_simplify_abs, gfc_resolve_abs, 
	     a, BT_COMPLEX, dd, REQUIRED);

  make_alias ("cdabs", GFC_STD_GNU);

  make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77);

  add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
	     gfc_check_achar, gfc_simplify_achar, NULL,
	     i, BT_INTEGER, di, REQUIRED);

  make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);

  add_sym_1 ("acos", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dacos", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_acos, gfc_resolve_acos,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);

  add_sym_1 ("acosh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_fn_r, gfc_simplify_acosh, gfc_resolve_acosh,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dacosh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
	     NULL, gfc_simplify_acosh, gfc_resolve_acosh,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_GNU);

  add_sym_1 ("adjustl", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
	     NULL, gfc_simplify_adjustl, NULL,
	     stg, BT_CHARACTER, dc, REQUIRED);

  make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);

  add_sym_1 ("adjustr", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
	     NULL, gfc_simplify_adjustr, NULL,
	     stg, BT_CHARACTER, dc, REQUIRED);

  make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);

  add_sym_1 ("aimag", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
	     z, BT_COMPLEX, dz, REQUIRED);

  make_alias ("imag", GFC_STD_GNU);
  make_alias ("imagpart", GFC_STD_GNU);

  add_sym_1 ("dimag", 1, 1, BT_REAL, dd, GFC_STD_GNU, 
	     NULL, gfc_simplify_aimag, gfc_resolve_aimag, 
	     z, BT_COMPLEX, dd, REQUIRED);


  make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);

  add_sym_2 ("aint", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);

  add_sym_1 ("dint", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_dint, gfc_resolve_dint,
	     a, BT_REAL, dd, REQUIRED);

  make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);

  add_sym_2 ("all", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
	     gfc_check_all_any, NULL, gfc_resolve_all,
	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);

  make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);

  add_sym_1 ("allocated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
	     gfc_check_allocated, NULL, NULL,
	     ar, BT_UNKNOWN, 0, REQUIRED);

  make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);

  add_sym_2 ("anint", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);

  add_sym_1 ("dnint", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_dnint, gfc_resolve_dnint,
	     a, BT_REAL, dd, REQUIRED);

  make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);

  add_sym_2 ("any", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
	     gfc_check_all_any, NULL, gfc_resolve_any,
	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);

  make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);

  add_sym_1 ("asin", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dasin", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_asin, gfc_resolve_asin,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
  
  add_sym_1 ("asinh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_fn_r, gfc_simplify_asinh, gfc_resolve_asinh,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dasinh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
	     NULL, gfc_simplify_asinh, gfc_resolve_asinh,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_GNU);

  add_sym_2 ("associated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
	     gfc_check_associated, NULL, NULL,
	     pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);

  make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);

  add_sym_1 ("atan", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("datan", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_atan, gfc_resolve_atan,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
  
  add_sym_1 ("atanh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_fn_r, gfc_simplify_atanh, gfc_resolve_atanh,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("datanh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
	     NULL, gfc_simplify_atanh, gfc_resolve_atanh,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_GNU);

  add_sym_2 ("atan2", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
	     y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);

  add_sym_2 ("datan2", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_atan2, gfc_resolve_atan2,
	     y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);

  make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
  
  /* Bessel and Neumann functions for G77 compatibility.  */
  add_sym_1 ("besj0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dbesj0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("besj0", GFC_ISYM_J0, GFC_STD_GNU);

  add_sym_1 ("besj1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dbesj1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("besj1", GFC_ISYM_J1, GFC_STD_GNU);

  add_sym_2 ("besjn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_besn, NULL, gfc_resolve_besn,
	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);

  add_sym_2 ("dbesjn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
	     gfc_check_besn, NULL, gfc_resolve_besn,
	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);

  make_generic ("besjn", GFC_ISYM_JN, GFC_STD_GNU);

  add_sym_1 ("besy0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dbesy0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("besy0", GFC_ISYM_Y0, GFC_STD_GNU);

  add_sym_1 ("besy1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dbesy1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
	     gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("besy1", GFC_ISYM_Y1, GFC_STD_GNU);

  add_sym_2 ("besyn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
	     gfc_check_besn, NULL, gfc_resolve_besn,
	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);

  add_sym_2 ("dbesyn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
	     gfc_check_besn, NULL, gfc_resolve_besn,
	     n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);

  make_generic ("besyn", GFC_ISYM_YN, GFC_STD_GNU);

  add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
	     gfc_check_i, gfc_simplify_bit_size, NULL,
	     i, BT_INTEGER, di, REQUIRED);

  make_generic ("bit_size", GFC_ISYM_NONE, GFC_STD_F95);

  add_sym_2 ("btest", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
	     gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);

  make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);

  add_sym_2 ("ceiling", 1, 1, BT_INTEGER, di, GFC_STD_F95,
	     gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
	     a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);

  make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);

  add_sym_2 ("char", 1, 0, BT_CHARACTER, dc, GFC_STD_F77,
	     gfc_check_char, gfc_simplify_char, gfc_resolve_char,
	     i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);

  make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);

  add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
	     gfc_check_chdir, NULL, gfc_resolve_chdir,
	     a, BT_CHARACTER, dc, REQUIRED);

  make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
  
  add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
	     gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
	     x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
	     kind, BT_INTEGER, di, OPTIONAL);

  make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);

  add_sym_2 ("complex", 1, 1, BT_COMPLEX, dz, GFC_STD_GNU,
	     gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
	     x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);

  make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);

  /* Making dcmplx a specific of cmplx causes cmplx to return a double
     complex instead of the default complex.  */

  add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
	     gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
	     x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);

  make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);

  add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
	     gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
	     z, BT_COMPLEX, dz, REQUIRED);

  add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
	     NULL, gfc_simplify_conjg, gfc_resolve_conjg, 
	     z, BT_COMPLEX, dd, REQUIRED);

  make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);

  add_sym_1 ("cos", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dcos", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
	     x, BT_REAL, dd, REQUIRED);

  add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
	     NULL, gfc_simplify_cos, gfc_resolve_cos,
	     x, BT_COMPLEX, dz, REQUIRED);

  add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
	     NULL, gfc_simplify_cos, gfc_resolve_cos, 
	     x, BT_COMPLEX, dd, REQUIRED);

  make_alias ("cdcos", GFC_STD_GNU);

  make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);

  add_sym_1 ("cosh", 1, 1, BT_REAL, dr, GFC_STD_F77,
	     gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh,
	     x, BT_REAL, dr, REQUIRED);

  add_sym_1 ("dcosh", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     NULL, gfc_simplify_cosh, gfc_resolve_cosh,
	     x, BT_REAL, dd, REQUIRED);

  make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);

  add_sym_2 ("count", 0, 1, BT_INTEGER, di, GFC_STD_F95,
	     gfc_check_count, NULL, gfc_resolve_count,
	     msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);

  make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);

  add_sym_3 ("cshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
	     gfc_check_cshift, NULL, gfc_resolve_cshift,
	     ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
	     dm, BT_INTEGER, ii, OPTIONAL);

  make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);

  add_sym_1 ("ctime", 0, 1, BT_CHARACTER, 0, GFC_STD_GNU,
              gfc_check_ctime, NULL, gfc_resolve_ctime,
	      tm, BT_INTEGER, di, REQUIRED);

  make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);

  add_sym_1 ("dble", 1, 1, BT_REAL, dd, GFC_STD_F77,
	     gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
	     a, BT_REAL, dr, REQUIRED);

  make_alias ("dfloat", GFC_STD_GNU);

  make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);

  add_sym_1 ("digits", 0, 1, BT_INTEGER, di, GFC_STD_F95,
	     gfc_check_digits, gfc_simplify_digits, NULL,
	     x, BT_UNKNOWN, dr, REQUIRED);