aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/misc.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/misc.c')
-rw-r--r--gcc/fortran/misc.c460
1 files changed, 0 insertions, 460 deletions
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
deleted file mode 100644
index af36347..0000000
--- a/gcc/fortran/misc.c
+++ /dev/null
@@ -1,460 +0,0 @@
-/* Miscellaneous stuff that doesn't fit anywhere else.
- Copyright (C) 2000-2022 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)
-{
- /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0',
- or "CLASS()" + '\0'. */
- static char buffer1[GFC_MAX_SYMBOL_LEN + 8];
- static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
- static int flag = 0;
- char *buffer;
- 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 || !ts->u.derived->components
- || !ts->u.derived->components->ts.u.derived)
- {
- sprintf (buffer, "invalid class");
- break;
- }
- if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
- sprintf (buffer, "CLASS(*)");
- else
- sprintf (buffer, "CLASS(%s)",
- ts->u.derived->components->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 >= 0 && 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));
-
- 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);
-}
generated by cgit v1.1 at 2025-05-23 16:28:57 +0000