LCOV - code coverage report
Current view: top level - gcc/fortran - misc.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 88.8 % 240 213
Test Date: 2024-07-13 14:16:58 Functions: 100.0 % 17 17
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Miscellaneous stuff that doesn't fit anywhere else.
       2                 :             :    Copyright (C) 2000-2024 Free Software Foundation, Inc.
       3                 :             :    Contributed by Andy Vaught
       4                 :             : 
       5                 :             : This file is part of GCC.
       6                 :             : 
       7                 :             : GCC is free software; you can redistribute it and/or modify it under
       8                 :             : the terms of the GNU General Public License as published by the Free
       9                 :             : Software Foundation; either version 3, or (at your option) any later
      10                 :             : version.
      11                 :             : 
      12                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :             : for more details.
      16                 :             : 
      17                 :             : You should have received a copy of the GNU General Public License
      18                 :             : along with GCC; see the file COPYING3.  If not see
      19                 :             : <http://www.gnu.org/licenses/>.  */
      20                 :             : 
      21                 :             : #include "config.h"
      22                 :             : #include "system.h"
      23                 :             : #include "coretypes.h"
      24                 :             : #include "gfortran.h"
      25                 :             : #include "spellcheck.h"
      26                 :             : #include "tree.h"
      27                 :             : 
      28                 :             : 
      29                 :             : /* Initialize a typespec to unknown.  */
      30                 :             : 
      31                 :             : void
      32                 :   132241029 : gfc_clear_ts (gfc_typespec *ts)
      33                 :             : {
      34                 :   132241029 :   ts->type = BT_UNKNOWN;
      35                 :   132241029 :   ts->u.derived = NULL;
      36                 :   132241029 :   ts->kind = 0;
      37                 :   132241029 :   ts->u.cl = NULL;
      38                 :   132241029 :   ts->interface = NULL;
      39                 :             :   /* flag that says if the type is C interoperable */
      40                 :   132241029 :   ts->is_c_interop = 0;
      41                 :             :   /* says what f90 type the C kind interops with */
      42                 :   132241029 :   ts->f90_type = BT_UNKNOWN;
      43                 :             :   /* flag that says whether it's from iso_c_binding or not */
      44                 :   132241029 :   ts->is_iso_c = 0;
      45                 :   132241029 :   ts->deferred = false;
      46                 :   132241029 : }
      47                 :             : 
      48                 :             : 
      49                 :             : /* Open a file for reading.  */
      50                 :             : 
      51                 :             : FILE *
      52                 :       60316 : gfc_open_file (const char *name)
      53                 :             : {
      54                 :       60316 :   if (!*name)
      55                 :           0 :     return stdin;
      56                 :             : 
      57                 :       60316 :   return fopen (name, "r");
      58                 :             : }
      59                 :             : 
      60                 :             : 
      61                 :             : /* Return a string for each type.  */
      62                 :             : 
      63                 :             : const char *
      64                 :       15911 : gfc_basic_typename (bt type)
      65                 :             : {
      66                 :       15911 :   const char *p;
      67                 :             : 
      68                 :       15911 :   switch (type)
      69                 :             :     {
      70                 :             :     case BT_INTEGER:
      71                 :             :       p = "INTEGER";
      72                 :             :       break;
      73                 :        5469 :     case BT_REAL:
      74                 :        5469 :       p = "REAL";
      75                 :        5469 :       break;
      76                 :         502 :     case BT_COMPLEX:
      77                 :         502 :       p = "COMPLEX";
      78                 :         502 :       break;
      79                 :          98 :     case BT_LOGICAL:
      80                 :          98 :       p = "LOGICAL";
      81                 :          98 :       break;
      82                 :        5111 :     case BT_CHARACTER:
      83                 :        5111 :       p = "CHARACTER";
      84                 :        5111 :       break;
      85                 :          19 :     case BT_HOLLERITH:
      86                 :          19 :       p = "HOLLERITH";
      87                 :          19 :       break;
      88                 :           0 :     case BT_UNION:
      89                 :           0 :       p = "UNION";
      90                 :           0 :       break;
      91                 :         117 :     case BT_DERIVED:
      92                 :         117 :       p = "DERIVED";
      93                 :         117 :       break;
      94                 :          38 :     case BT_CLASS:
      95                 :          38 :       p = "CLASS";
      96                 :          38 :       break;
      97                 :          16 :     case BT_PROCEDURE:
      98                 :          16 :       p = "PROCEDURE";
      99                 :          16 :       break;
     100                 :           6 :     case BT_VOID:
     101                 :           6 :       p = "VOID";
     102                 :           6 :       break;
     103                 :           0 :     case BT_BOZ:
     104                 :           0 :       p = "BOZ";
     105                 :           0 :       break;
     106                 :         235 :     case BT_UNKNOWN:
     107                 :         235 :       p = "UNKNOWN";
     108                 :         235 :       break;
     109                 :           0 :     case BT_ASSUMED:
     110                 :           0 :       p = "TYPE(*)";
     111                 :           0 :       break;
     112                 :           0 :     default:
     113                 :           0 :       gfc_internal_error ("gfc_basic_typename(): Undefined type");
     114                 :             :     }
     115                 :             : 
     116                 :       15911 :   return p;
     117                 :             : }
     118                 :             : 
     119                 :             : 
     120                 :             : /* Return a string describing the type and kind of a typespec.  Because
     121                 :             :    we return alternating buffers, this subroutine can appear twice in
     122                 :             :    the argument list of a single statement.  */
     123                 :             : 
     124                 :             : const char *
     125                 :       24140 : gfc_typename (gfc_typespec *ts, bool for_hash)
     126                 :             : {
     127                 :             :   /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0',
     128                 :             :      or "CLASS()" + '\0'.  */
     129                 :       24140 :   static char buffer1[GFC_MAX_SYMBOL_LEN + 8];
     130                 :       24140 :   static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
     131                 :       24140 :   static int flag = 0;
     132                 :       24140 :   char *buffer;
     133                 :       24140 :   gfc_charlen_t length = 0;
     134                 :             : 
     135                 :       24140 :   buffer = flag ? buffer1 : buffer2;
     136                 :       24140 :   flag = !flag;
     137                 :             : 
     138                 :       24140 :   switch (ts->type)
     139                 :             :     {
     140                 :       10075 :     case BT_INTEGER:
     141                 :       10075 :       if (ts->f90_type == BT_VOID
     142                 :           1 :           && ts->u.derived
     143                 :           1 :           && ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
     144                 :           1 :         sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
     145                 :             :       else
     146                 :       10074 :         sprintf (buffer, "INTEGER(%d)", ts->kind);
     147                 :             :       break;
     148                 :        6729 :     case BT_REAL:
     149                 :        6729 :       sprintf (buffer, "REAL(%d)", ts->kind);
     150                 :        6729 :       break;
     151                 :        2114 :     case BT_COMPLEX:
     152                 :        2114 :       sprintf (buffer, "COMPLEX(%d)", ts->kind);
     153                 :        2114 :       break;
     154                 :         708 :     case BT_LOGICAL:
     155                 :         708 :       sprintf (buffer, "LOGICAL(%d)", ts->kind);
     156                 :         708 :       break;
     157                 :         300 :     case BT_CHARACTER:
     158                 :         300 :       if (for_hash)
     159                 :             :         {
     160                 :         232 :           sprintf (buffer, "CHARACTER(%d)", ts->kind);
     161                 :         232 :           break;
     162                 :             :         }
     163                 :             : 
     164                 :          68 :       if (ts->u.cl && ts->u.cl->length)
     165                 :          67 :         length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
     166                 :          68 :       if (ts->kind == gfc_default_character_kind)
     167                 :          68 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
     168                 :             :       else
     169                 :           0 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
     170                 :             :                  ts->kind);
     171                 :             :       break;
     172                 :        1375 :     case BT_HOLLERITH:
     173                 :        1375 :       sprintf (buffer, "HOLLERITH");
     174                 :        1375 :       break;
     175                 :           0 :     case BT_UNION:
     176                 :           0 :       sprintf (buffer, "UNION(%s)", ts->u.derived->name);
     177                 :           0 :       break;
     178                 :        2206 :     case BT_DERIVED:
     179                 :        2206 :       if (ts->u.derived == NULL)
     180                 :             :         {
     181                 :           1 :           sprintf (buffer, "invalid type");
     182                 :           1 :           break;
     183                 :             :         }
     184                 :        2205 :       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
     185                 :        2205 :       break;
     186                 :         326 :     case BT_CLASS:
     187                 :         326 :       if (!ts->u.derived || !ts->u.derived->components
     188                 :         324 :           || !ts->u.derived->components->ts.u.derived)
     189                 :             :         {
     190                 :           3 :           sprintf (buffer, "invalid class");
     191                 :           3 :           break;
     192                 :             :         }
     193                 :         323 :       if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
     194                 :           2 :         sprintf (buffer, "CLASS(*)");
     195                 :             :       else
     196                 :         321 :         sprintf (buffer, "CLASS(%s)",
     197                 :             :                  ts->u.derived->components->ts.u.derived->name);
     198                 :             :       break;
     199                 :           6 :     case BT_ASSUMED:
     200                 :           6 :       sprintf (buffer, "TYPE(*)");
     201                 :           6 :       break;
     202                 :          10 :     case BT_PROCEDURE:
     203                 :          10 :       strcpy (buffer, "PROCEDURE");
     204                 :          10 :       break;
     205                 :           2 :     case BT_BOZ:
     206                 :           2 :       strcpy (buffer, "BOZ");
     207                 :           2 :       break;
     208                 :         289 :     case BT_UNKNOWN:
     209                 :         289 :       strcpy (buffer, "UNKNOWN");
     210                 :         289 :       break;
     211                 :           0 :     default:
     212                 :           0 :       gfc_internal_error ("gfc_typename(): Undefined type");
     213                 :             :     }
     214                 :             : 
     215                 :       24140 :   return buffer;
     216                 :             : }
     217                 :             : 
     218                 :             : 
     219                 :             : const char *
     220                 :        4235 : gfc_typename (gfc_expr *ex)
     221                 :             : {
     222                 :             :   /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
     223                 :             :      add 19 for the extra width and 1 for '\0' */
     224                 :        4235 :   static char buffer1[34];
     225                 :        4235 :   static char buffer2[34];
     226                 :        4235 :   static bool flag = false;
     227                 :        4235 :   char *buffer;
     228                 :        4235 :   gfc_charlen_t length;
     229                 :        4235 :   buffer = flag ? buffer1 : buffer2;
     230                 :        4235 :   flag = !flag;
     231                 :             : 
     232                 :        4235 :   if (ex->ts.type == BT_CHARACTER)
     233                 :             :     {
     234                 :        1037 :       if (ex->expr_type == EXPR_CONSTANT)
     235                 :         932 :         length = ex->value.character.length;
     236                 :         105 :       else if (ex->ts.deferred)
     237                 :             :         {
     238                 :           2 :           if (ex->ts.kind == gfc_default_character_kind)
     239                 :             :             return "CHARACTER(:)";
     240                 :           0 :           sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
     241                 :           0 :           return buffer;
     242                 :             :         }
     243                 :         103 :       else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
     244                 :             :         {
     245                 :           7 :           if (ex->ts.kind == gfc_default_character_kind)
     246                 :             :             return "CHARACTER(*)";
     247                 :           0 :           sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
     248                 :           0 :           return buffer;
     249                 :             :         }
     250                 :          96 :       else if (ex->ts.u.cl == NULL
     251                 :          96 :                || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
     252                 :             :         {
     253                 :           3 :           if (ex->ts.kind == gfc_default_character_kind)
     254                 :             :             return "CHARACTER";
     255                 :           0 :           sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
     256                 :           0 :           return buffer;
     257                 :             :         }
     258                 :             :       else
     259                 :          93 :         length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
     260                 :        1025 :       if (ex->ts.kind == gfc_default_character_kind)
     261                 :         944 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
     262                 :             :       else
     263                 :          81 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
     264                 :             :                  ex->ts.kind);
     265                 :        1025 :       return buffer;
     266                 :             :     }
     267                 :        3198 :   return gfc_typename(&ex->ts);
     268                 :             : }
     269                 :             : 
     270                 :             : /* The type of a dummy variable can also be CHARACTER(*).  */
     271                 :             : 
     272                 :             : const char *
     273                 :        1633 : gfc_dummy_typename (gfc_typespec *ts)
     274                 :             : {
     275                 :        1633 :   static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
     276                 :        1633 :   static char buffer2[15];
     277                 :        1633 :   static bool flag = false;
     278                 :        1633 :   char *buffer;
     279                 :             : 
     280                 :        1633 :   buffer = flag ? buffer1 : buffer2;
     281                 :        1633 :   flag = !flag;
     282                 :             : 
     283                 :        1633 :   if (ts->type == BT_CHARACTER)
     284                 :             :     {
     285                 :         176 :       bool has_length = false;
     286                 :         176 :       if (ts->u.cl)
     287                 :          55 :         has_length = ts->u.cl->length != NULL;
     288                 :          55 :       if (!has_length)
     289                 :             :         {
     290                 :         136 :           if (ts->kind == gfc_default_character_kind)
     291                 :         133 :             sprintf(buffer, "CHARACTER(*)");
     292                 :           3 :           else if (ts->kind >= 0 && ts->kind < 10)
     293                 :           3 :             sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
     294                 :             :           else
     295                 :           0 :             sprintf(buffer, "CHARACTER(*,?)");
     296                 :         136 :           return buffer;
     297                 :             :         }
     298                 :             :     }
     299                 :        1497 :   return gfc_typename(ts);
     300                 :             : }
     301                 :             : 
     302                 :             : 
     303                 :             : /* Given an mstring array and a code, locate the code in the table,
     304                 :             :    returning a pointer to the string.  */
     305                 :             : 
     306                 :             : const char *
     307                 :     9683864 : gfc_code2string (const mstring *m, int code)
     308                 :             : {
     309                 :    61172678 :   while (m->string != NULL)
     310                 :             :     {
     311                 :    61172678 :       if (m->tag == code)
     312                 :     9683864 :         return m->string;
     313                 :    51488814 :       m++;
     314                 :             :     }
     315                 :             : 
     316                 :           0 :   gfc_internal_error ("gfc_code2string(): Bad code");
     317                 :             :   /* Not reached */
     318                 :             : }
     319                 :             : 
     320                 :             : 
     321                 :             : /* Given an mstring array and a string, returns the value of the tag
     322                 :             :    field.  Returns the final tag if no matches to the string are found.  */
     323                 :             : 
     324                 :             : int
     325                 :     9137786 : gfc_string2code (const mstring *m, const char *string)
     326                 :             : {
     327                 :    58428742 :   for (; m->string != NULL; m++)
     328                 :    58428742 :     if (strcmp (m->string, string) == 0)
     329                 :     9137786 :       return m->tag;
     330                 :             : 
     331                 :           0 :   return m->tag;
     332                 :             : }
     333                 :             : 
     334                 :             : 
     335                 :             : /* Convert an intent code to a string.  */
     336                 :             : /* TODO: move to gfortran.h as define.  */
     337                 :             : 
     338                 :             : const char *
     339                 :          19 : gfc_intent_string (sym_intent i)
     340                 :             : {
     341                 :          19 :   return gfc_code2string (intents, i);
     342                 :             : }
     343                 :             : 
     344                 :             : 
     345                 :             : /***************** Initialization functions ****************/
     346                 :             : 
     347                 :             : /* Top level initialization.  */
     348                 :             : 
     349                 :             : void
     350                 :       29874 : gfc_init_1 (void)
     351                 :             : {
     352                 :       29874 :   gfc_error_init_1 ();
     353                 :       29874 :   gfc_scanner_init_1 ();
     354                 :       29874 :   gfc_arith_init_1 ();
     355                 :       29874 :   gfc_intrinsic_init_1 ();
     356                 :       29874 : }
     357                 :             : 
     358                 :             : 
     359                 :             : /* Per program unit initialization.  */
     360                 :             : 
     361                 :             : void
     362                 :       76370 : gfc_init_2 (void)
     363                 :             : {
     364                 :       76370 :   gfc_symbol_init_2 ();
     365                 :       76370 :   gfc_module_init_2 ();
     366                 :       76370 : }
     367                 :             : 
     368                 :             : 
     369                 :             : /******************* Destructor functions ******************/
     370                 :             : 
     371                 :             : /* Call all of the top level destructors.  */
     372                 :             : 
     373                 :             : void
     374                 :       29857 : gfc_done_1 (void)
     375                 :             : {
     376                 :       29857 :   gfc_scanner_done_1 ();
     377                 :       29857 :   gfc_intrinsic_done_1 ();
     378                 :       29857 :   gfc_arith_done_1 ();
     379                 :       29857 : }
     380                 :             : 
     381                 :             : 
     382                 :             : /* Per program unit destructors.  */
     383                 :             : 
     384                 :             : void
     385                 :       76671 : gfc_done_2 (void)
     386                 :             : {
     387                 :       76671 :   gfc_symbol_done_2 ();
     388                 :       76671 :   gfc_module_done_2 ();
     389                 :       76671 : }
     390                 :             : 
     391                 :             : 
     392                 :             : /* Returns the index into the table of C interoperable kinds where the
     393                 :             :    kind with the given name (c_kind_name) was found.  */
     394                 :             : 
     395                 :             : int
     396                 :        7612 : get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
     397                 :             : {
     398                 :        7612 :   int index = 0;
     399                 :             : 
     400                 :      327316 :   for (index = 0; index < ISOCBINDING_LAST; index++)
     401                 :      327316 :     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
     402                 :        7612 :       return index;
     403                 :             : 
     404                 :             :   return ISOCBINDING_INVALID;
     405                 :             : }
     406                 :             : 
     407                 :             : 
     408                 :             : /* For a given name TYPO, determine the best candidate from CANDIDATES
     409                 :             :    using get_edit_distance.  Frees CANDIDATES before returning.  */
     410                 :             : 
     411                 :             : const char *
     412                 :         258 : gfc_closest_fuzzy_match (const char *typo, char **candidates)
     413                 :             : {
     414                 :             :   /* Determine closest match.  */
     415                 :         258 :   const char *best = NULL;
     416                 :         258 :   char **cand = candidates;
     417                 :         258 :   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
     418                 :         258 :   const size_t tl = strlen (typo);
     419                 :             : 
     420                 :         835 :   while (cand && *cand)
     421                 :             :     {
     422                 :        1154 :       edit_distance_t dist = get_edit_distance (typo, tl, *cand,
     423                 :         577 :           strlen (*cand));
     424                 :         577 :       if (dist < best_distance)
     425                 :             :         {
     426                 :         193 :            best_distance = dist;
     427                 :         193 :            best = *cand;
     428                 :             :         }
     429                 :         577 :       cand++;
     430                 :             :     }
     431                 :             :   /* If more than half of the letters were misspelled, the suggestion is
     432                 :             :      likely to be meaningless.  */
     433                 :         258 :   if (best)
     434                 :             :     {
     435                 :         121 :       unsigned int cutoff = MAX (tl, strlen (best));
     436                 :             : 
     437                 :         121 :       if (best_distance > cutoff)
     438                 :             :         {
     439                 :          77 :           XDELETEVEC (candidates);
     440                 :          77 :           return NULL;
     441                 :             :         }
     442                 :          44 :       XDELETEVEC (candidates);
     443                 :             :     }
     444                 :             :   return best;
     445                 :             : }
     446                 :             : 
     447                 :             : /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
     448                 :             : 
     449                 :             : HOST_WIDE_INT
     450                 :       11586 : gfc_mpz_get_hwi (mpz_t op)
     451                 :             : {
     452                 :             :   /* Using long_long_integer_type_node as that is the integer type
     453                 :             :      node that closest matches HOST_WIDE_INT; both are guaranteed to
     454                 :             :      be at least 64 bits.  */
     455                 :       11586 :   const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
     456                 :       11586 :   return w.to_shwi ();
     457                 :       11586 : }
     458                 :             : 
     459                 :             : 
     460                 :             : void
     461                 :        1659 : gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
     462                 :             : {
     463                 :        1659 :   const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
     464                 :        1659 :   wi::to_mpz (w, rop, SIGNED);
     465                 :        1659 : }
        

Generated by: LCOV version 2.1-beta

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.