LCOV - code coverage report
Current view: top level - gcc/fortran - misc.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 199 221 90.0 %
Date: 2020-03-28 11:57:23 Functions: 17 17 100.0 %
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-2020 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                 :  123790000 : gfc_clear_ts (gfc_typespec *ts)
      33                 :            : {
      34                 :  123790000 :   ts->type = BT_UNKNOWN;
      35                 :  123790000 :   ts->u.derived = NULL;
      36                 :  123790000 :   ts->kind = 0;
      37                 :  123790000 :   ts->u.cl = NULL;
      38                 :  123790000 :   ts->interface = NULL;
      39                 :            :   /* flag that says if the type is C interoperable */
      40                 :  123790000 :   ts->is_c_interop = 0;
      41                 :            :   /* says what f90 type the C kind interops with */
      42                 :  123790000 :   ts->f90_type = BT_UNKNOWN;
      43                 :            :   /* flag that says whether it's from iso_c_binding or not */
      44                 :  123790000 :   ts->is_iso_c = 0;
      45                 :  123790000 :   ts->deferred = false;
      46                 :  123790000 : }
      47                 :            : 
      48                 :            : 
      49                 :            : /* Open a file for reading.  */
      50                 :            : 
      51                 :            : FILE *
      52                 :      50922 : gfc_open_file (const char *name)
      53                 :            : {
      54                 :      50922 :   if (!*name)
      55                 :          0 :     return stdin;
      56                 :            : 
      57                 :      50922 :   return fopen (name, "r");
      58                 :            : }
      59                 :            : 
      60                 :            : 
      61                 :            : /* Return a string for each type.  */
      62                 :            : 
      63                 :            : const char *
      64                 :       7758 : gfc_basic_typename (bt type)
      65                 :            : {
      66                 :       7758 :   const char *p;
      67                 :            : 
      68                 :       7758 :   switch (type)
      69                 :            :     {
      70                 :            :     case BT_INTEGER:
      71                 :            :       p = "INTEGER";
      72                 :            :       break;
      73                 :       4021 :     case BT_REAL:
      74                 :       4021 :       p = "REAL";
      75                 :       4021 :       break;
      76                 :        213 :     case BT_COMPLEX:
      77                 :        213 :       p = "COMPLEX";
      78                 :        213 :       break;
      79                 :         62 :     case BT_LOGICAL:
      80                 :         62 :       p = "LOGICAL";
      81                 :         62 :       break;
      82                 :       1378 :     case BT_CHARACTER:
      83                 :       1378 :       p = "CHARACTER";
      84                 :       1378 :       break;
      85                 :         13 :     case BT_HOLLERITH:
      86                 :         13 :       p = "HOLLERITH";
      87                 :         13 :       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                 :          3 :     case BT_PROCEDURE:
      98                 :          3 :       p = "PROCEDURE";
      99                 :          3 :       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                 :        209 :     case BT_UNKNOWN:
     107                 :        209 :       p = "UNKNOWN";
     108                 :        209 :       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                 :       7758 :   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                 :      20993 : gfc_typename (gfc_typespec *ts)
     126                 :            : {
     127                 :      20993 :   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
     128                 :      20993 :   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
     129                 :      20993 :   static int flag = 0;
     130                 :      20993 :   char *buffer;
     131                 :      20993 :   gfc_typespec *ts1;
     132                 :      20993 :   gfc_charlen_t length = 0;
     133                 :            : 
     134                 :      20993 :   buffer = flag ? buffer1 : buffer2;
     135                 :      20993 :   flag = !flag;
     136                 :            : 
     137                 :      20993 :   switch (ts->type)
     138                 :            :     {
     139                 :       8272 :     case BT_INTEGER:
     140                 :       8272 :       sprintf (buffer, "INTEGER(%d)", ts->kind);
     141                 :       8272 :       break;
     142                 :       5719 :     case BT_REAL:
     143                 :       5719 :       sprintf (buffer, "REAL(%d)", ts->kind);
     144                 :       5719 :       break;
     145                 :       2034 :     case BT_COMPLEX:
     146                 :       2034 :       sprintf (buffer, "COMPLEX(%d)", ts->kind);
     147                 :       2034 :       break;
     148                 :       1238 :     case BT_LOGICAL:
     149                 :       1238 :       sprintf (buffer, "LOGICAL(%d)", ts->kind);
     150                 :       1238 :       break;
     151                 :        186 :     case BT_CHARACTER:
     152                 :        186 :       if (ts->u.cl && ts->u.cl->length)
     153                 :         96 :         length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
     154                 :        186 :       if (ts->kind == gfc_default_character_kind)
     155                 :        173 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
     156                 :            :       else
     157                 :         13 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
     158                 :            :                  ts->kind);
     159                 :            :       break;
     160                 :       1375 :     case BT_HOLLERITH:
     161                 :       1375 :       sprintf (buffer, "HOLLERITH");
     162                 :       1375 :       break;
     163                 :          0 :     case BT_UNION:
     164                 :          0 :       sprintf (buffer, "UNION(%s)", ts->u.derived->name);
     165                 :          0 :       break;
     166                 :       1773 :     case BT_DERIVED:
     167                 :       1773 :       if (ts->u.derived == NULL)
     168                 :            :         {
     169                 :          1 :           sprintf (buffer, "invalid type");
     170                 :          1 :           break;
     171                 :            :         }
     172                 :       1772 :       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
     173                 :       1772 :       break;
     174                 :        250 :     case BT_CLASS:
     175                 :        250 :       if (ts->u.derived == NULL)
     176                 :            :         {
     177                 :          0 :           sprintf (buffer, "invalid class");
     178                 :          0 :           break;
     179                 :            :         }
     180                 :        250 :       ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
     181                 :        249 :       if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
     182                 :          1 :         sprintf (buffer, "CLASS(*)");
     183                 :            :       else
     184                 :        249 :         sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
     185                 :            :       break;
     186                 :          4 :     case BT_ASSUMED:
     187                 :          4 :       sprintf (buffer, "TYPE(*)");
     188                 :          4 :       break;
     189                 :          1 :     case BT_PROCEDURE:
     190                 :          1 :       strcpy (buffer, "PROCEDURE");
     191                 :          1 :       break;
     192                 :          1 :     case BT_BOZ:
     193                 :          1 :       strcpy (buffer, "BOZ");
     194                 :          1 :       break;
     195                 :        140 :     case BT_UNKNOWN:
     196                 :        140 :       strcpy (buffer, "UNKNOWN");
     197                 :        140 :       break;
     198                 :          0 :     default:
     199                 :          0 :       gfc_internal_error ("gfc_typename(): Undefined type");
     200                 :            :     }
     201                 :            : 
     202                 :      20993 :   return buffer;
     203                 :            : }
     204                 :            : 
     205                 :            : 
     206                 :            : const char *
     207                 :       3600 : gfc_typename (gfc_expr *ex)
     208                 :            : {
     209                 :            :   /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
     210                 :            :      add 19 for the extra width and 1 for '\0' */
     211                 :       3600 :   static char buffer1[34];
     212                 :       3600 :   static char buffer2[34];
     213                 :       3600 :   static bool flag = false;
     214                 :       3600 :   char *buffer;
     215                 :       3600 :   gfc_charlen_t length;
     216                 :       3600 :   buffer = flag ? buffer1 : buffer2;
     217                 :       3600 :   flag = !flag;
     218                 :            : 
     219                 :       3600 :   if (ex->ts.type == BT_CHARACTER)
     220                 :            :     {
     221                 :        997 :       if (ex->ts.u.cl && ex->ts.u.cl->length)
     222                 :         91 :         length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
     223                 :            :       else
     224                 :        906 :         length = ex->value.character.length;
     225                 :        997 :       if (ex->ts.kind == gfc_default_character_kind)
     226                 :        917 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
     227                 :            :       else
     228                 :         80 :         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
     229                 :            :                  ex->ts.kind);
     230                 :        997 :       return buffer;
     231                 :            :     }
     232                 :       2603 :   return gfc_typename(&ex->ts);
     233                 :            : }
     234                 :            : 
     235                 :            : /* The type of a dummy variable can also be CHARACTER(*).  */
     236                 :            : 
     237                 :            : const char *
     238                 :       1611 : gfc_dummy_typename (gfc_typespec *ts)
     239                 :            : {
     240                 :       1611 :   static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
     241                 :       1611 :   static char buffer2[15];
     242                 :       1611 :   static bool flag = false;
     243                 :       1611 :   char *buffer;
     244                 :            : 
     245                 :       1611 :   buffer = flag ? buffer1 : buffer2;
     246                 :       1611 :   flag = !flag;
     247                 :            : 
     248                 :       1611 :   if (ts->type == BT_CHARACTER)
     249                 :            :     {
     250                 :        176 :       bool has_length = false;
     251                 :        176 :       if (ts->u.cl)
     252                 :         55 :         has_length = ts->u.cl->length != NULL;
     253                 :         55 :       if (!has_length)
     254                 :            :         {
     255                 :        136 :           if (ts->kind == gfc_default_character_kind)
     256                 :        133 :             sprintf(buffer, "CHARACTER(*)");
     257                 :          3 :           else if (ts->kind < 10)
     258                 :          3 :             sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
     259                 :            :           else
     260                 :          0 :             sprintf(buffer, "CHARACTER(*,?)");
     261                 :        136 :           return buffer;
     262                 :            :         }
     263                 :            :     }
     264                 :       1475 :   return gfc_typename(ts);
     265                 :            : }
     266                 :            : 
     267                 :            : 
     268                 :            : /* Given an mstring array and a code, locate the code in the table,
     269                 :            :    returning a pointer to the string.  */
     270                 :            : 
     271                 :            : const char *
     272                 :    7077700 : gfc_code2string (const mstring *m, int code)
     273                 :            : {
     274                 :   45095500 :   while (m->string != NULL)
     275                 :            :     {
     276                 :   45095500 :       if (m->tag == code)
     277                 :    7077700 :         return m->string;
     278                 :   38017800 :       m++;
     279                 :            :     }
     280                 :            : 
     281                 :          0 :   gfc_internal_error ("gfc_code2string(): Bad code");
     282                 :            :   /* Not reached */
     283                 :            : }
     284                 :            : 
     285                 :            : 
     286                 :            : /* Given an mstring array and a string, returns the value of the tag
     287                 :            :    field.  Returns the final tag if no matches to the string are found.  */
     288                 :            : 
     289                 :            : int
     290                 :    4055560 : gfc_string2code (const mstring *m, const char *string)
     291                 :            : {
     292                 :   25947500 :   for (; m->string != NULL; m++)
     293                 :   25947500 :     if (strcmp (m->string, string) == 0)
     294                 :    4055560 :       return m->tag;
     295                 :            : 
     296                 :          0 :   return m->tag;
     297                 :            : }
     298                 :            : 
     299                 :            : 
     300                 :            : /* Convert an intent code to a string.  */
     301                 :            : /* TODO: move to gfortran.h as define.  */
     302                 :            : 
     303                 :            : const char *
     304                 :         19 : gfc_intent_string (sym_intent i)
     305                 :            : {
     306                 :         19 :   return gfc_code2string (intents, i);
     307                 :            : }
     308                 :            : 
     309                 :            : 
     310                 :            : /***************** Initialization functions ****************/
     311                 :            : 
     312                 :            : /* Top level initialization.  */
     313                 :            : 
     314                 :            : void
     315                 :      25191 : gfc_init_1 (void)
     316                 :            : {
     317                 :      25191 :   gfc_error_init_1 ();
     318                 :      25191 :   gfc_scanner_init_1 ();
     319                 :      25191 :   gfc_arith_init_1 ();
     320                 :      25191 :   gfc_intrinsic_init_1 ();
     321                 :      25191 : }
     322                 :            : 
     323                 :            : 
     324                 :            : /* Per program unit initialization.  */
     325                 :            : 
     326                 :            : void
     327                 :      64216 : gfc_init_2 (void)
     328                 :            : {
     329                 :      64216 :   gfc_symbol_init_2 ();
     330                 :      64216 :   gfc_module_init_2 ();
     331                 :      64216 : }
     332                 :            : 
     333                 :            : 
     334                 :            : /******************* Destructor functions ******************/
     335                 :            : 
     336                 :            : /* Call all of the top level destructors.  */
     337                 :            : 
     338                 :            : void
     339                 :      25179 : gfc_done_1 (void)
     340                 :            : {
     341                 :      25179 :   gfc_scanner_done_1 ();
     342                 :      25179 :   gfc_intrinsic_done_1 ();
     343                 :      25179 :   gfc_arith_done_1 ();
     344                 :      25179 : }
     345                 :            : 
     346                 :            : 
     347                 :            : /* Per program unit destructors.  */
     348                 :            : 
     349                 :            : void
     350                 :      64331 : gfc_done_2 (void)
     351                 :            : {
     352                 :      64331 :   gfc_symbol_done_2 ();
     353                 :      64331 :   gfc_module_done_2 ();
     354                 :      64331 : }
     355                 :            : 
     356                 :            : 
     357                 :            : /* Returns the index into the table of C interoperable kinds where the
     358                 :            :    kind with the given name (c_kind_name) was found.  */
     359                 :            : 
     360                 :            : int
     361                 :       2385 : get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
     362                 :            : {
     363                 :       2385 :   int index = 0;
     364                 :            : 
     365                 :     102555 :   for (index = 0; index < ISOCBINDING_LAST; index++)
     366                 :     102555 :     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
     367                 :       2385 :       return index;
     368                 :            : 
     369                 :            :   return ISOCBINDING_INVALID;
     370                 :            : }
     371                 :            : 
     372                 :            : 
     373                 :            : /* For a given name TYPO, determine the best candidate from CANDIDATES
     374                 :            :    using get_edit_distance.  Frees CANDIDATES before returning.  */
     375                 :            : 
     376                 :            : const char *
     377                 :        209 : gfc_closest_fuzzy_match (const char *typo, char **candidates)
     378                 :            : {
     379                 :            :   /* Determine closest match.  */
     380                 :        209 :   const char *best = NULL;
     381                 :        209 :   char **cand = candidates;
     382                 :        209 :   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
     383                 :        209 :   const size_t tl = strlen (typo);
     384                 :            : 
     385                 :        587 :   while (cand && *cand)
     386                 :            :     {
     387                 :        756 :       edit_distance_t dist = get_edit_distance (typo, tl, *cand,
     388                 :        378 :           strlen (*cand));
     389                 :        378 :       if (dist < best_distance)
     390                 :            :         {
     391                 :        155 :            best_distance = dist;
     392                 :        155 :            best = *cand;
     393                 :            :         }
     394                 :        378 :       cand++;
     395                 :            :     }
     396                 :            :   /* If more than half of the letters were misspelled, the suggestion is
     397                 :            :      likely to be meaningless.  */
     398                 :        209 :   if (best)
     399                 :            :     {
     400                 :        105 :       unsigned int cutoff = MAX (tl, strlen (best)) / 2;
     401                 :            : 
     402                 :        105 :       if (best_distance > cutoff)
     403                 :            :         {
     404                 :         70 :           XDELETEVEC (candidates);
     405                 :         70 :           return NULL;
     406                 :            :         }
     407                 :         35 :       XDELETEVEC (candidates);
     408                 :            :     }
     409                 :            :   return best;
     410                 :            : }
     411                 :            : 
     412                 :            : /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
     413                 :            : 
     414                 :            : HOST_WIDE_INT
     415                 :       8139 : gfc_mpz_get_hwi (mpz_t op)
     416                 :            : {
     417                 :            :   /* Using long_long_integer_type_node as that is the integer type
     418                 :            :      node that closest matches HOST_WIDE_INT; both are guaranteed to
     419                 :            :      be at least 64 bits.  */
     420                 :       8139 :   const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
     421                 :       8139 :   return w.to_shwi ();
     422                 :            : }
     423                 :            : 
     424                 :            : 
     425                 :            : void
     426                 :       1103 : gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
     427                 :            : {
     428                 :       1103 :   const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
     429                 :       1103 :   wi::to_mpz (w, rop, SIGNED);
     430                 :       1103 : }

Generated by: LCOV version 1.0

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 --enable-host-shared. GCC test suite is run with the built compiler.