xref: /netbsd-src/external/gpl3/gcc.old/dist/gcc/fortran/misc.c (revision 4c3eb207d36f67d31994830c0a694161fc1ca39b)

/* Miscellaneous stuff that doesn't fit anywhere else.
   Copyright (C) 2000-2020 Free Software Foundation, Inc.
   Contributed by Andy Vaught

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 3, 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 COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
#include "spellcheck.h"
#include "tree.h"


/* Initialize a typespec to unknown.  */

void
gfc_clear_ts (gfc_typespec *ts)
{
  ts->type = BT_UNKNOWN;
  ts->u.derived = NULL;
  ts->kind = 0;
  ts->u.cl = NULL;
  ts->interface = NULL;
  /* flag that says if the type is C interoperable */
  ts->is_c_interop = 0;
  /* says what f90 type the C kind interops with */
  ts->f90_type = BT_UNKNOWN;
  /* flag that says whether it's from iso_c_binding or not */
  ts->is_iso_c = 0;
  ts->deferred = false;
}


/* Open a file for reading.  */

FILE *
gfc_open_file (const char *name)
{
  if (!*name)
    return stdin;

  return fopen (name, "r");
}


/* Return a string for each type.  */

const char *
gfc_basic_typename (bt type)
{
  const char *p;

  switch (type)
    {
    case BT_INTEGER:
      p = "INTEGER";
      break;
    case BT_REAL:
      p = "REAL";
      break;
    case BT_COMPLEX:
      p = "COMPLEX";
      break;
    case BT_LOGICAL:
      p = "LOGICAL";
      break;
    case BT_CHARACTER:
      p = "CHARACTER";
      break;
    case BT_HOLLERITH:
      p = "HOLLERITH";
      break;
    case BT_UNION:
      p = "UNION";
      break;
    case BT_DERIVED:
      p = "DERIVED";
      break;
    case BT_CLASS:
      p = "CLASS";
      break;
    case BT_PROCEDURE:
      p = "PROCEDURE";
      break;
    case BT_VOID:
      p = "VOID";
      break;
    case BT_BOZ:
      p = "BOZ";
      break;
    case BT_UNKNOWN:
      p = "UNKNOWN";
      break;
    case BT_ASSUMED:
      p = "TYPE(*)";
      break;
    default:
      gfc_internal_error ("gfc_basic_typename(): Undefined type");
    }

  return p;
}


/* Return a string describing the type and kind of a typespec.  Because
   we return alternating buffers, this subroutine can appear twice in
   the argument list of a single statement.  */

const char *
gfc_typename (gfc_typespec *ts, bool for_hash)
{
  static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
  static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
  static int flag = 0;
  char *buffer;
  gfc_typespec *ts1;
  gfc_charlen_t length = 0;

  buffer = flag ? buffer1 : buffer2;
  flag = !flag;

  switch (ts->type)
    {
    case BT_INTEGER:
      sprintf (buffer, "INTEGER(%d)", ts->kind);
      break;
    case BT_REAL:
      sprintf (buffer, "REAL(%d)", ts->kind);
      break;
    case BT_COMPLEX:
      sprintf (buffer, "COMPLEX(%d)", ts->kind);
      break;
    case BT_LOGICAL:
      sprintf (buffer, "LOGICAL(%d)", ts->kind);
      break;
    case BT_CHARACTER:
      if (for_hash)
	{
	  sprintf (buffer, "CHARACTER(%d)", ts->kind);
	  break;
	}

      if (ts->u.cl && ts->u.cl->length)
	length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
      if (ts->kind == gfc_default_character_kind)
	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
      else
	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
		 ts->kind);
      break;
    case BT_HOLLERITH:
      sprintf (buffer, "HOLLERITH");
      break;
    case BT_UNION:
      sprintf (buffer, "UNION(%s)", ts->u.derived->name);
      break;
    case BT_DERIVED:
      if (ts->u.derived == NULL)
	{
	  sprintf (buffer, "invalid type");
	  break;
	}
      sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
      break;
    case BT_CLASS:
      if (ts->u.derived == NULL)
	{
	  sprintf (buffer, "invalid class");
	  break;
	}
      ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
      if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
	sprintf (buffer, "CLASS(*)");
      else
	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
      break;
    case BT_ASSUMED:
      sprintf (buffer, "TYPE(*)");
      break;
    case BT_PROCEDURE:
      strcpy (buffer, "PROCEDURE");
      break;
    case BT_BOZ:
      strcpy (buffer, "BOZ");
      break;
    case BT_UNKNOWN:
      strcpy (buffer, "UNKNOWN");
      break;
    default:
      gfc_internal_error ("gfc_typename(): Undefined type");
    }

  return buffer;
}


const char *
gfc_typename (gfc_expr *ex)
{
  /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
     add 19 for the extra width and 1 for '\0' */
  static char buffer1[34];
  static char buffer2[34];
  static bool flag = false;
  char *buffer;
  gfc_charlen_t length;
  buffer = flag ? buffer1 : buffer2;
  flag = !flag;

  if (ex->ts.type == BT_CHARACTER)
    {
      if (ex->expr_type == EXPR_CONSTANT)
	length = ex->value.character.length;
      else if (ex->ts.deferred)
	{
	  if (ex->ts.kind == gfc_default_character_kind)
	    return "CHARACTER(:)";
	  sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
	  return buffer;
	}
      else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
	{
	  if (ex->ts.kind == gfc_default_character_kind)
	    return "CHARACTER(*)";
	  sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
	  return buffer;
	}
      else if (ex->ts.u.cl == NULL
	       || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
	{
	  if (ex->ts.kind == gfc_default_character_kind)
	    return "CHARACTER";
	  sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
	  return buffer;
	}
      else
	length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
      if (ex->ts.kind == gfc_default_character_kind)
	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
      else
	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
		 ex->ts.kind);
      return buffer;
    }
  return gfc_typename(&ex->ts);
}

/* The type of a dummy variable can also be CHARACTER(*).  */

const char *
gfc_dummy_typename (gfc_typespec *ts)
{
  static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
  static char buffer2[15];
  static bool flag = false;
  char *buffer;

  buffer = flag ? buffer1 : buffer2;
  flag = !flag;

  if (ts->type == BT_CHARACTER)
    {
      bool has_length = false;
      if (ts->u.cl)
	has_length = ts->u.cl->length != NULL;
      if (!has_length)
	{
	  if (ts->kind == gfc_default_character_kind)
	    sprintf(buffer, "CHARACTER(*)");
	  else if (ts->kind < 10)
	    sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
	  else
	    sprintf(buffer, "CHARACTER(*,?)");
	  return buffer;
	}
    }
  return gfc_typename(ts);
}


/* Given an mstring array and a code, locate the code in the table,
   returning a pointer to the string.  */

const char *
gfc_code2string (const mstring *m, int code)
{
  while (m->string != NULL)
    {
      if (m->tag == code)
	return m->string;
      m++;
    }

  gfc_internal_error ("gfc_code2string(): Bad code");
  /* Not reached */
}


/* Given an mstring array and a string, returns the value of the tag
   field.  Returns the final tag if no matches to the string are found.  */

int
gfc_string2code (const mstring *m, const char *string)
{
  for (; m->string != NULL; m++)
    if (strcmp (m->string, string) == 0)
      return m->tag;

  return m->tag;
}


/* Convert an intent code to a string.  */
/* TODO: move to gfortran.h as define.  */

const char *
gfc_intent_string (sym_intent i)
{
  return gfc_code2string (intents, i);
}


/***************** Initialization functions ****************/

/* Top level initialization.  */

void
gfc_init_1 (void)
{
  gfc_error_init_1 ();
  gfc_scanner_init_1 ();
  gfc_arith_init_1 ();
  gfc_intrinsic_init_1 ();
}


/* Per program unit initialization.  */

void
gfc_init_2 (void)
{
  gfc_symbol_init_2 ();
  gfc_module_init_2 ();
}


/******************* Destructor functions ******************/

/* Call all of the top level destructors.  */

void
gfc_done_1 (void)
{
  gfc_scanner_done_1 ();
  gfc_intrinsic_done_1 ();
  gfc_arith_done_1 ();
}


/* Per program unit destructors.  */

void
gfc_done_2 (void)
{
  gfc_symbol_done_2 ();
  gfc_module_done_2 ();
}


/* Returns the index into the table of C interoperable kinds where the
   kind with the given name (c_kind_name) was found.  */

int
get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
{
  int index = 0;

  for (index = 0; index < ISOCBINDING_LAST; index++)
    if (strcmp (kinds_table[index].name, c_kind_name) == 0)
      return index;

  return ISOCBINDING_INVALID;
}


/* For a given name TYPO, determine the best candidate from CANDIDATES
   using get_edit_distance.  Frees CANDIDATES before returning.  */

const char *
gfc_closest_fuzzy_match (const char *typo, char **candidates)
{
  /* Determine closest match.  */
  const char *best = NULL;
  char **cand = candidates;
  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
  const size_t tl = strlen (typo);

  while (cand && *cand)
    {
      edit_distance_t dist = get_edit_distance (typo, tl, *cand,
	  strlen (*cand));
      if (dist < best_distance)
	{
	   best_distance = dist;
	   best = *cand;
	}
      cand++;
    }
  /* If more than half of the letters were misspelled, the suggestion is
     likely to be meaningless.  */
  if (best)
    {
      unsigned int cutoff = MAX (tl, strlen (best)) / 2;

      if (best_distance > cutoff)
	{
	  XDELETEVEC (candidates);
	  return NULL;
	}
      XDELETEVEC (candidates);
    }
  return best;
}

/* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */

HOST_WIDE_INT
gfc_mpz_get_hwi (mpz_t op)
{
  /* Using long_long_integer_type_node as that is the integer type
     node that closest matches HOST_WIDE_INT; both are guaranteed to
     be at least 64 bits.  */
  const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
  return w.to_shwi ();
}


void
gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
{
  const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
  wi::to_mpz (w, rop, SIGNED);
}