LCOV - code coverage report
Current view: top level - gcc/fortran - primary.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 94.2 % 2128 2004
Test Date: 2024-05-25 14:05:00 Functions: 100.0 % 44 44
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Primary expression subroutines
       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 "options.h"
      25                 :             : #include "gfortran.h"
      26                 :             : #include "arith.h"
      27                 :             : #include "match.h"
      28                 :             : #include "parse.h"
      29                 :             : #include "constructor.h"
      30                 :             : 
      31                 :             : int matching_actual_arglist = 0;
      32                 :             : 
      33                 :             : /* Matches a kind-parameter expression, which is either a named
      34                 :             :    symbolic constant or a nonnegative integer constant.  If
      35                 :             :    successful, sets the kind value to the correct integer.
      36                 :             :    The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
      37                 :             :    symbol like e.g. 'c_int'.  */
      38                 :             : 
      39                 :             : static match
      40                 :      375404 : match_kind_param (int *kind, int *is_iso_c)
      41                 :             : {
      42                 :      375404 :   char name[GFC_MAX_SYMBOL_LEN + 1];
      43                 :      375404 :   gfc_symbol *sym;
      44                 :      375404 :   match m;
      45                 :             : 
      46                 :      375404 :   *is_iso_c = 0;
      47                 :             : 
      48                 :      375404 :   m = gfc_match_small_literal_int (kind, NULL, false);
      49                 :      375404 :   if (m != MATCH_NO)
      50                 :             :     return m;
      51                 :             : 
      52                 :       92452 :   m = gfc_match_name (name, false);
      53                 :       92452 :   if (m != MATCH_YES)
      54                 :             :     return m;
      55                 :             : 
      56                 :       90720 :   if (gfc_find_symbol (name, NULL, 1, &sym))
      57                 :             :     return MATCH_ERROR;
      58                 :             : 
      59                 :       90720 :   if (sym == NULL)
      60                 :             :     return MATCH_NO;
      61                 :             : 
      62                 :       90719 :   *is_iso_c = sym->attr.is_iso_c;
      63                 :             : 
      64                 :       90719 :   if (sym->attr.flavor != FL_PARAMETER)
      65                 :             :     return MATCH_NO;
      66                 :             : 
      67                 :       90719 :   if (sym->value == NULL)
      68                 :             :     return MATCH_NO;
      69                 :             : 
      70                 :       90718 :   if (gfc_extract_int (sym->value, kind))
      71                 :             :     return MATCH_NO;
      72                 :             : 
      73                 :       90718 :   gfc_set_sym_referenced (sym);
      74                 :             : 
      75                 :       90718 :   if (*kind < 0)
      76                 :             :     return MATCH_NO;
      77                 :             : 
      78                 :             :   return MATCH_YES;
      79                 :             : }
      80                 :             : 
      81                 :             : 
      82                 :             : /* Get a trailing kind-specification for non-character variables.
      83                 :             :    Returns:
      84                 :             :      * the integer kind value or
      85                 :             :      * -1 if an error was generated,
      86                 :             :      * -2 if no kind was found.
      87                 :             :    The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
      88                 :             :    symbol like e.g. 'c_int'.  */
      89                 :             : 
      90                 :             : static int
      91                 :     3842414 : get_kind (int *is_iso_c)
      92                 :             : {
      93                 :     3842414 :   int kind;
      94                 :     3842414 :   match m;
      95                 :             : 
      96                 :     3842414 :   *is_iso_c = 0;
      97                 :             : 
      98                 :     3842414 :   if (gfc_match_char ('_', false) != MATCH_YES)
      99                 :             :     return -2;
     100                 :             : 
     101                 :      375404 :   m = match_kind_param (&kind, is_iso_c);
     102                 :      375404 :   if (m == MATCH_NO)
     103                 :        1734 :     gfc_error ("Missing kind-parameter at %C");
     104                 :             : 
     105                 :      375404 :   return (m == MATCH_YES) ? kind : -1;
     106                 :             : }
     107                 :             : 
     108                 :             : 
     109                 :             : /* Given a character and a radix, see if the character is a valid
     110                 :             :    digit in that radix.  */
     111                 :             : 
     112                 :             : bool
     113                 :    24406020 : gfc_check_digit (char c, int radix)
     114                 :             : {
     115                 :    24406020 :   bool r;
     116                 :             : 
     117                 :    24406020 :   switch (radix)
     118                 :             :     {
     119                 :       15314 :     case 2:
     120                 :       15314 :       r = ('0' <= c && c <= '1');
     121                 :       15314 :       break;
     122                 :             : 
     123                 :       18858 :     case 8:
     124                 :       18858 :       r = ('0' <= c && c <= '7');
     125                 :       18858 :       break;
     126                 :             : 
     127                 :    24308241 :     case 10:
     128                 :    24308241 :       r = ('0' <= c && c <= '9');
     129                 :    24308241 :       break;
     130                 :             : 
     131                 :       63607 :     case 16:
     132                 :       63607 :       r = ISXDIGIT (c);
     133                 :       63607 :       break;
     134                 :             : 
     135                 :           0 :     default:
     136                 :           0 :       gfc_internal_error ("gfc_check_digit(): bad radix");
     137                 :             :     }
     138                 :             : 
     139                 :    24406020 :   return r;
     140                 :             : }
     141                 :             : 
     142                 :             : 
     143                 :             : /* Match the digit string part of an integer if signflag is not set,
     144                 :             :    the signed digit string part if signflag is set.  If the buffer
     145                 :             :    is NULL, we just count characters for the resolution pass.  Returns
     146                 :             :    the number of characters matched, -1 for no match.  */
     147                 :             : 
     148                 :             : static int
     149                 :    14245644 : match_digits (int signflag, int radix, char *buffer)
     150                 :             : {
     151                 :    14245644 :   locus old_loc;
     152                 :    14245644 :   int length;
     153                 :    14245644 :   char c;
     154                 :             : 
     155                 :    14245644 :   length = 0;
     156                 :    14245644 :   c = gfc_next_ascii_char ();
     157                 :             : 
     158                 :    14245644 :   if (signflag && (c == '+' || c == '-'))
     159                 :             :     {
     160                 :        4743 :       if (buffer != NULL)
     161                 :        1844 :         *buffer++ = c;
     162                 :        4743 :       gfc_gobble_whitespace ();
     163                 :        4743 :       c = gfc_next_ascii_char ();
     164                 :        4743 :       length++;
     165                 :             :     }
     166                 :             : 
     167                 :    14245644 :   if (!gfc_check_digit (c, radix))
     168                 :             :     return -1;
     169                 :             : 
     170                 :     7188377 :   length++;
     171                 :     7188377 :   if (buffer != NULL)
     172                 :     3594188 :     *buffer++ = c;
     173                 :             : 
     174                 :    13081911 :   for (;;)
     175                 :             :     {
     176                 :    10135144 :       old_loc = gfc_current_locus;
     177                 :    10135144 :       c = gfc_next_ascii_char ();
     178                 :             : 
     179                 :    10135144 :       if (!gfc_check_digit (c, radix))
     180                 :             :         break;
     181                 :             : 
     182                 :     2946767 :       if (buffer != NULL)
     183                 :     1473382 :         *buffer++ = c;
     184                 :     2946767 :       length++;
     185                 :             :     }
     186                 :             : 
     187                 :     7188377 :   gfc_current_locus = old_loc;
     188                 :             : 
     189                 :     7188377 :   return length;
     190                 :             : }
     191                 :             : 
     192                 :             : /* Convert an integer string to an expression node.  */
     193                 :             : 
     194                 :             : static gfc_expr *
     195                 :     3588448 : convert_integer (const char *buffer, int kind, int radix, locus *where)
     196                 :             : {
     197                 :     3588448 :   gfc_expr *e;
     198                 :     3588448 :   const char *t;
     199                 :             : 
     200                 :     3588448 :   e = gfc_get_constant_expr (BT_INTEGER, kind, where);
     201                 :             :   /* A leading plus is allowed, but not by mpz_set_str.  */
     202                 :     3588448 :   if (buffer[0] == '+')
     203                 :          21 :     t = buffer + 1;
     204                 :             :   else
     205                 :             :     t = buffer;
     206                 :     3588448 :   mpz_set_str (e->value.integer, t, radix);
     207                 :             : 
     208                 :     3588448 :   return e;
     209                 :             : }
     210                 :             : 
     211                 :             : 
     212                 :             : /* Convert a real string to an expression node.  */
     213                 :             : 
     214                 :             : static gfc_expr *
     215                 :      213356 : convert_real (const char *buffer, int kind, locus *where)
     216                 :             : {
     217                 :      213356 :   gfc_expr *e;
     218                 :             : 
     219                 :      213356 :   e = gfc_get_constant_expr (BT_REAL, kind, where);
     220                 :      213356 :   mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
     221                 :             : 
     222                 :      213356 :   return e;
     223                 :             : }
     224                 :             : 
     225                 :             : 
     226                 :             : /* Convert a pair of real, constant expression nodes to a single
     227                 :             :    complex expression node.  */
     228                 :             : 
     229                 :             : static gfc_expr *
     230                 :        6512 : convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
     231                 :             : {
     232                 :        6512 :   gfc_expr *e;
     233                 :             : 
     234                 :        6512 :   e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
     235                 :        6512 :   mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
     236                 :             :                  GFC_MPC_RND_MODE);
     237                 :             : 
     238                 :        6512 :   return e;
     239                 :             : }
     240                 :             : 
     241                 :             : 
     242                 :             : /* Match an integer (digit string and optional kind).
     243                 :             :    A sign will be accepted if signflag is set.  */
     244                 :             : 
     245                 :             : static match
     246                 :    10647449 : match_integer_constant (gfc_expr **result, int signflag)
     247                 :             : {
     248                 :    10647449 :   int length, kind, is_iso_c;
     249                 :    10647449 :   locus old_loc;
     250                 :    10647449 :   char *buffer;
     251                 :    10647449 :   gfc_expr *e;
     252                 :             : 
     253                 :    10647449 :   old_loc = gfc_current_locus;
     254                 :    10647449 :   gfc_gobble_whitespace ();
     255                 :             : 
     256                 :    10647449 :   length = match_digits (signflag, 10, NULL);
     257                 :    10647449 :   gfc_current_locus = old_loc;
     258                 :    10647449 :   if (length == -1)
     259                 :             :     return MATCH_NO;
     260                 :             : 
     261                 :     3590182 :   buffer = (char *) alloca (length + 1);
     262                 :     3590182 :   memset (buffer, '\0', length + 1);
     263                 :             : 
     264                 :     3590182 :   gfc_gobble_whitespace ();
     265                 :             : 
     266                 :     3590182 :   match_digits (signflag, 10, buffer);
     267                 :             : 
     268                 :     3590182 :   kind = get_kind (&is_iso_c);
     269                 :     3590182 :   if (kind == -2)
     270                 :     3285449 :     kind = gfc_default_integer_kind;
     271                 :     3590182 :   if (kind == -1)
     272                 :             :     return MATCH_ERROR;
     273                 :             : 
     274                 :     3588452 :   if (kind == 4 && flag_integer4_kind == 8)
     275                 :           0 :     kind = 8;
     276                 :             : 
     277                 :     3588452 :   if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
     278                 :             :     {
     279                 :           4 :       gfc_error ("Integer kind %d at %C not available", kind);
     280                 :           4 :       return MATCH_ERROR;
     281                 :             :     }
     282                 :             : 
     283                 :     3588448 :   e = convert_integer (buffer, kind, 10, &gfc_current_locus);
     284                 :     3588448 :   e->ts.is_c_interop = is_iso_c;
     285                 :             : 
     286                 :     3588448 :   if (gfc_range_check (e) != ARITH_OK)
     287                 :             :     {
     288                 :           4 :       gfc_error ("Integer too big for its kind at %C. This check can be "
     289                 :             :                  "disabled with the option %<-fno-range-check%>");
     290                 :             : 
     291                 :           4 :       gfc_free_expr (e);
     292                 :           4 :       return MATCH_ERROR;
     293                 :             :     }
     294                 :             : 
     295                 :     3588444 :   *result = e;
     296                 :     3588444 :   return MATCH_YES;
     297                 :             : }
     298                 :             : 
     299                 :             : 
     300                 :             : /* Match a Hollerith constant.  */
     301                 :             : 
     302                 :             : static match
     303                 :     5287664 : match_hollerith_constant (gfc_expr **result)
     304                 :             : {
     305                 :     5287664 :   locus old_loc;
     306                 :     5287664 :   gfc_expr *e = NULL;
     307                 :     5287664 :   int num, pad;
     308                 :     5287664 :   int i;
     309                 :             : 
     310                 :     5287664 :   old_loc = gfc_current_locus;
     311                 :     5287664 :   gfc_gobble_whitespace ();
     312                 :             : 
     313                 :     5287664 :   if (match_integer_constant (&e, 0) == MATCH_YES
     314                 :     5287664 :       && gfc_match_char ('h') == MATCH_YES)
     315                 :             :     {
     316                 :        2649 :       if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
     317                 :          17 :         goto cleanup;
     318                 :             : 
     319                 :        2632 :       if (gfc_extract_int (e, &num, 1))
     320                 :           0 :         goto cleanup;
     321                 :        2632 :       if (num == 0)
     322                 :             :         {
     323                 :           1 :           gfc_error ("Invalid Hollerith constant: %L must contain at least "
     324                 :             :                      "one character", &old_loc);
     325                 :           1 :           goto cleanup;
     326                 :             :         }
     327                 :        2631 :       if (e->ts.kind != gfc_default_integer_kind)
     328                 :             :         {
     329                 :           1 :           gfc_error ("Invalid Hollerith constant: Integer kind at %L "
     330                 :             :                      "should be default", &old_loc);
     331                 :           1 :           goto cleanup;
     332                 :             :         }
     333                 :             :       else
     334                 :             :         {
     335                 :        2630 :           gfc_free_expr (e);
     336                 :        2630 :           e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
     337                 :             :                                      &gfc_current_locus);
     338                 :             : 
     339                 :             :           /* Calculate padding needed to fit default integer memory.  */
     340                 :        2630 :           pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
     341                 :             : 
     342                 :        2630 :           e->representation.string = XCNEWVEC (char, num + pad + 1);
     343                 :             : 
     344                 :       14956 :           for (i = 0; i < num; i++)
     345                 :             :             {
     346                 :       12326 :               gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
     347                 :       12326 :               if (! gfc_wide_fits_in_byte (c))
     348                 :             :                 {
     349                 :           0 :                   gfc_error ("Invalid Hollerith constant at %L contains a "
     350                 :             :                              "wide character", &old_loc);
     351                 :           0 :                   goto cleanup;
     352                 :             :                 }
     353                 :             : 
     354                 :       12326 :               e->representation.string[i] = (unsigned char) c;
     355                 :             :             }
     356                 :             : 
     357                 :             :           /* Now pad with blanks and end with a null char.  */
     358                 :       11792 :           for (i = 0; i < pad; i++)
     359                 :        9162 :             e->representation.string[num + i] = ' ';
     360                 :             : 
     361                 :        2630 :           e->representation.string[num + i] = '\0';
     362                 :        2630 :           e->representation.length = num + pad;
     363                 :        2630 :           e->ts.u.pad = pad;
     364                 :             : 
     365                 :        2630 :           *result = e;
     366                 :        2630 :           return MATCH_YES;
     367                 :             :         }
     368                 :             :     }
     369                 :             : 
     370                 :     5285015 :   gfc_free_expr (e);
     371                 :     5285015 :   gfc_current_locus = old_loc;
     372                 :     5285015 :   return MATCH_NO;
     373                 :             : 
     374                 :          19 : cleanup:
     375                 :          19 :   gfc_free_expr (e);
     376                 :          19 :   return MATCH_ERROR;
     377                 :             : }
     378                 :             : 
     379                 :             : 
     380                 :             : /* Match a binary, octal or hexadecimal constant that can be found in
     381                 :             :    a DATA statement.  The standard permits b'010...', o'73...', and
     382                 :             :    z'a1...' where b, o, and z can be capital letters.  This function
     383                 :             :    also accepts postfixed forms of the constants: '01...'b, '73...'o,
     384                 :             :    and 'a1...'z.  An additional extension is the use of x for z.  */
     385                 :             : 
     386                 :             : static match
     387                 :     5491685 : match_boz_constant (gfc_expr **result)
     388                 :             : {
     389                 :     5491685 :   int radix, length, x_hex;
     390                 :     5491685 :   locus old_loc, start_loc;
     391                 :     5491685 :   char *buffer, post, delim;
     392                 :     5491685 :   gfc_expr *e;
     393                 :             : 
     394                 :     5491685 :   start_loc = old_loc = gfc_current_locus;
     395                 :     5491685 :   gfc_gobble_whitespace ();
     396                 :             : 
     397                 :     5491685 :   x_hex = 0;
     398                 :     5491685 :   switch (post = gfc_next_ascii_char ())
     399                 :             :     {
     400                 :             :     case 'b':
     401                 :             :       radix = 2;
     402                 :             :       post = 0;
     403                 :             :       break;
     404                 :       42892 :     case 'o':
     405                 :       42892 :       radix = 8;
     406                 :       42892 :       post = 0;
     407                 :       42892 :       break;
     408                 :       55700 :     case 'x':
     409                 :       55700 :       x_hex = 1;
     410                 :             :       /* Fall through.  */
     411                 :             :     case 'z':
     412                 :             :       radix = 16;
     413                 :             :       post = 0;
     414                 :             :       break;
     415                 :          25 :     case '\'':
     416                 :             :       /* Fall through.  */
     417                 :          25 :     case '\"':
     418                 :          25 :       delim = post;
     419                 :          25 :       post = 1;
     420                 :          25 :       radix = 16;  /* Set to accept any valid digit string.  */
     421                 :          25 :       break;
     422                 :     5266680 :     default:
     423                 :     5266680 :       goto backup;
     424                 :             :     }
     425                 :             : 
     426                 :             :   /* No whitespace allowed here.  */
     427                 :             : 
     428                 :      225005 :   if (post == 0)
     429                 :      224980 :     delim = gfc_next_ascii_char ();
     430                 :             : 
     431                 :      225005 :   if (delim != '\'' && delim != '\"')
     432                 :      220996 :     goto backup;
     433                 :             : 
     434                 :        4009 :   if (x_hex
     435                 :        4009 :       && gfc_invalid_boz (G_("Hexadecimal constant at %L uses "
     436                 :             :                           "nonstandard X instead of Z"), &gfc_current_locus))
     437                 :             :     return MATCH_ERROR;
     438                 :             : 
     439                 :        4007 :   old_loc = gfc_current_locus;
     440                 :             : 
     441                 :        4007 :   length = match_digits (0, radix, NULL);
     442                 :        4007 :   if (length == -1)
     443                 :             :     {
     444                 :           0 :       gfc_error ("Empty set of digits in BOZ constant at %C");
     445                 :           0 :       return MATCH_ERROR;
     446                 :             :     }
     447                 :             : 
     448                 :        4007 :   if (gfc_next_ascii_char () != delim)
     449                 :             :     {
     450                 :           0 :       gfc_error ("Illegal character in BOZ constant at %C");
     451                 :           0 :       return MATCH_ERROR;
     452                 :             :     }
     453                 :             : 
     454                 :        4007 :   if (post == 1)
     455                 :             :     {
     456                 :          25 :       switch (gfc_next_ascii_char ())
     457                 :             :         {
     458                 :             :         case 'b':
     459                 :             :           radix = 2;
     460                 :             :           break;
     461                 :           6 :         case 'o':
     462                 :           6 :           radix = 8;
     463                 :           6 :           break;
     464                 :          13 :         case 'x':
     465                 :             :           /* Fall through.  */
     466                 :          13 :         case 'z':
     467                 :          13 :           radix = 16;
     468                 :          13 :           break;
     469                 :           0 :         default:
     470                 :           0 :           goto backup;
     471                 :             :         }
     472                 :             : 
     473                 :          25 :       if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix "
     474                 :             :                            "syntax"), &gfc_current_locus))
     475                 :             :         return MATCH_ERROR;
     476                 :             :     }
     477                 :             : 
     478                 :        4006 :   gfc_current_locus = old_loc;
     479                 :             : 
     480                 :        4006 :   buffer = (char *) alloca (length + 1);
     481                 :        4006 :   memset (buffer, '\0', length + 1);
     482                 :             : 
     483                 :        4006 :   match_digits (0, radix, buffer);
     484                 :        4006 :   gfc_next_ascii_char ();    /* Eat delimiter.  */
     485                 :        4006 :   if (post == 1)
     486                 :          24 :     gfc_next_ascii_char ();  /* Eat postfixed b, o, z, or x.  */
     487                 :             : 
     488                 :        4006 :   e = gfc_get_expr ();
     489                 :        4006 :   e->expr_type = EXPR_CONSTANT;
     490                 :        4006 :   e->ts.type = BT_BOZ;
     491                 :        4006 :   e->where = gfc_current_locus;
     492                 :        4006 :   e->boz.rdx = radix;
     493                 :        4006 :   e->boz.len = length;
     494                 :        4006 :   e->boz.str = XCNEWVEC (char, length + 1);
     495                 :        4006 :   strncpy (e->boz.str, buffer, length);
     496                 :             : 
     497                 :        4006 :   if (!gfc_in_match_data ()
     498                 :        4006 :       && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
     499                 :             :                           "statement at %L", &e->where)))
     500                 :             :     return MATCH_ERROR;
     501                 :             : 
     502                 :        4001 :   *result = e;
     503                 :        4001 :   return MATCH_YES;
     504                 :             : 
     505                 :     5487676 : backup:
     506                 :     5487676 :   gfc_current_locus = start_loc;
     507                 :     5487676 :   return MATCH_NO;
     508                 :             : }
     509                 :             : 
     510                 :             : 
     511                 :             : /* Match a real constant of some sort.  Allow a signed constant if signflag
     512                 :             :    is nonzero.  */
     513                 :             : 
     514                 :             : static match
     515                 :     5575804 : match_real_constant (gfc_expr **result, int signflag)
     516                 :             : {
     517                 :     5575804 :   int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
     518                 :     5575804 :   locus old_loc, temp_loc;
     519                 :     5575804 :   char *p, *buffer, c, exp_char;
     520                 :     5575804 :   gfc_expr *e;
     521                 :     5575804 :   bool negate;
     522                 :             : 
     523                 :     5575804 :   old_loc = gfc_current_locus;
     524                 :     5575804 :   gfc_gobble_whitespace ();
     525                 :             : 
     526                 :     5575804 :   e = NULL;
     527                 :             : 
     528                 :     5575804 :   default_exponent = 0;
     529                 :     5575804 :   count = 0;
     530                 :     5575804 :   seen_dp = 0;
     531                 :     5575804 :   seen_digits = 0;
     532                 :     5575804 :   exp_char = ' ';
     533                 :     5575804 :   negate = false;
     534                 :             : 
     535                 :     5575804 :   c = gfc_next_ascii_char ();
     536                 :     5575804 :   if (signflag && (c == '+' || c == '-'))
     537                 :             :     {
     538                 :        6139 :       if (c == '-')
     539                 :        6003 :         negate = true;
     540                 :             : 
     541                 :        6139 :       gfc_gobble_whitespace ();
     542                 :        6139 :       c = gfc_next_ascii_char ();
     543                 :             :     }
     544                 :             : 
     545                 :             :   /* Scan significand.  */
     546                 :     3245779 :   for (;; c = gfc_next_ascii_char (), count++)
     547                 :             :     {
     548                 :     8821583 :       if (c == '.')
     549                 :             :         {
     550                 :      256132 :           if (seen_dp)
     551                 :         204 :             goto done;
     552                 :             : 
     553                 :             :           /* Check to see if "." goes with a following operator like
     554                 :             :              ".eq.".  */
     555                 :      255928 :           temp_loc = gfc_current_locus;
     556                 :      255928 :           c = gfc_next_ascii_char ();
     557                 :             : 
     558                 :      255928 :           if (c == 'e' || c == 'd' || c == 'q')
     559                 :             :             {
     560                 :       18101 :               c = gfc_next_ascii_char ();
     561                 :       18101 :               if (c == '.')
     562                 :           0 :                 goto done;      /* Operator named .e. or .d.  */
     563                 :             :             }
     564                 :             : 
     565                 :      255928 :           if (ISALPHA (c))
     566                 :       48992 :             goto done;          /* Distinguish 1.e9 from 1.eq.2 */
     567                 :             : 
     568                 :      206936 :           gfc_current_locus = temp_loc;
     569                 :      206936 :           seen_dp = 1;
     570                 :      206936 :           continue;
     571                 :             :         }
     572                 :             : 
     573                 :     8565451 :       if (ISDIGIT (c))
     574                 :             :         {
     575                 :     3038843 :           seen_digits = 1;
     576                 :     3038843 :           continue;
     577                 :             :         }
     578                 :             : 
     579                 :     5526608 :       break;
     580                 :             :     }
     581                 :             : 
     582                 :     5526608 :   if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
     583                 :     5488842 :     goto done;
     584                 :       37766 :   exp_char = c;
     585                 :             : 
     586                 :             : 
     587                 :       37766 :   if (c == 'q')
     588                 :             :     {
     589                 :           0 :       if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter %<q%> in "
     590                 :             :                            "real-literal-constant at %C"))
     591                 :             :         return MATCH_ERROR;
     592                 :           0 :       else if (warn_real_q_constant)
     593                 :           0 :         gfc_warning (OPT_Wreal_q_constant,
     594                 :             :                      "Extension: exponent-letter %<q%> in real-literal-constant "
     595                 :             :                      "at %C");
     596                 :             :     }
     597                 :             : 
     598                 :             :   /* Scan exponent.  */
     599                 :       37766 :   c = gfc_next_ascii_char ();
     600                 :       37766 :   count++;
     601                 :             : 
     602                 :       37766 :   if (c == '+' || c == '-')
     603                 :             :     {                           /* optional sign */
     604                 :        6903 :       c = gfc_next_ascii_char ();
     605                 :        6903 :       count++;
     606                 :             :     }
     607                 :             : 
     608                 :       37766 :   if (!ISDIGIT (c))
     609                 :             :     {
     610                 :             :       /* With -fdec, default exponent to 0 instead of complaining.  */
     611                 :          40 :       if (flag_dec)
     612                 :       37756 :         default_exponent = 1;
     613                 :             :       else
     614                 :             :         {
     615                 :          10 :           gfc_error ("Missing exponent in real number at %C");
     616                 :          10 :           return MATCH_ERROR;
     617                 :             :         }
     618                 :             :     }
     619                 :             : 
     620                 :       78300 :   while (ISDIGIT (c))
     621                 :             :     {
     622                 :       40544 :       c = gfc_next_ascii_char ();
     623                 :       40544 :       count++;
     624                 :             :     }
     625                 :             : 
     626                 :       37756 : done:
     627                 :             :   /* Check that we have a numeric constant.  */
     628                 :     5575794 :   if (!seen_digits || (!seen_dp && exp_char == ' '))
     629                 :             :     {
     630                 :     5362434 :       gfc_current_locus = old_loc;
     631                 :     5362434 :       return MATCH_NO;
     632                 :             :     }
     633                 :             : 
     634                 :             :   /* Convert the number.  */
     635                 :      213360 :   gfc_current_locus = old_loc;
     636                 :      213360 :   gfc_gobble_whitespace ();
     637                 :             : 
     638                 :      213360 :   buffer = (char *) alloca (count + default_exponent + 1);
     639                 :      213360 :   memset (buffer, '\0', count + default_exponent + 1);
     640                 :             : 
     641                 :      213360 :   p = buffer;
     642                 :      213360 :   c = gfc_next_ascii_char ();
     643                 :      213360 :   if (c == '+' || c == '-')
     644                 :             :     {
     645                 :        3240 :       gfc_gobble_whitespace ();
     646                 :        3240 :       c = gfc_next_ascii_char ();
     647                 :             :     }
     648                 :             : 
     649                 :             :   /* Hack for mpfr_set_str().  */
     650                 :     1390848 :   for (;;)
     651                 :             :     {
     652                 :      802104 :       if (c == 'd' || c == 'q')
     653                 :       30220 :         *p = 'e';
     654                 :             :       else
     655                 :      771884 :         *p = c;
     656                 :      802104 :       p++;
     657                 :      802104 :       if (--count == 0)
     658                 :             :         break;
     659                 :             : 
     660                 :      588744 :       c = gfc_next_ascii_char ();
     661                 :             :     }
     662                 :      213360 :   if (default_exponent)
     663                 :          30 :     *p++ = '0';
     664                 :             : 
     665                 :      213360 :   kind = get_kind (&is_iso_c);
     666                 :      213360 :   if (kind == -1)
     667                 :           4 :     goto cleanup;
     668                 :             : 
     669                 :      213356 :   if (kind == 4)
     670                 :             :     {
     671                 :       20095 :       if (flag_real4_kind == 8)
     672                 :         192 :         kind = 8;
     673                 :       20095 :       if (flag_real4_kind == 10)
     674                 :         192 :         kind = 10;
     675                 :       20095 :       if (flag_real4_kind == 16)
     676                 :         384 :         kind = 16;
     677                 :             :     }
     678                 :      193261 :   else if (kind == 8)
     679                 :             :     {
     680                 :       26163 :       if (flag_real8_kind == 4)
     681                 :         192 :         kind = 4;
     682                 :       26163 :       if (flag_real8_kind == 10)
     683                 :         192 :         kind = 10;
     684                 :       26163 :       if (flag_real8_kind == 16)
     685                 :         384 :         kind = 16;
     686                 :             :     }
     687                 :             : 
     688                 :      213356 :   switch (exp_char)
     689                 :             :     {
     690                 :       30220 :     case 'd':
     691                 :       30220 :       if (kind != -2)
     692                 :             :         {
     693                 :           0 :           gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
     694                 :             :                      "kind");
     695                 :           0 :           goto cleanup;
     696                 :             :         }
     697                 :       30220 :       kind = gfc_default_double_kind;
     698                 :       30220 :       break;
     699                 :             : 
     700                 :           0 :     case 'q':
     701                 :           0 :       if (kind != -2)
     702                 :             :         {
     703                 :           0 :           gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
     704                 :             :                      "kind");
     705                 :           0 :           goto cleanup;
     706                 :             :         }
     707                 :             : 
     708                 :             :       /* The maximum possible real kind type parameter is 16.  First, try
     709                 :             :          that for the kind, then fallback to trying kind=10 (Intel 80 bit)
     710                 :             :          extended precision.  If neither value works, just given up.  */
     711                 :           0 :       kind = 16;
     712                 :           0 :       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
     713                 :             :         {
     714                 :           0 :           kind = 10;
     715                 :           0 :           if (gfc_validate_kind (BT_REAL, kind, true) < 0)
     716                 :             :             {
     717                 :           0 :               gfc_error ("Invalid exponent-letter %<q%> in "
     718                 :             :                          "real-literal-constant at %C");
     719                 :           0 :               goto cleanup;
     720                 :             :             }
     721                 :             :         }
     722                 :             :       break;
     723                 :             : 
     724                 :      183136 :     default:
     725                 :      183136 :       if (kind == -2)
     726                 :      112926 :         kind = gfc_default_real_kind;
     727                 :             : 
     728                 :      183136 :       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
     729                 :             :         {
     730                 :           0 :           gfc_error ("Invalid real kind %d at %C", kind);
     731                 :           0 :           goto cleanup;
     732                 :             :         }
     733                 :             :     }
     734                 :             : 
     735                 :      213356 :   e = convert_real (buffer, kind, &gfc_current_locus);
     736                 :      213356 :   if (negate)
     737                 :        3135 :     mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
     738                 :      213356 :   e->ts.is_c_interop = is_iso_c;
     739                 :             : 
     740                 :      213356 :   switch (gfc_range_check (e))
     741                 :             :     {
     742                 :             :     case ARITH_OK:
     743                 :             :       break;
     744                 :           1 :     case ARITH_OVERFLOW:
     745                 :           1 :       gfc_error ("Real constant overflows its kind at %C");
     746                 :           1 :       goto cleanup;
     747                 :             : 
     748                 :           0 :     case ARITH_UNDERFLOW:
     749                 :           0 :       if (warn_underflow)
     750                 :           0 :         gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
     751                 :           0 :       mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
     752                 :           0 :       break;
     753                 :             : 
     754                 :           0 :     default:
     755                 :           0 :       gfc_internal_error ("gfc_range_check() returned bad value");
     756                 :             :     }
     757                 :             : 
     758                 :             :   /* Warn about trailing digits which suggest the user added too many
     759                 :             :      trailing digits, which may cause the appearance of higher precision
     760                 :             :      than the kind can support.
     761                 :             : 
     762                 :             :      This is done by replacing the rightmost non-zero digit with zero
     763                 :             :      and comparing with the original value.  If these are equal, we
     764                 :             :      assume the user supplied more digits than intended (or forgot to
     765                 :             :      convert to the correct kind).
     766                 :             :   */
     767                 :             : 
     768                 :      213355 :   if (warn_conversion_extra)
     769                 :             :     {
     770                 :          21 :       mpfr_t r;
     771                 :          21 :       char *c1;
     772                 :          21 :       bool did_break;
     773                 :             : 
     774                 :          21 :       c1 = strchr (buffer, 'e');
     775                 :          21 :       if (c1 == NULL)
     776                 :          18 :         c1 = buffer + strlen(buffer);
     777                 :             : 
     778                 :          30 :       did_break = false;
     779                 :          30 :       for (p = c1; p > buffer;)
     780                 :             :         {
     781                 :          30 :           p--;
     782                 :          30 :           if (*p == '.')
     783                 :           7 :             continue;
     784                 :             : 
     785                 :          23 :           if (*p != '0')
     786                 :             :             {
     787                 :          21 :               *p = '0';
     788                 :          21 :               did_break = true;
     789                 :          21 :               break;
     790                 :             :             }
     791                 :             :         }
     792                 :             : 
     793                 :          21 :       if (did_break)
     794                 :             :         {
     795                 :          21 :           mpfr_init (r);
     796                 :          21 :           mpfr_set_str (r, buffer, 10, GFC_RND_MODE);
     797                 :          21 :           if (negate)
     798                 :           0 :             mpfr_neg (r, r, GFC_RND_MODE);
     799                 :             : 
     800                 :          21 :           mpfr_sub (r, r, e->value.real, GFC_RND_MODE);
     801                 :             : 
     802                 :          21 :           if (mpfr_cmp_ui (r, 0) == 0)
     803                 :           1 :             gfc_warning (OPT_Wconversion_extra, "Non-significant digits "
     804                 :             :                          "in %qs number at %C, maybe incorrect KIND",
     805                 :             :                          gfc_typename (&e->ts));
     806                 :             : 
     807                 :          21 :           mpfr_clear (r);
     808                 :             :         }
     809                 :             :     }
     810                 :             : 
     811                 :      213355 :   *result = e;
     812                 :      213355 :   return MATCH_YES;
     813                 :             : 
     814                 :           5 : cleanup:
     815                 :           5 :   gfc_free_expr (e);
     816                 :           5 :   return MATCH_ERROR;
     817                 :             : }
     818                 :             : 
     819                 :             : 
     820                 :             : /* Match a substring reference.  */
     821                 :             : 
     822                 :             : static match
     823                 :      576688 : match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
     824                 :             : {
     825                 :      576688 :   gfc_expr *start, *end;
     826                 :      576688 :   locus old_loc;
     827                 :      576688 :   gfc_ref *ref;
     828                 :      576688 :   match m;
     829                 :             : 
     830                 :      576688 :   start = NULL;
     831                 :      576688 :   end = NULL;
     832                 :             : 
     833                 :      576688 :   old_loc = gfc_current_locus;
     834                 :             : 
     835                 :      576688 :   m = gfc_match_char ('(');
     836                 :      576688 :   if (m != MATCH_YES)
     837                 :             :     return MATCH_NO;
     838                 :             : 
     839                 :       15023 :   if (gfc_match_char (':') != MATCH_YES)
     840                 :             :     {
     841                 :       14036 :       if (init)
     842                 :           0 :         m = gfc_match_init_expr (&start);
     843                 :             :       else
     844                 :       14036 :         m = gfc_match_expr (&start);
     845                 :             : 
     846                 :       14036 :       if (m != MATCH_YES)
     847                 :             :         {
     848                 :         154 :           m = MATCH_NO;
     849                 :         154 :           goto cleanup;
     850                 :             :         }
     851                 :             : 
     852                 :       13882 :       m = gfc_match_char (':');
     853                 :       13882 :       if (m != MATCH_YES)
     854                 :         454 :         goto cleanup;
     855                 :             :     }
     856                 :             : 
     857                 :       14415 :   if (gfc_match_char (')') != MATCH_YES)
     858                 :             :     {
     859                 :       13519 :       if (init)
     860                 :           0 :         m = gfc_match_init_expr (&end);
     861                 :             :       else
     862                 :       13519 :         m = gfc_match_expr (&end);
     863                 :             : 
     864                 :       13519 :       if (m == MATCH_NO)
     865                 :           2 :         goto syntax;
     866                 :       13517 :       if (m == MATCH_ERROR)
     867                 :           0 :         goto cleanup;
     868                 :             : 
     869                 :       13517 :       m = gfc_match_char (')');
     870                 :       13517 :       if (m == MATCH_NO)
     871                 :           3 :         goto syntax;
     872                 :             :     }
     873                 :             : 
     874                 :             :   /* Optimize away the (:) reference.  */
     875                 :       14410 :   if (start == NULL && end == NULL && !deferred)
     876                 :             :     ref = NULL;
     877                 :             :   else
     878                 :             :     {
     879                 :       14172 :       ref = gfc_get_ref ();
     880                 :             : 
     881                 :       14172 :       ref->type = REF_SUBSTRING;
     882                 :       14172 :       if (start == NULL)
     883                 :         747 :         start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
     884                 :       14172 :       ref->u.ss.start = start;
     885                 :       14172 :       if (end == NULL && cl)
     886                 :         656 :         end = gfc_copy_expr (cl->length);
     887                 :       14172 :       ref->u.ss.end = end;
     888                 :       14172 :       ref->u.ss.length = cl;
     889                 :             :     }
     890                 :             : 
     891                 :       14410 :   *result = ref;
     892                 :       14410 :   return MATCH_YES;
     893                 :             : 
     894                 :           5 : syntax:
     895                 :           5 :   gfc_error ("Syntax error in SUBSTRING specification at %C");
     896                 :           5 :   m = MATCH_ERROR;
     897                 :             : 
     898                 :         613 : cleanup:
     899                 :         613 :   gfc_free_expr (start);
     900                 :         613 :   gfc_free_expr (end);
     901                 :             : 
     902                 :         613 :   gfc_current_locus = old_loc;
     903                 :         613 :   return m;
     904                 :             : }
     905                 :             : 
     906                 :             : 
     907                 :             : /* Reads the next character of a string constant, taking care to
     908                 :             :    return doubled delimiters on the input as a single instance of
     909                 :             :    the delimiter.
     910                 :             : 
     911                 :             :    Special return values for "ret" argument are:
     912                 :             :      -1   End of the string, as determined by the delimiter
     913                 :             :      -2   Unterminated string detected
     914                 :             : 
     915                 :             :    Backslash codes are also expanded at this time.  */
     916                 :             : 
     917                 :             : static gfc_char_t
     918                 :     3981701 : next_string_char (gfc_char_t delimiter, int *ret)
     919                 :             : {
     920                 :     3981701 :   locus old_locus;
     921                 :     3981701 :   gfc_char_t c;
     922                 :             : 
     923                 :     3981701 :   c = gfc_next_char_literal (INSTRING_WARN);
     924                 :     3981701 :   *ret = 0;
     925                 :             : 
     926                 :     3981701 :   if (c == '\n')
     927                 :             :     {
     928                 :           4 :       *ret = -2;
     929                 :           4 :       return 0;
     930                 :             :     }
     931                 :             : 
     932                 :     3981697 :   if (flag_backslash && c == '\\')
     933                 :             :     {
     934                 :       12180 :       old_locus = gfc_current_locus;
     935                 :             : 
     936                 :       12180 :       if (gfc_match_special_char (&c) == MATCH_NO)
     937                 :           0 :         gfc_current_locus = old_locus;
     938                 :             : 
     939                 :       12180 :       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
     940                 :           0 :         gfc_warning (0, "Extension: backslash character at %C");
     941                 :             :     }
     942                 :             : 
     943                 :     3981697 :   if (c != delimiter)
     944                 :             :     return c;
     945                 :             : 
     946                 :      581960 :   old_locus = gfc_current_locus;
     947                 :      581960 :   c = gfc_next_char_literal (NONSTRING);
     948                 :             : 
     949                 :      581960 :   if (c == delimiter)
     950                 :             :     return c;
     951                 :      581142 :   gfc_current_locus = old_locus;
     952                 :             : 
     953                 :      581142 :   *ret = -1;
     954                 :      581142 :   return 0;
     955                 :             : }
     956                 :             : 
     957                 :             : 
     958                 :             : /* Special case of gfc_match_name() that matches a parameter kind name
     959                 :             :    before a string constant.  This takes case of the weird but legal
     960                 :             :    case of:
     961                 :             : 
     962                 :             :      kind_____'string'
     963                 :             : 
     964                 :             :    where kind____ is a parameter. gfc_match_name() will happily slurp
     965                 :             :    up all the underscores, which leads to problems.  If we return
     966                 :             :    MATCH_YES, the parse pointer points to the final underscore, which
     967                 :             :    is not part of the name.  We never return MATCH_ERROR-- errors in
     968                 :             :    the name will be detected later.  */
     969                 :             : 
     970                 :             : static match
     971                 :     3504168 : match_charkind_name (char *name)
     972                 :             : {
     973                 :     3504168 :   locus old_loc;
     974                 :     3504168 :   char c, peek;
     975                 :     3504168 :   int len;
     976                 :             : 
     977                 :     3504168 :   gfc_gobble_whitespace ();
     978                 :     3504168 :   c = gfc_next_ascii_char ();
     979                 :     3504168 :   if (!ISALPHA (c))
     980                 :             :     return MATCH_NO;
     981                 :             : 
     982                 :     3178982 :   *name++ = c;
     983                 :     3178982 :   len = 1;
     984                 :             : 
     985                 :    13580607 :   for (;;)
     986                 :             :     {
     987                 :    13580607 :       old_loc = gfc_current_locus;
     988                 :    13580607 :       c = gfc_next_ascii_char ();
     989                 :             : 
     990                 :    13580607 :       if (c == '_')
     991                 :             :         {
     992                 :      452077 :           peek = gfc_peek_ascii_char ();
     993                 :             : 
     994                 :      452077 :           if (peek == '\'' || peek == '\"')
     995                 :             :             {
     996                 :         794 :               gfc_current_locus = old_loc;
     997                 :         794 :               *name = '\0';
     998                 :         794 :               return MATCH_YES;
     999                 :             :             }
    1000                 :             :         }
    1001                 :             : 
    1002                 :    13579813 :       if (!ISALNUM (c)
    1003                 :     3629471 :           && c != '_'
    1004                 :     3178188 :           && (c != '$' || !flag_dollar_ok))
    1005                 :             :         break;
    1006                 :             : 
    1007                 :    10401625 :       *name++ = c;
    1008                 :    10401625 :       if (++len > GFC_MAX_SYMBOL_LEN)
    1009                 :             :         break;
    1010                 :             :     }
    1011                 :             : 
    1012                 :             :   return MATCH_NO;
    1013                 :             : }
    1014                 :             : 
    1015                 :             : 
    1016                 :             : /* See if the current input matches a character constant.  Lots of
    1017                 :             :    contortions have to be done to match the kind parameter which comes
    1018                 :             :    before the actual string.  The main consideration is that we don't
    1019                 :             :    want to error out too quickly.  For example, we don't actually do
    1020                 :             :    any validation of the kinds until we have actually seen a legal
    1021                 :             :    delimiter.  Using match_kind_param() generates errors too quickly.  */
    1022                 :             : 
    1023                 :             : static match
    1024                 :     5782250 : match_string_constant (gfc_expr **result)
    1025                 :             : {
    1026                 :     5782250 :   char name[GFC_MAX_SYMBOL_LEN + 1], peek;
    1027                 :     5782250 :   size_t length;
    1028                 :     5782250 :   int kind,save_warn_ampersand, ret;
    1029                 :     5782250 :   locus old_locus, start_locus;
    1030                 :     5782250 :   gfc_symbol *sym;
    1031                 :     5782250 :   gfc_expr *e;
    1032                 :     5782250 :   match m;
    1033                 :     5782250 :   gfc_char_t c, delimiter, *p;
    1034                 :             : 
    1035                 :     5782250 :   old_locus = gfc_current_locus;
    1036                 :             : 
    1037                 :     5782250 :   gfc_gobble_whitespace ();
    1038                 :             : 
    1039                 :     5782250 :   c = gfc_next_char ();
    1040                 :     5782250 :   if (c == '\'' || c == '"')
    1041                 :             :     {
    1042                 :      252837 :       kind = gfc_default_character_kind;
    1043                 :      252837 :       start_locus = gfc_current_locus;
    1044                 :      252837 :       goto got_delim;
    1045                 :             :     }
    1046                 :             : 
    1047                 :     5529413 :   if (gfc_wide_is_digit (c))
    1048                 :             :     {
    1049                 :     2025245 :       kind = 0;
    1050                 :             : 
    1051                 :     4812223 :       while (gfc_wide_is_digit (c))
    1052                 :             :         {
    1053                 :     2790549 :           kind = kind * 10 + c - '0';
    1054                 :     2790549 :           if (kind > 9999999)
    1055                 :        3571 :             goto no_match;
    1056                 :     2786978 :           c = gfc_next_char ();
    1057                 :             :         }
    1058                 :             : 
    1059                 :             :     }
    1060                 :             :   else
    1061                 :             :     {
    1062                 :     3504168 :       gfc_current_locus = old_locus;
    1063                 :             : 
    1064                 :     3504168 :       m = match_charkind_name (name);
    1065                 :     3504168 :       if (m != MATCH_YES)
    1066                 :     3503374 :         goto no_match;
    1067                 :             : 
    1068                 :         794 :       if (gfc_find_symbol (name, NULL, 1, &sym)
    1069                 :         794 :           || sym == NULL
    1070                 :        1587 :           || sym->attr.flavor != FL_PARAMETER)
    1071                 :           1 :         goto no_match;
    1072                 :             : 
    1073                 :         793 :       kind = -1;
    1074                 :         793 :       c = gfc_next_char ();
    1075                 :             :     }
    1076                 :             : 
    1077                 :     2022467 :   if (c != '_')
    1078                 :     1837100 :     goto no_match;
    1079                 :             : 
    1080                 :      185367 :   c = gfc_next_char ();
    1081                 :      185367 :   if (c != '\'' && c != '"')
    1082                 :      147614 :     goto no_match;
    1083                 :             : 
    1084                 :       37753 :   start_locus = gfc_current_locus;
    1085                 :             : 
    1086                 :       37753 :   if (kind == -1)
    1087                 :             :     {
    1088                 :         793 :       if (gfc_extract_int (sym->value, &kind, 1))
    1089                 :             :         return MATCH_ERROR;
    1090                 :         793 :       gfc_set_sym_referenced (sym);
    1091                 :             :     }
    1092                 :             : 
    1093                 :       37753 :   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
    1094                 :             :     {
    1095                 :           0 :       gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
    1096                 :           0 :       return MATCH_ERROR;
    1097                 :             :     }
    1098                 :             : 
    1099                 :       37753 : got_delim:
    1100                 :             :   /* Scan the string into a block of memory by first figuring out how
    1101                 :             :      long it is, allocating the structure, then re-reading it.  This
    1102                 :             :      isn't particularly efficient, but string constants aren't that
    1103                 :             :      common in most code.  TODO: Use obstacks?  */
    1104                 :             : 
    1105                 :      290590 :   delimiter = c;
    1106                 :      290590 :   length = 0;
    1107                 :             : 
    1108                 :     3691454 :   for (;;)
    1109                 :             :     {
    1110                 :     1991022 :       c = next_string_char (delimiter, &ret);
    1111                 :     1991022 :       if (ret == -1)
    1112                 :             :         break;
    1113                 :     1700436 :       if (ret == -2)
    1114                 :             :         {
    1115                 :           4 :           gfc_current_locus = start_locus;
    1116                 :           4 :           gfc_error ("Unterminated character constant beginning at %C");
    1117                 :           4 :           return MATCH_ERROR;
    1118                 :             :         }
    1119                 :             : 
    1120                 :     1700432 :       length++;
    1121                 :             :     }
    1122                 :             : 
    1123                 :             :   /* Peek at the next character to see if it is a b, o, z, or x for the
    1124                 :             :      postfixed BOZ literal constants.  */
    1125                 :      290586 :   peek = gfc_peek_ascii_char ();
    1126                 :      290586 :   if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
    1127                 :          25 :     goto no_match;
    1128                 :             : 
    1129                 :      290561 :   e = gfc_get_character_expr (kind, &start_locus, NULL, length);
    1130                 :             : 
    1131                 :      290561 :   gfc_current_locus = start_locus;
    1132                 :             : 
    1133                 :             :   /* We disable the warning for the following loop as the warning has already
    1134                 :             :      been printed in the loop above.  */
    1135                 :      290561 :   save_warn_ampersand = warn_ampersand;
    1136                 :      290561 :   warn_ampersand = false;
    1137                 :             : 
    1138                 :      290561 :   p = e->value.character.string;
    1139                 :     1990679 :   for (size_t i = 0; i < length; i++)
    1140                 :             :     {
    1141                 :     1700123 :       c = next_string_char (delimiter, &ret);
    1142                 :             : 
    1143                 :     1700123 :       if (!gfc_check_character_range (c, kind))
    1144                 :             :         {
    1145                 :           5 :           gfc_free_expr (e);
    1146                 :           5 :           gfc_error ("Character %qs in string at %C is not representable "
    1147                 :             :                      "in character kind %d", gfc_print_wide_char (c), kind);
    1148                 :           5 :           return MATCH_ERROR;
    1149                 :             :         }
    1150                 :             : 
    1151                 :     1700118 :       *p++ = c;
    1152                 :             :     }
    1153                 :             : 
    1154                 :      290556 :   *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
    1155                 :      290556 :   warn_ampersand = save_warn_ampersand;
    1156                 :             : 
    1157                 :      290556 :   next_string_char (delimiter, &ret);
    1158                 :      290556 :   if (ret != -1)
    1159                 :           0 :     gfc_internal_error ("match_string_constant(): Delimiter not found");
    1160                 :             : 
    1161                 :      290556 :   if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
    1162                 :         312 :     e->expr_type = EXPR_SUBSTRING;
    1163                 :             : 
    1164                 :             :   /* Substrings with constant starting and ending points are eligible as
    1165                 :             :      designators (F2018, section 9.1).  Simplify substrings to make them usable
    1166                 :             :      e.g. in data statements.  */
    1167                 :      290556 :   if (e->expr_type == EXPR_SUBSTRING
    1168                 :         312 :       && e->ref && e->ref->type == REF_SUBSTRING
    1169                 :         308 :       && e->ref->u.ss.start->expr_type == EXPR_CONSTANT
    1170                 :          73 :       && (e->ref->u.ss.end == NULL
    1171                 :          71 :           || e->ref->u.ss.end->expr_type == EXPR_CONSTANT))
    1172                 :             :     {
    1173                 :          71 :       gfc_expr *res;
    1174                 :          71 :       ptrdiff_t istart, iend;
    1175                 :          71 :       size_t length;
    1176                 :          71 :       bool equal_length = false;
    1177                 :             : 
    1178                 :             :       /* Basic checks on substring starting and ending indices.  */
    1179                 :          71 :       if (!gfc_resolve_substring (e->ref, &equal_length))
    1180                 :           6 :         return MATCH_ERROR;
    1181                 :             : 
    1182                 :          68 :       length = e->value.character.length;
    1183                 :          68 :       istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer);
    1184                 :          68 :       if (e->ref->u.ss.end == NULL)
    1185                 :             :         iend = length;
    1186                 :             :       else
    1187                 :          66 :         iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer);
    1188                 :             : 
    1189                 :          68 :       if (istart <= iend)
    1190                 :             :         {
    1191                 :          65 :           if (istart < 1)
    1192                 :             :             {
    1193                 :           2 :               gfc_error ("Substring start index (%td) at %L below 1",
    1194                 :           2 :                          istart, &e->ref->u.ss.start->where);
    1195                 :           2 :               return MATCH_ERROR;
    1196                 :             :             }
    1197                 :          63 :           if (iend > (ssize_t) length)
    1198                 :             :             {
    1199                 :           1 :               gfc_error ("Substring end index (%td) at %L exceeds string "
    1200                 :           1 :                          "length", iend, &e->ref->u.ss.end->where);
    1201                 :           1 :               return MATCH_ERROR;
    1202                 :             :             }
    1203                 :          62 :           length = iend - istart + 1;
    1204                 :             :         }
    1205                 :             :       else
    1206                 :             :         length = 0;
    1207                 :             : 
    1208                 :          65 :       res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
    1209                 :          65 :       res->value.character.string = gfc_get_wide_string (length + 1);
    1210                 :          65 :       res->value.character.length = length;
    1211                 :          65 :       if (length > 0)
    1212                 :          62 :         memcpy (res->value.character.string,
    1213                 :          62 :                 &e->value.character.string[istart - 1],
    1214                 :             :                 length * sizeof (gfc_char_t));
    1215                 :          65 :       res->value.character.string[length] = '\0';
    1216                 :          65 :       e = res;
    1217                 :             :     }
    1218                 :             : 
    1219                 :      290550 :   *result = e;
    1220                 :             : 
    1221                 :      290550 :   return MATCH_YES;
    1222                 :             : 
    1223                 :     5491685 : no_match:
    1224                 :     5491685 :   gfc_current_locus = old_locus;
    1225                 :     5491685 :   return MATCH_NO;
    1226                 :             : }
    1227                 :             : 
    1228                 :             : 
    1229                 :             : /* Match a .true. or .false.  Returns 1 if a .true. was found,
    1230                 :             :    0 if a .false. was found, and -1 otherwise.  */
    1231                 :             : static int
    1232                 :     3498074 : match_logical_constant_string (void)
    1233                 :             : {
    1234                 :     3498074 :   locus orig_loc = gfc_current_locus;
    1235                 :             : 
    1236                 :     3498074 :   gfc_gobble_whitespace ();
    1237                 :     3498074 :   if (gfc_next_ascii_char () == '.')
    1238                 :             :     {
    1239                 :       38873 :       char ch = gfc_next_ascii_char ();
    1240                 :       38873 :       if (ch == 'f')
    1241                 :             :         {
    1242                 :       20607 :           if (gfc_next_ascii_char () == 'a'
    1243                 :       20607 :               && gfc_next_ascii_char () == 'l'
    1244                 :       20607 :               && gfc_next_ascii_char () == 's'
    1245                 :       20607 :               && gfc_next_ascii_char () == 'e'
    1246                 :       41214 :               && gfc_next_ascii_char () == '.')
    1247                 :             :             /* Matched ".false.".  */
    1248                 :             :             return 0;
    1249                 :             :         }
    1250                 :       18266 :       else if (ch == 't')
    1251                 :             :         {
    1252                 :       18265 :           if (gfc_next_ascii_char () == 'r'
    1253                 :       18265 :               && gfc_next_ascii_char () == 'u'
    1254                 :       18265 :               && gfc_next_ascii_char () == 'e'
    1255                 :       36530 :               && gfc_next_ascii_char () == '.')
    1256                 :             :             /* Matched ".true.".  */
    1257                 :             :             return 1;
    1258                 :             :         }
    1259                 :             :     }
    1260                 :     3459202 :   gfc_current_locus = orig_loc;
    1261                 :     3459202 :   return -1;
    1262                 :             : }
    1263                 :             : 
    1264                 :             : /* Match a .true. or .false.  */
    1265                 :             : 
    1266                 :             : static match
    1267                 :     3498074 : match_logical_constant (gfc_expr **result)
    1268                 :             : {
    1269                 :     3498074 :   gfc_expr *e;
    1270                 :     3498074 :   int i, kind, is_iso_c;
    1271                 :             : 
    1272                 :     3498074 :   i = match_logical_constant_string ();
    1273                 :     3498074 :   if (i == -1)
    1274                 :             :     return MATCH_NO;
    1275                 :             : 
    1276                 :       38872 :   kind = get_kind (&is_iso_c);
    1277                 :       38872 :   if (kind == -1)
    1278                 :             :     return MATCH_ERROR;
    1279                 :       38872 :   if (kind == -2)
    1280                 :       38415 :     kind = gfc_default_logical_kind;
    1281                 :             : 
    1282                 :       38872 :   if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
    1283                 :             :     {
    1284                 :           4 :       gfc_error ("Bad kind for logical constant at %C");
    1285                 :           4 :       return MATCH_ERROR;
    1286                 :             :     }
    1287                 :             : 
    1288                 :       38868 :   e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
    1289                 :       38868 :   e->ts.is_c_interop = is_iso_c;
    1290                 :             : 
    1291                 :       38868 :   *result = e;
    1292                 :       38868 :   return MATCH_YES;
    1293                 :             : }
    1294                 :             : 
    1295                 :             : 
    1296                 :             : /* Match a real or imaginary part of a complex constant that is a
    1297                 :             :    symbolic constant.  */
    1298                 :             : 
    1299                 :             : static match
    1300                 :      119321 : match_sym_complex_part (gfc_expr **result)
    1301                 :             : {
    1302                 :      119321 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1303                 :      119321 :   gfc_symbol *sym;
    1304                 :      119321 :   gfc_expr *e;
    1305                 :      119321 :   match m;
    1306                 :             : 
    1307                 :      119321 :   m = gfc_match_name (name);
    1308                 :      119321 :   if (m != MATCH_YES)
    1309                 :             :     return m;
    1310                 :             : 
    1311                 :       36350 :   if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
    1312                 :             :     return MATCH_NO;
    1313                 :             : 
    1314                 :       33706 :   if (sym->attr.flavor != FL_PARAMETER)
    1315                 :             :     {
    1316                 :             :       /* Give the matcher for implied do-loops a chance to run.  This yields
    1317                 :             :          a much saner error message for "write(*,*) (i, i=1, 6" where the
    1318                 :             :          right parenthesis is missing.  */
    1319                 :       32311 :       char c;
    1320                 :       32311 :       gfc_gobble_whitespace ();
    1321                 :       32311 :       c = gfc_peek_ascii_char ();
    1322                 :       32311 :       if (c == '=' || c == ',')
    1323                 :             :         {
    1324                 :             :           m = MATCH_NO;
    1325                 :             :         }
    1326                 :             :       else
    1327                 :             :         {
    1328                 :       29798 :           gfc_error ("Expected PARAMETER symbol in complex constant at %C");
    1329                 :       29798 :           m = MATCH_ERROR;
    1330                 :             :         }
    1331                 :       32311 :       return m;
    1332                 :             :     }
    1333                 :             : 
    1334                 :        1395 :   if (!sym->value)
    1335                 :           2 :     goto error;
    1336                 :             : 
    1337                 :        1393 :   if (!gfc_numeric_ts (&sym->value->ts))
    1338                 :             :     {
    1339                 :         330 :       gfc_error ("Numeric PARAMETER required in complex constant at %C");
    1340                 :         330 :       return MATCH_ERROR;
    1341                 :             :     }
    1342                 :             : 
    1343                 :        1063 :   if (sym->value->rank != 0)
    1344                 :             :     {
    1345                 :         174 :       gfc_error ("Scalar PARAMETER required in complex constant at %C");
    1346                 :         174 :       return MATCH_ERROR;
    1347                 :             :     }
    1348                 :             : 
    1349                 :         889 :   if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
    1350                 :             :                        "complex constant at %C"))
    1351                 :             :     return MATCH_ERROR;
    1352                 :             : 
    1353                 :         886 :   switch (sym->value->ts.type)
    1354                 :             :     {
    1355                 :          20 :     case BT_REAL:
    1356                 :          20 :       e = gfc_copy_expr (sym->value);
    1357                 :          20 :       break;
    1358                 :             : 
    1359                 :           1 :     case BT_COMPLEX:
    1360                 :           1 :       e = gfc_complex2real (sym->value, sym->value->ts.kind);
    1361                 :           1 :       if (e == NULL)
    1362                 :           0 :         goto error;
    1363                 :             :       break;
    1364                 :             : 
    1365                 :         865 :     case BT_INTEGER:
    1366                 :         865 :       e = gfc_int2real (sym->value, gfc_default_real_kind);
    1367                 :         865 :       if (e == NULL)
    1368                 :           0 :         goto error;
    1369                 :             :       break;
    1370                 :             : 
    1371                 :           0 :     default:
    1372                 :           0 :       gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
    1373                 :             :     }
    1374                 :             : 
    1375                 :         886 :   *result = e;          /* e is a scalar, real, constant expression.  */
    1376                 :         886 :   return MATCH_YES;
    1377                 :             : 
    1378                 :           2 : error:
    1379                 :           2 :   gfc_error ("Error converting PARAMETER constant in complex constant at %C");
    1380                 :           2 :   return MATCH_ERROR;
    1381                 :             : }
    1382                 :             : 
    1383                 :             : 
    1384                 :             : /* Match a real or imaginary part of a complex number.  */
    1385                 :             : 
    1386                 :             : static match
    1387                 :      119321 : match_complex_part (gfc_expr **result)
    1388                 :             : {
    1389                 :      119321 :   match m;
    1390                 :             : 
    1391                 :      119321 :   m = match_sym_complex_part (result);
    1392                 :      119321 :   if (m != MATCH_NO)
    1393                 :             :     return m;
    1394                 :             : 
    1395                 :       88128 :   m = match_real_constant (result, 1);
    1396                 :       88128 :   if (m != MATCH_NO)
    1397                 :             :     return m;
    1398                 :             : 
    1399                 :       74770 :   return match_integer_constant (result, 1);
    1400                 :             : }
    1401                 :             : 
    1402                 :             : 
    1403                 :             : /* Try to match a complex constant.  */
    1404                 :             : 
    1405                 :             : static match
    1406                 :     5791922 : match_complex_constant (gfc_expr **result)
    1407                 :             : {
    1408                 :     5791922 :   gfc_expr *e, *real, *imag;
    1409                 :     5791922 :   gfc_error_buffer old_error;
    1410                 :     5791922 :   gfc_typespec target;
    1411                 :     5791922 :   locus old_loc;
    1412                 :     5791922 :   int kind;
    1413                 :     5791922 :   match m;
    1414                 :             : 
    1415                 :     5791922 :   old_loc = gfc_current_locus;
    1416                 :     5791922 :   real = imag = e = NULL;
    1417                 :             : 
    1418                 :     5791922 :   m = gfc_match_char ('(');
    1419                 :     5791922 :   if (m != MATCH_YES)
    1420                 :             :     return m;
    1421                 :             : 
    1422                 :      109653 :   gfc_push_error (&old_error);
    1423                 :             : 
    1424                 :      109653 :   m = match_complex_part (&real);
    1425                 :      109653 :   if (m == MATCH_NO)
    1426                 :             :     {
    1427                 :       58032 :       gfc_free_error (&old_error);
    1428                 :       58032 :       goto cleanup;
    1429                 :             :     }
    1430                 :             : 
    1431                 :       51621 :   if (gfc_match_char (',') == MATCH_NO)
    1432                 :             :     {
    1433                 :             :       /* It is possible that gfc_int2real issued a warning when
    1434                 :             :          converting an integer to real.  Throw this away here.  */
    1435                 :             : 
    1436                 :       41949 :       gfc_clear_warning ();
    1437                 :       41949 :       gfc_pop_error (&old_error);
    1438                 :       41949 :       m = MATCH_NO;
    1439                 :       41949 :       goto cleanup;
    1440                 :             :     }
    1441                 :             : 
    1442                 :             :   /* If m is error, then something was wrong with the real part and we
    1443                 :             :      assume we have a complex constant because we've seen the ','.  An
    1444                 :             :      ambiguous case here is the start of an iterator list of some
    1445                 :             :      sort. These sort of lists are matched prior to coming here.  */
    1446                 :             : 
    1447                 :        9672 :   if (m == MATCH_ERROR)
    1448                 :             :     {
    1449                 :           4 :       gfc_free_error (&old_error);
    1450                 :           4 :       goto cleanup;
    1451                 :             :     }
    1452                 :        9668 :   gfc_pop_error (&old_error);
    1453                 :             : 
    1454                 :        9668 :   m = match_complex_part (&imag);
    1455                 :        9668 :   if (m == MATCH_NO)
    1456                 :        3010 :     goto syntax;
    1457                 :        6658 :   if (m == MATCH_ERROR)
    1458                 :         133 :     goto cleanup;
    1459                 :             : 
    1460                 :        6525 :   m = gfc_match_char (')');
    1461                 :        6525 :   if (m == MATCH_NO)
    1462                 :             :     {
    1463                 :             :       /* Give the matcher for implied do-loops a chance to run.  This
    1464                 :             :          yields a much saner error message for (/ (i, 4=i, 6) /).  */
    1465                 :          13 :       if (gfc_peek_ascii_char () == '=')
    1466                 :             :         {
    1467                 :           0 :           m = MATCH_ERROR;
    1468                 :           0 :           goto cleanup;
    1469                 :             :         }
    1470                 :             :       else
    1471                 :          13 :     goto syntax;
    1472                 :             :     }
    1473                 :             : 
    1474                 :        6512 :   if (m == MATCH_ERROR)
    1475                 :           0 :     goto cleanup;
    1476                 :             : 
    1477                 :             :   /* Decide on the kind of this complex number.  */
    1478                 :        6512 :   if (real->ts.type == BT_REAL)
    1479                 :             :     {
    1480                 :        6099 :       if (imag->ts.type == BT_REAL)
    1481                 :        6074 :         kind = gfc_kind_max (real, imag);
    1482                 :             :       else
    1483                 :          25 :         kind = real->ts.kind;
    1484                 :             :     }
    1485                 :             :   else
    1486                 :             :     {
    1487                 :         413 :       if (imag->ts.type == BT_REAL)
    1488                 :           7 :         kind = imag->ts.kind;
    1489                 :             :       else
    1490                 :         406 :         kind = gfc_default_real_kind;
    1491                 :             :     }
    1492                 :        6512 :   gfc_clear_ts (&target);
    1493                 :        6512 :   target.type = BT_REAL;
    1494                 :        6512 :   target.kind = kind;
    1495                 :             : 
    1496                 :        6512 :   if (real->ts.type != BT_REAL || kind != real->ts.kind)
    1497                 :         414 :     gfc_convert_type (real, &target, 2);
    1498                 :        6512 :   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
    1499                 :         469 :     gfc_convert_type (imag, &target, 2);
    1500                 :             : 
    1501                 :        6512 :   e = convert_complex (real, imag, kind);
    1502                 :        6512 :   e->where = gfc_current_locus;
    1503                 :             : 
    1504                 :        6512 :   gfc_free_expr (real);
    1505                 :        6512 :   gfc_free_expr (imag);
    1506                 :             : 
    1507                 :        6512 :   *result = e;
    1508                 :        6512 :   return MATCH_YES;
    1509                 :             : 
    1510                 :        3023 : syntax:
    1511                 :        3023 :   gfc_error ("Syntax error in COMPLEX constant at %C");
    1512                 :        3023 :   m = MATCH_ERROR;
    1513                 :             : 
    1514                 :      103141 : cleanup:
    1515                 :      103141 :   gfc_free_expr (e);
    1516                 :      103141 :   gfc_free_expr (real);
    1517                 :      103141 :   gfc_free_expr (imag);
    1518                 :      103141 :   gfc_current_locus = old_loc;
    1519                 :             : 
    1520                 :      103141 :   return m;
    1521                 :     5791922 : }
    1522                 :             : 
    1523                 :             : 
    1524                 :             : /* Match constants in any of several forms.  Returns nonzero for a
    1525                 :             :    match, zero for no match.  */
    1526                 :             : 
    1527                 :             : match
    1528                 :     5791922 : gfc_match_literal_constant (gfc_expr **result, int signflag)
    1529                 :             : {
    1530                 :     5791922 :   match m;
    1531                 :             : 
    1532                 :     5791922 :   m = match_complex_constant (result);
    1533                 :     5791922 :   if (m != MATCH_NO)
    1534                 :             :     return m;
    1535                 :             : 
    1536                 :     5782250 :   m = match_string_constant (result);
    1537                 :     5782250 :   if (m != MATCH_NO)
    1538                 :             :     return m;
    1539                 :             : 
    1540                 :     5491685 :   m = match_boz_constant (result);
    1541                 :     5491685 :   if (m != MATCH_NO)
    1542                 :             :     return m;
    1543                 :             : 
    1544                 :     5487676 :   m = match_real_constant (result, signflag);
    1545                 :     5487676 :   if (m != MATCH_NO)
    1546                 :             :     return m;
    1547                 :             : 
    1548                 :     5287664 :   m = match_hollerith_constant (result);
    1549                 :     5287664 :   if (m != MATCH_NO)
    1550                 :             :     return m;
    1551                 :             : 
    1552                 :     5285015 :   m = match_integer_constant (result, signflag);
    1553                 :     5285015 :   if (m != MATCH_NO)
    1554                 :             :     return m;
    1555                 :             : 
    1556                 :     3498074 :   m = match_logical_constant (result);
    1557                 :     3498074 :   if (m != MATCH_NO)
    1558                 :             :     return m;
    1559                 :             : 
    1560                 :             :   return MATCH_NO;
    1561                 :             : }
    1562                 :             : 
    1563                 :             : 
    1564                 :             : /* This checks if a symbol is the return value of an encompassing function.
    1565                 :             :    Function nesting can be maximally two levels deep, but we may have
    1566                 :             :    additional local namespaces like BLOCK etc.  */
    1567                 :             : 
    1568                 :             : bool
    1569                 :      682075 : gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
    1570                 :             : {
    1571                 :      682075 :   if (!sym->attr.function || (sym->result != sym))
    1572                 :             :     return false;
    1573                 :     1413669 :   while (ns)
    1574                 :             :     {
    1575                 :      795714 :       if (ns->proc_name == sym)
    1576                 :             :         return true;
    1577                 :      784783 :       ns = ns->parent;
    1578                 :             :     }
    1579                 :             :   return false;
    1580                 :             : }
    1581                 :             : 
    1582                 :             : 
    1583                 :             : /* Match a single actual argument value.  An actual argument is
    1584                 :             :    usually an expression, but can also be a procedure name.  If the
    1585                 :             :    argument is a single name, it is not always possible to tell
    1586                 :             :    whether the name is a dummy procedure or not.  We treat these cases
    1587                 :             :    by creating an argument that looks like a dummy procedure and
    1588                 :             :    fixing things later during resolution.  */
    1589                 :             : 
    1590                 :             : static match
    1591                 :     1745051 : match_actual_arg (gfc_expr **result)
    1592                 :             : {
    1593                 :     1745051 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1594                 :     1745051 :   gfc_symtree *symtree;
    1595                 :     1745051 :   locus where, w;
    1596                 :     1745051 :   gfc_expr *e;
    1597                 :     1745051 :   char c;
    1598                 :             : 
    1599                 :     1745051 :   gfc_gobble_whitespace ();
    1600                 :     1745051 :   where = gfc_current_locus;
    1601                 :             : 
    1602                 :     1745051 :   switch (gfc_match_name (name))
    1603                 :             :     {
    1604                 :             :     case MATCH_ERROR:
    1605                 :             :       return MATCH_ERROR;
    1606                 :             : 
    1607                 :             :     case MATCH_NO:
    1608                 :             :       break;
    1609                 :             : 
    1610                 :     1123855 :     case MATCH_YES:
    1611                 :     1123855 :       w = gfc_current_locus;
    1612                 :     1123855 :       gfc_gobble_whitespace ();
    1613                 :     1123855 :       c = gfc_next_ascii_char ();
    1614                 :     1123855 :       gfc_current_locus = w;
    1615                 :             : 
    1616                 :     1123855 :       if (c != ',' && c != ')')
    1617                 :             :         break;
    1618                 :             : 
    1619                 :      593822 :       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
    1620                 :             :         break;
    1621                 :             :       /* Handle error elsewhere.  */
    1622                 :             : 
    1623                 :             :       /* Eliminate a couple of common cases where we know we don't
    1624                 :             :          have a function argument.  */
    1625                 :      593822 :       if (symtree == NULL)
    1626                 :             :         {
    1627                 :       11774 :           gfc_get_sym_tree (name, NULL, &symtree, false);
    1628                 :       11774 :           gfc_set_sym_referenced (symtree->n.sym);
    1629                 :             :         }
    1630                 :             :       else
    1631                 :             :         {
    1632                 :      582048 :           gfc_symbol *sym;
    1633                 :             : 
    1634                 :      582048 :           sym = symtree->n.sym;
    1635                 :      582048 :           gfc_set_sym_referenced (sym);
    1636                 :      582048 :           if (sym->attr.flavor == FL_NAMELIST)
    1637                 :             :             {
    1638                 :        1095 :               gfc_error ("Namelist %qs cannot be an argument at %L",
    1639                 :             :               sym->name, &where);
    1640                 :        1095 :               break;
    1641                 :             :             }
    1642                 :      580953 :           if (sym->attr.flavor != FL_PROCEDURE
    1643                 :      547927 :               && sym->attr.flavor != FL_UNKNOWN)
    1644                 :             :             break;
    1645                 :             : 
    1646                 :      171471 :           if (sym->attr.in_common && !sym->attr.proc_pointer)
    1647                 :             :             {
    1648                 :         224 :               if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
    1649                 :             :                                    sym->name, &sym->declared_at))
    1650                 :             :                 return MATCH_ERROR;
    1651                 :             :               break;
    1652                 :             :             }
    1653                 :             : 
    1654                 :             :           /* If the symbol is a function with itself as the result and
    1655                 :             :              is being defined, then we have a variable.  */
    1656                 :      171247 :           if (sym->attr.function && sym->result == sym)
    1657                 :             :             {
    1658                 :        2964 :               if (gfc_is_function_return_value (sym, gfc_current_ns))
    1659                 :             :                 break;
    1660                 :             : 
    1661                 :        2350 :               if (sym->attr.entry
    1662                 :          55 :                   && (sym->ns == gfc_current_ns
    1663                 :           2 :                       || sym->ns == gfc_current_ns->parent))
    1664                 :             :                 {
    1665                 :          54 :                   gfc_entry_list *el = NULL;
    1666                 :             : 
    1667                 :          54 :                   for (el = sym->ns->entries; el; el = el->next)
    1668                 :          54 :                     if (sym == el->sym)
    1669                 :             :                       break;
    1670                 :             : 
    1671                 :          54 :                   if (el)
    1672                 :             :                     break;
    1673                 :             :                 }
    1674                 :             :             }
    1675                 :             :         }
    1676                 :             : 
    1677                 :      182353 :       e = gfc_get_expr ();      /* Leave it unknown for now */
    1678                 :      182353 :       e->symtree = symtree;
    1679                 :      182353 :       e->expr_type = EXPR_VARIABLE;
    1680                 :      182353 :       e->ts.type = BT_PROCEDURE;
    1681                 :      182353 :       e->where = where;
    1682                 :             : 
    1683                 :      182353 :       *result = e;
    1684                 :      182353 :       return MATCH_YES;
    1685                 :             :     }
    1686                 :             : 
    1687                 :     1562698 :   gfc_current_locus = where;
    1688                 :     1562698 :   return gfc_match_expr (result);
    1689                 :             : }
    1690                 :             : 
    1691                 :             : 
    1692                 :             : /* Match a keyword argument or type parameter spec list..  */
    1693                 :             : 
    1694                 :             : static match
    1695                 :     1736984 : match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
    1696                 :             : {
    1697                 :     1736984 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1698                 :     1736984 :   gfc_actual_arglist *a;
    1699                 :     1736984 :   locus name_locus;
    1700                 :     1736984 :   match m;
    1701                 :             : 
    1702                 :     1736984 :   name_locus = gfc_current_locus;
    1703                 :     1736984 :   m = gfc_match_name (name);
    1704                 :             : 
    1705                 :     1736984 :   if (m != MATCH_YES)
    1706                 :      537484 :     goto cleanup;
    1707                 :     1199500 :   if (gfc_match_char ('=') != MATCH_YES)
    1708                 :             :     {
    1709                 :     1070825 :       m = MATCH_NO;
    1710                 :     1070825 :       goto cleanup;
    1711                 :             :     }
    1712                 :             : 
    1713                 :      128675 :   if (pdt)
    1714                 :             :     {
    1715                 :         214 :       if (gfc_match_char ('*') == MATCH_YES)
    1716                 :             :         {
    1717                 :          18 :           actual->spec_type = SPEC_ASSUMED;
    1718                 :          18 :           goto add_name;
    1719                 :             :         }
    1720                 :         196 :       else if (gfc_match_char (':') == MATCH_YES)
    1721                 :             :         {
    1722                 :          14 :           actual->spec_type = SPEC_DEFERRED;
    1723                 :          14 :           goto add_name;
    1724                 :             :         }
    1725                 :             :       else
    1726                 :         182 :         actual->spec_type = SPEC_EXPLICIT;
    1727                 :             :     }
    1728                 :             : 
    1729                 :      128643 :   m = match_actual_arg (&actual->expr);
    1730                 :      128643 :   if (m != MATCH_YES)
    1731                 :       10233 :     goto cleanup;
    1732                 :             : 
    1733                 :             :   /* Make sure this name has not appeared yet.  */
    1734                 :      118410 : add_name:
    1735                 :      118442 :   if (name[0] != '\0')
    1736                 :             :     {
    1737                 :      364998 :       for (a = base; a; a = a->next)
    1738                 :      246566 :         if (a->name != NULL && strcmp (a->name, name) == 0)
    1739                 :             :           {
    1740                 :          10 :             gfc_error ("Keyword %qs at %C has already appeared in the "
    1741                 :             :                        "current argument list", name);
    1742                 :          10 :             return MATCH_ERROR;
    1743                 :             :           }
    1744                 :             :     }
    1745                 :             : 
    1746                 :      118432 :   actual->name = gfc_get_string ("%s", name);
    1747                 :      118432 :   return MATCH_YES;
    1748                 :             : 
    1749                 :     1618542 : cleanup:
    1750                 :     1618542 :   gfc_current_locus = name_locus;
    1751                 :     1618542 :   return m;
    1752                 :             : }
    1753                 :             : 
    1754                 :             : 
    1755                 :             : /* Match an argument list function, such as %VAL.  */
    1756                 :             : 
    1757                 :             : static match
    1758                 :     1707698 : match_arg_list_function (gfc_actual_arglist *result)
    1759                 :             : {
    1760                 :     1707698 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1761                 :     1707698 :   locus old_locus;
    1762                 :     1707698 :   match m;
    1763                 :             : 
    1764                 :     1707698 :   old_locus = gfc_current_locus;
    1765                 :             : 
    1766                 :     1707698 :   if (gfc_match_char ('%') != MATCH_YES)
    1767                 :             :     {
    1768                 :     1707453 :       m = MATCH_NO;
    1769                 :     1707453 :       goto cleanup;
    1770                 :             :     }
    1771                 :             : 
    1772                 :         245 :   m = gfc_match ("%n (", name);
    1773                 :         245 :   if (m != MATCH_YES)
    1774                 :           0 :     goto cleanup;
    1775                 :             : 
    1776                 :         245 :   if (name[0] != '\0')
    1777                 :             :     {
    1778                 :         245 :       switch (name[0])
    1779                 :             :         {
    1780                 :          76 :         case 'l':
    1781                 :          76 :           if (startswith (name, "loc"))
    1782                 :             :             {
    1783                 :          76 :               result->name = "%LOC";
    1784                 :          76 :               break;
    1785                 :             :             }
    1786                 :             :           /* FALLTHRU */
    1787                 :          72 :         case 'r':
    1788                 :          72 :           if (startswith (name, "ref"))
    1789                 :             :             {
    1790                 :          72 :               result->name = "%REF";
    1791                 :          72 :               break;
    1792                 :             :             }
    1793                 :             :           /* FALLTHRU */
    1794                 :          97 :         case 'v':
    1795                 :          97 :           if (startswith (name, "val"))
    1796                 :             :             {
    1797                 :          97 :               result->name = "%VAL";
    1798                 :          97 :               break;
    1799                 :             :             }
    1800                 :             :           /* FALLTHRU */
    1801                 :           0 :         default:
    1802                 :           0 :           m = MATCH_ERROR;
    1803                 :           0 :           goto cleanup;
    1804                 :             :         }
    1805                 :             :     }
    1806                 :             : 
    1807                 :         245 :   if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
    1808                 :             :     {
    1809                 :           1 :       m = MATCH_ERROR;
    1810                 :           1 :       goto cleanup;
    1811                 :             :     }
    1812                 :             : 
    1813                 :         244 :   m = match_actual_arg (&result->expr);
    1814                 :         244 :   if (m != MATCH_YES)
    1815                 :           0 :     goto cleanup;
    1816                 :             : 
    1817                 :         244 :   if (gfc_match_char (')') != MATCH_YES)
    1818                 :             :     {
    1819                 :           0 :       m = MATCH_NO;
    1820                 :           0 :       goto cleanup;
    1821                 :             :     }
    1822                 :             : 
    1823                 :             :   return MATCH_YES;
    1824                 :             : 
    1825                 :     1707454 : cleanup:
    1826                 :     1707454 :   gfc_current_locus = old_locus;
    1827                 :     1707454 :   return m;
    1828                 :             : }
    1829                 :             : 
    1830                 :             : 
    1831                 :             : /* Matches an actual argument list of a function or subroutine, from
    1832                 :             :    the opening parenthesis to the closing parenthesis.  The argument
    1833                 :             :    list is assumed to allow keyword arguments because we don't know if
    1834                 :             :    the symbol associated with the procedure has an implicit interface
    1835                 :             :    or not.  We make sure keywords are unique. If sub_flag is set,
    1836                 :             :    we're matching the argument list of a subroutine.
    1837                 :             : 
    1838                 :             :    NOTE: An alternative use for this function is to match type parameter
    1839                 :             :    spec lists, which are so similar to actual argument lists that the
    1840                 :             :    machinery can be reused. This use is flagged by the optional argument
    1841                 :             :    'pdt'.  */
    1842                 :             : 
    1843                 :             : match
    1844                 :     1821103 : gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
    1845                 :             : {
    1846                 :     1821103 :   gfc_actual_arglist *head, *tail;
    1847                 :     1821103 :   int seen_keyword;
    1848                 :     1821103 :   gfc_st_label *label;
    1849                 :     1821103 :   locus old_loc;
    1850                 :     1821103 :   match m;
    1851                 :             : 
    1852                 :     1821103 :   *argp = tail = NULL;
    1853                 :     1821103 :   old_loc = gfc_current_locus;
    1854                 :             : 
    1855                 :     1821103 :   seen_keyword = 0;
    1856                 :             : 
    1857                 :     1821103 :   if (gfc_match_char ('(') == MATCH_NO)
    1858                 :     1084501 :     return (sub_flag) ? MATCH_YES : MATCH_NO;
    1859                 :             : 
    1860                 :     1264182 :   if (gfc_match_char (')') == MATCH_YES)
    1861                 :             :     return MATCH_YES;
    1862                 :             : 
    1863                 :     1241122 :   head = NULL;
    1864                 :             : 
    1865                 :     1241122 :   matching_actual_arglist++;
    1866                 :             : 
    1867                 :     1737148 :   for (;;)
    1868                 :             :     {
    1869                 :     1737148 :       if (head == NULL)
    1870                 :     1241122 :         head = tail = gfc_get_actual_arglist ();
    1871                 :             :       else
    1872                 :             :         {
    1873                 :      496026 :           tail->next = gfc_get_actual_arglist ();
    1874                 :      496026 :           tail = tail->next;
    1875                 :             :         }
    1876                 :             : 
    1877                 :     1737148 :       if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
    1878                 :             :         {
    1879                 :         238 :           m = gfc_match_st_label (&label);
    1880                 :         238 :           if (m == MATCH_NO)
    1881                 :           0 :             gfc_error ("Expected alternate return label at %C");
    1882                 :         238 :           if (m != MATCH_YES)
    1883                 :           0 :             goto cleanup;
    1884                 :             : 
    1885                 :         238 :           if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
    1886                 :             :                                "at %C"))
    1887                 :           0 :             goto cleanup;
    1888                 :             : 
    1889                 :         238 :           tail->label = label;
    1890                 :         238 :           goto next;
    1891                 :             :         }
    1892                 :             : 
    1893                 :     1736910 :       if (pdt && !seen_keyword)
    1894                 :             :         {
    1895                 :         822 :           if (gfc_match_char (':') == MATCH_YES)
    1896                 :             :             {
    1897                 :          55 :               tail->spec_type = SPEC_DEFERRED;
    1898                 :          55 :               goto next;
    1899                 :             :             }
    1900                 :         767 :           else if (gfc_match_char ('*') == MATCH_YES)
    1901                 :             :             {
    1902                 :          98 :               tail->spec_type = SPEC_ASSUMED;
    1903                 :          98 :               goto next;
    1904                 :             :             }
    1905                 :             :           else
    1906                 :         669 :             tail->spec_type = SPEC_EXPLICIT;
    1907                 :             : 
    1908                 :         669 :           m = match_keyword_arg (tail, head, pdt);
    1909                 :         669 :           if (m == MATCH_YES)
    1910                 :             :             {
    1911                 :         197 :               seen_keyword = 1;
    1912                 :         197 :               goto next;
    1913                 :             :             }
    1914                 :         472 :           if (m == MATCH_ERROR)
    1915                 :           0 :             goto cleanup;
    1916                 :             :         }
    1917                 :             : 
    1918                 :             :       /* After the first keyword argument is seen, the following
    1919                 :             :          arguments must also have keywords.  */
    1920                 :     1736560 :       if (seen_keyword)
    1921                 :             :         {
    1922                 :       28862 :           m = match_keyword_arg (tail, head, pdt);
    1923                 :             : 
    1924                 :       28862 :           if (m == MATCH_ERROR)
    1925                 :          29 :             goto cleanup;
    1926                 :       28833 :           if (m == MATCH_NO)
    1927                 :             :             {
    1928                 :        1191 :               gfc_error ("Missing keyword name in actual argument list at %C");
    1929                 :        1191 :               goto cleanup;
    1930                 :             :             }
    1931                 :             : 
    1932                 :             :         }
    1933                 :             :       else
    1934                 :             :         {
    1935                 :             :           /* Try an argument list function, like %VAL.  */
    1936                 :     1707698 :           m = match_arg_list_function (tail);
    1937                 :     1707698 :           if (m == MATCH_ERROR)
    1938                 :           1 :             goto cleanup;
    1939                 :             : 
    1940                 :             :           /* See if we have the first keyword argument.  */
    1941                 :     1707697 :           if (m == MATCH_NO)
    1942                 :             :             {
    1943                 :     1707453 :               m = match_keyword_arg (tail, head, false);
    1944                 :     1707453 :               if (m == MATCH_YES)
    1945                 :             :                 seen_keyword = 1;
    1946                 :     1616860 :               if (m == MATCH_ERROR)
    1947                 :         696 :                 goto cleanup;
    1948                 :             :             }
    1949                 :             : 
    1950                 :     1706757 :           if (m == MATCH_NO)
    1951                 :             :             {
    1952                 :             :               /* Try for a non-keyword argument.  */
    1953                 :     1616164 :               m = match_actual_arg (&tail->expr);
    1954                 :     1616164 :               if (m == MATCH_ERROR)
    1955                 :        1747 :                 goto cleanup;
    1956                 :     1614417 :               if (m == MATCH_NO)
    1957                 :       17382 :                 goto syntax;
    1958                 :             :             }
    1959                 :             :         }
    1960                 :             : 
    1961                 :             : 
    1962                 :       90593 :     next:
    1963                 :     1716102 :       if (gfc_match_char (')') == MATCH_YES)
    1964                 :             :         break;
    1965                 :      503842 :       if (gfc_match_char (',') != MATCH_YES)
    1966                 :        7816 :         goto syntax;
    1967                 :             :     }
    1968                 :             : 
    1969                 :     1212260 :   *argp = head;
    1970                 :     1212260 :   matching_actual_arglist--;
    1971                 :     1212260 :   return MATCH_YES;
    1972                 :             : 
    1973                 :       25198 : syntax:
    1974                 :       25198 :   gfc_error ("Syntax error in argument list at %C");
    1975                 :             : 
    1976                 :       28862 : cleanup:
    1977                 :       28862 :   gfc_free_actual_arglist (head);
    1978                 :       28862 :   gfc_current_locus = old_loc;
    1979                 :       28862 :   matching_actual_arglist--;
    1980                 :       28862 :   return MATCH_ERROR;
    1981                 :             : }
    1982                 :             : 
    1983                 :             : 
    1984                 :             : /* Used by gfc_match_varspec() to extend the reference list by one
    1985                 :             :    element.  */
    1986                 :             : 
    1987                 :             : static gfc_ref *
    1988                 :      620656 : extend_ref (gfc_expr *primary, gfc_ref *tail)
    1989                 :             : {
    1990                 :      620656 :   if (primary->ref == NULL)
    1991                 :      570051 :     primary->ref = tail = gfc_get_ref ();
    1992                 :             :   else
    1993                 :             :     {
    1994                 :       50605 :       if (tail == NULL)
    1995                 :           0 :         gfc_internal_error ("extend_ref(): Bad tail");
    1996                 :       50605 :       tail->next = gfc_get_ref ();
    1997                 :       50605 :       tail = tail->next;
    1998                 :             :     }
    1999                 :             : 
    2000                 :      620656 :   return tail;
    2001                 :             : }
    2002                 :             : 
    2003                 :             : 
    2004                 :             : /* Used by gfc_match_varspec() to match an inquiry reference.  */
    2005                 :             : 
    2006                 :             : bool
    2007                 :        3349 : is_inquiry_ref (const char *name, gfc_ref **ref)
    2008                 :             : {
    2009                 :        3349 :   inquiry_type type;
    2010                 :             : 
    2011                 :        3349 :   if (name == NULL)
    2012                 :             :     return false;
    2013                 :             : 
    2014                 :        3349 :   if (ref) *ref = NULL;
    2015                 :             : 
    2016                 :        3349 :   if (strcmp (name, "re") == 0)
    2017                 :             :     type = INQUIRY_RE;
    2018                 :        2517 :   else if (strcmp (name, "im") == 0)
    2019                 :             :     type = INQUIRY_IM;
    2020                 :        1780 :   else if (strcmp (name, "kind") == 0)
    2021                 :             :     type = INQUIRY_KIND;
    2022                 :        1320 :   else if (strcmp (name, "len") == 0)
    2023                 :             :     type = INQUIRY_LEN;
    2024                 :             :   else
    2025                 :             :     return false;
    2026                 :             : 
    2027                 :        2457 :   if (ref)
    2028                 :             :     {
    2029                 :        1371 :       *ref = gfc_get_ref ();
    2030                 :        1371 :       (*ref)->type = REF_INQUIRY;
    2031                 :        1371 :       (*ref)->u.i = type;
    2032                 :             :     }
    2033                 :             : 
    2034                 :             :   return true;
    2035                 :             : }
    2036                 :             : 
    2037                 :             : 
    2038                 :             : /* Check to see if functions in operator expressions can be resolved now.  */
    2039                 :             : 
    2040                 :             : static bool
    2041                 :         198 : resolvable_fcns (gfc_expr *e,
    2042                 :             :                   gfc_symbol *sym ATTRIBUTE_UNUSED,
    2043                 :             :                   int *f ATTRIBUTE_UNUSED)
    2044                 :             : {
    2045                 :         198 :   bool p;
    2046                 :         198 :   gfc_symbol *s;
    2047                 :             : 
    2048                 :         198 :   if (e->expr_type != EXPR_FUNCTION)
    2049                 :             :     return false;
    2050                 :             : 
    2051                 :          72 :   s = e && e->symtree && e->symtree->n.sym ? e->symtree->n.sym : NULL;
    2052                 :         144 :   p = s && (s->attr.use_assoc
    2053                 :          72 :             || s->attr.host_assoc
    2054                 :          54 :             || s->attr.if_source == IFSRC_DECL
    2055                 :          54 :             || s->attr.proc == PROC_INTRINSIC
    2056                 :          24 :             || gfc_is_intrinsic (s, 0, e->where));
    2057                 :          72 :   return !p;
    2058                 :             : }
    2059                 :             : 
    2060                 :             : 
    2061                 :             : /* Match any additional specifications associated with the current
    2062                 :             :    variable like member references or substrings.  If equiv_flag is
    2063                 :             :    set we only match stuff that is allowed inside an EQUIVALENCE
    2064                 :             :    statement.  sub_flag tells whether we expect a type-bound procedure found
    2065                 :             :    to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
    2066                 :             :    components, 'ppc_arg' determines whether the PPC may be called (with an
    2067                 :             :    argument list), or whether it may just be referred to as a pointer.  */
    2068                 :             : 
    2069                 :             : match
    2070                 :     3997443 : gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
    2071                 :             :                    bool ppc_arg)
    2072                 :             : {
    2073                 :     3997443 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    2074                 :     3997443 :   gfc_ref *substring, *tail, *tmp;
    2075                 :     3997443 :   gfc_component *component = NULL;
    2076                 :     3997443 :   gfc_component *previous = NULL;
    2077                 :     3997443 :   gfc_symbol *sym = primary->symtree->n.sym;
    2078                 :     3997443 :   gfc_expr *tgt_expr = NULL;
    2079                 :     3997443 :   match m;
    2080                 :     3997443 :   bool unknown;
    2081                 :     3997443 :   bool inquiry;
    2082                 :     3997443 :   bool intrinsic;
    2083                 :     3997443 :   bool inferred_type;
    2084                 :     3997443 :   locus old_loc;
    2085                 :     3997443 :   char sep;
    2086                 :             : 
    2087                 :     3997443 :   tail = NULL;
    2088                 :             : 
    2089                 :     3997443 :   gfc_gobble_whitespace ();
    2090                 :             : 
    2091                 :     3997443 :   if (gfc_peek_ascii_char () == '[')
    2092                 :             :     {
    2093                 :        2655 :       if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
    2094                 :        2655 :           || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    2095                 :          81 :               && CLASS_DATA (sym)->attr.dimension))
    2096                 :             :         {
    2097                 :           0 :           gfc_error ("Array section designator, e.g. %<(:)%>, is required "
    2098                 :             :                      "besides the coarray designator %<[...]%> at %C");
    2099                 :           0 :           return MATCH_ERROR;
    2100                 :             :         }
    2101                 :        2655 :       if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
    2102                 :        2654 :           || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    2103                 :          81 :               && !CLASS_DATA (sym)->attr.codimension))
    2104                 :             :         {
    2105                 :           1 :           gfc_error ("Coarray designator at %C but %qs is not a coarray",
    2106                 :             :                      sym->name);
    2107                 :           1 :           return MATCH_ERROR;
    2108                 :             :         }
    2109                 :             :     }
    2110                 :             : 
    2111                 :     3997442 :   if (sym->assoc && sym->assoc->target)
    2112                 :     3997442 :     tgt_expr = sym->assoc->target;
    2113                 :             : 
    2114                 :     3997442 :   inferred_type = IS_INFERRED_TYPE (primary);
    2115                 :             : 
    2116                 :             :   /* SELECT TYPE temporaries within an ASSOCIATE block, whose selector has not
    2117                 :             :      been parsed, can generate errors with array refs.. The SELECT TYPE
    2118                 :             :      namespace is marked with 'assoc_name_inferred'. During resolution, this is
    2119                 :             :      detected and gfc_fixup_inferred_type_refs is called.  */
    2120                 :     3996616 :   if (!inferred_type
    2121                 :     3996616 :       && sym->attr.select_type_temporary
    2122                 :       22253 :       && sym->ns->assoc_name_inferred
    2123                 :         344 :       && !sym->attr.select_rank_temporary)
    2124                 :        1170 :     inferred_type = true;
    2125                 :             : 
    2126                 :             :   /* For associate names, we may not yet know whether they are arrays or not.
    2127                 :             :      If the selector expression is unambiguously an array; eg. a full array
    2128                 :             :      or an array section, then the associate name must be an array and we can
    2129                 :             :      fix it now. Otherwise, if parentheses follow and it is not a character
    2130                 :             :      type, we have to assume that it actually is one for now.  The final
    2131                 :             :      decision will be made at resolution, of course.  */
    2132                 :     3997442 :   if (sym->assoc
    2133                 :       27392 :       && gfc_peek_ascii_char () == '('
    2134                 :        9228 :       && sym->ts.type != BT_CLASS
    2135                 :     4006535 :       && !sym->attr.dimension)
    2136                 :             :     {
    2137                 :         358 :       gfc_ref *ref = NULL;
    2138                 :             : 
    2139                 :         358 :       if (!sym->assoc->dangling && tgt_expr)
    2140                 :             :         {
    2141                 :         298 :            if (tgt_expr->expr_type == EXPR_VARIABLE)
    2142                 :          21 :              gfc_resolve_expr (tgt_expr);
    2143                 :             : 
    2144                 :         298 :            ref = tgt_expr->ref;
    2145                 :         312 :            for (; ref; ref = ref->next)
    2146                 :          14 :               if (ref->type == REF_ARRAY
    2147                 :           7 :                   && (ref->u.ar.type == AR_FULL
    2148                 :           7 :                       || ref->u.ar.type == AR_SECTION))
    2149                 :             :                 break;
    2150                 :             :         }
    2151                 :             : 
    2152                 :         358 :       if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
    2153                 :         232 :                   && sym->assoc->st
    2154                 :         232 :                   && sym->assoc->st->n.sym
    2155                 :         232 :                   && sym->assoc->st->n.sym->attr.dimension == 0))
    2156                 :             :         {
    2157                 :         232 :           sym->attr.dimension = 1;
    2158                 :         232 :           if (sym->as == NULL
    2159                 :         232 :               && sym->assoc->st
    2160                 :         232 :               && sym->assoc->st->n.sym
    2161                 :         232 :               && sym->assoc->st->n.sym->as)
    2162                 :           0 :             sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
    2163                 :             :         }
    2164                 :             :     }
    2165                 :     3997084 :   else if (sym->ts.type == BT_CLASS
    2166                 :       40210 :            && tgt_expr
    2167                 :         252 :            && tgt_expr->expr_type == EXPR_VARIABLE
    2168                 :         126 :            && sym->ts.u.derived != tgt_expr->ts.u.derived)
    2169                 :             :     {
    2170                 :          19 :       gfc_resolve_expr (tgt_expr);
    2171                 :          19 :       if (tgt_expr->rank)
    2172                 :           0 :         sym->ts.u.derived = tgt_expr->ts.u.derived;
    2173                 :             :     }
    2174                 :             : 
    2175                 :        1170 :   if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
    2176                 :     3997228 :       || (equiv_flag && gfc_peek_ascii_char () == '(')
    2177                 :     3995647 :       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
    2178                 :     3979537 :       || (sym->attr.dimension && sym->ts.type != BT_CLASS
    2179                 :      536958 :           && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
    2180                 :      536943 :           && !(gfc_matching_procptr_assignment
    2181                 :          32 :                && sym->attr.flavor == FL_PROCEDURE))
    2182                 :     7440056 :       || (sym->ts.type == BT_CLASS && sym->attr.class_ok
    2183                 :       40081 :           && sym->ts.u.derived && CLASS_DATA (sym)
    2184                 :       40077 :           && (CLASS_DATA (sym)->attr.dimension
    2185                 :       40077 :               || CLASS_DATA (sym)->attr.codimension)))
    2186                 :             :     {
    2187                 :      570051 :       gfc_array_spec *as;
    2188                 :             : 
    2189                 :      570051 :       tail = extend_ref (primary, tail);
    2190                 :      570051 :       tail->type = REF_ARRAY;
    2191                 :             : 
    2192                 :             :       /* In EQUIVALENCE, we don't know yet whether we are seeing
    2193                 :             :          an array, character variable or array of character
    2194                 :             :          variables.  We'll leave the decision till resolve time.  */
    2195                 :             : 
    2196                 :      570051 :       if (equiv_flag)
    2197                 :             :         as = NULL;
    2198                 :      568035 :       else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
    2199                 :       15305 :         as = CLASS_DATA (sym)->as;
    2200                 :             :       else
    2201                 :      552730 :         as = sym->as;
    2202                 :             : 
    2203                 :      570051 :       m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
    2204                 :             :                                as ? as->corank : 0);
    2205                 :      570051 :       if (m != MATCH_YES)
    2206                 :             :         return m;
    2207                 :             : 
    2208                 :      570002 :       gfc_gobble_whitespace ();
    2209                 :      570002 :       if (equiv_flag && gfc_peek_ascii_char () == '(')
    2210                 :             :         {
    2211                 :          74 :           tail = extend_ref (primary, tail);
    2212                 :          74 :           tail->type = REF_ARRAY;
    2213                 :             : 
    2214                 :          74 :           m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
    2215                 :          74 :           if (m != MATCH_YES)
    2216                 :             :             return m;
    2217                 :             :         }
    2218                 :             :     }
    2219                 :             : 
    2220                 :     3997393 :   primary->ts = sym->ts;
    2221                 :             : 
    2222                 :     3997393 :   if (equiv_flag)
    2223                 :             :     return MATCH_YES;
    2224                 :             : 
    2225                 :             :   /* With DEC extensions, member separator may be '.' or '%'.  */
    2226                 :     3994419 :   sep = gfc_peek_ascii_char ();
    2227                 :     3994419 :   m = gfc_match_member_sep (sym);
    2228                 :     3994419 :   if (m == MATCH_ERROR)
    2229                 :             :     return MATCH_ERROR;
    2230                 :             : 
    2231                 :     3994418 :   inquiry = false;
    2232                 :     3994418 :   if (m == MATCH_YES && sep == '%'
    2233                 :      127622 :       && primary->ts.type != BT_CLASS
    2234                 :      111800 :       && (primary->ts.type != BT_DERIVED || inferred_type))
    2235                 :             :     {
    2236                 :        1974 :       match mm;
    2237                 :        1974 :       old_loc = gfc_current_locus;
    2238                 :        1974 :       mm = gfc_match_name (name);
    2239                 :             : 
    2240                 :             :       /* Check to see if this has a default complex.  */
    2241                 :         466 :       if (sym->ts.type == BT_UNKNOWN && tgt_expr == NULL
    2242                 :        1992 :           && gfc_get_default_type (sym->name, sym->ns)->type != BT_UNKNOWN)
    2243                 :             :         {
    2244                 :           6 :           gfc_set_default_type (sym, 0, sym->ns);
    2245                 :           6 :           primary->ts = sym->ts;
    2246                 :             :         }
    2247                 :             : 
    2248                 :             :       /* This is a usable inquiry reference, if the symbol is already known
    2249                 :             :          to have a type or no derived types with a component of this name
    2250                 :             :          can be found.  If this was an inquiry reference with the same name
    2251                 :             :          as a derived component and the associate-name type is not derived
    2252                 :             :          or class, this is fixed up in 'gfc_fixup_inferred_type_refs'.  */
    2253                 :        1974 :       if (mm == MATCH_YES && is_inquiry_ref (name, NULL)
    2254                 :        3270 :           && !(sym->ts.type == BT_UNKNOWN
    2255                 :         210 :                 && gfc_find_derived_types (sym, gfc_current_ns, name)))
    2256                 :             :         inquiry = true;
    2257                 :        1974 :       gfc_current_locus = old_loc;
    2258                 :             :     }
    2259                 :             : 
    2260                 :             :   /* Use the default type if there is one.  */
    2261                 :     2321412 :   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
    2262                 :     3994878 :       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
    2263                 :           0 :     gfc_set_default_type (sym, 0, sym->ns);
    2264                 :             : 
    2265                 :             :   /* See if the type can be determined by resolution of the selector expression,
    2266                 :             :      if allowable now, or inferred from references.  */
    2267                 :     3994418 :   if ((sym->ts.type == BT_UNKNOWN || inferred_type)
    2268                 :     2322327 :       && m == MATCH_YES)
    2269                 :             :     {
    2270                 :        1212 :       bool sym_present, resolved = false;
    2271                 :        1212 :       gfc_symbol *tgt_sym;
    2272                 :             : 
    2273                 :        1212 :       sym_present = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym;
    2274                 :        1212 :       tgt_sym = sym_present ? tgt_expr->symtree->n.sym : NULL;
    2275                 :             : 
    2276                 :             :       /* These target expressions can be resolved at any time:
    2277                 :             :          (i) With a declared symbol or intrinsic function; or
    2278                 :             :          (ii) An operator expression,
    2279                 :             :          just as long as (iii) all the functions in the expression have been
    2280                 :             :          declared or are intrinsic.  */
    2281                 :        1212 :       if (((sym_present                                               // (i)
    2282                 :         838 :             && (tgt_sym->attr.use_assoc
    2283                 :         838 :                 || tgt_sym->attr.host_assoc
    2284                 :         820 :                 || tgt_sym->attr.if_source == IFSRC_DECL
    2285                 :         820 :                 || tgt_sym->attr.proc == PROC_INTRINSIC
    2286                 :         820 :                 || gfc_is_intrinsic (tgt_sym, 0, tgt_expr->where)))
    2287                 :        1182 :            || (tgt_expr && tgt_expr->expr_type == EXPR_OP))        // (ii)
    2288                 :          48 :           && !gfc_traverse_expr (tgt_expr, NULL, resolvable_fcns, 0)  // (iii)
    2289                 :          42 :           && gfc_resolve_expr (tgt_expr))
    2290                 :             :         {
    2291                 :          42 :           sym->ts = tgt_expr->ts;
    2292                 :          42 :           primary->ts = sym->ts;
    2293                 :          42 :           resolved = true;
    2294                 :             :         }
    2295                 :             : 
    2296                 :             :       /* If this hasn't done the trick and the target expression is a function,
    2297                 :             :          or an unresolved operator expression, then this must be a derived type
    2298                 :             :          if 'name' matches an accessible type both in this namespace and in the
    2299                 :             :          as yet unparsed contained function. In principle, the type could have
    2300                 :             :          already been inferred to be complex and yet a derived type with a
    2301                 :             :          component name 're' or 'im' could be found.  */
    2302                 :          42 :       if (tgt_expr
    2303                 :         856 :           && (tgt_expr->expr_type == EXPR_FUNCTION
    2304                 :          72 :               || (!resolved && tgt_expr->expr_type == EXPR_OP))
    2305                 :         790 :           && (sym->ts.type == BT_UNKNOWN
    2306                 :         384 :               || (inferred_type && sym->ts.type != BT_COMPLEX))
    2307                 :        1888 :           && gfc_find_derived_types (sym, gfc_current_ns, name, true))
    2308                 :             :         {
    2309                 :         526 :           sym->assoc->inferred_type = 1;
    2310                 :             :           /* The first returned type is as good as any at this stage. The final
    2311                 :             :              determination is made in 'gfc_fixup_inferred_type_refs'*/
    2312                 :         526 :           gfc_symbol **dts = &sym->assoc->derived_types;
    2313                 :         526 :           tgt_expr->ts.type = BT_DERIVED;
    2314                 :         526 :           tgt_expr->ts.kind = 0;
    2315                 :         526 :           tgt_expr->ts.u.derived = *dts;
    2316                 :         526 :           sym->ts = tgt_expr->ts;
    2317                 :         526 :           primary->ts = sym->ts;
    2318                 :             :           /* Delete the dt list even if this process has to be done again for
    2319                 :             :              another primary expression.  */
    2320                 :        1094 :           while (*dts && (*dts)->dt_next)
    2321                 :             :             {
    2322                 :         568 :               gfc_symbol **tmp = &(*dts)->dt_next;
    2323                 :         568 :               *dts = NULL;
    2324                 :         568 :               dts = tmp;
    2325                 :             :             }
    2326                 :             :         }
    2327                 :             :       /* If there is a usable inquiry reference not there are no matching
    2328                 :             :          derived types, force the inquiry reference by setting unknown the
    2329                 :             :          type of the primary expression.  */
    2330                 :         258 :       else if (inquiry && (sym->ts.type == BT_DERIVED && inferred_type)
    2331                 :         734 :                && !gfc_find_derived_types (sym, gfc_current_ns, name))
    2332                 :          48 :         primary->ts.type = BT_UNKNOWN;
    2333                 :             : 
    2334                 :             :       /* An inquiry reference might determine the type, otherwise we have an
    2335                 :             :          error.  */
    2336                 :        1212 :       if (sym->ts.type == BT_UNKNOWN && !inquiry)
    2337                 :             :         {
    2338                 :          12 :           gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
    2339                 :          12 :           return MATCH_ERROR;
    2340                 :             :         }
    2341                 :             :     }
    2342                 :     3993206 :   else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
    2343                 :     3792804 :            && m == MATCH_YES && !inquiry)
    2344                 :             :     {
    2345                 :           6 :       gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
    2346                 :             :                  sep, sym->name);
    2347                 :           6 :       return MATCH_ERROR;
    2348                 :             :     }
    2349                 :             : 
    2350                 :     3994400 :   if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
    2351                 :      202358 :       || m != MATCH_YES)
    2352                 :     3864710 :     goto check_substring;
    2353                 :             : 
    2354                 :      129690 :   if (!inquiry)
    2355                 :      128676 :     sym = sym->ts.u.derived;
    2356                 :             :   else
    2357                 :             :     sym = NULL;
    2358                 :             : 
    2359                 :      146728 :   for (;;)
    2360                 :             :     {
    2361                 :      146728 :       bool t;
    2362                 :      146728 :       gfc_symtree *tbp;
    2363                 :             : 
    2364                 :      146728 :       m = gfc_match_name (name);
    2365                 :      146728 :       if (m == MATCH_NO)
    2366                 :           0 :         gfc_error ("Expected structure component name at %C");
    2367                 :      146728 :       if (m != MATCH_YES)
    2368                 :         131 :         return MATCH_ERROR;
    2369                 :             : 
    2370                 :      146728 :       intrinsic = false;
    2371                 :      146728 :       if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
    2372                 :             :         {
    2373                 :        1363 :           inquiry = is_inquiry_ref (name, &tmp);
    2374                 :        1363 :           if (inquiry)
    2375                 :        1359 :             sym = NULL;
    2376                 :             : 
    2377                 :        1363 :           if (sep == '%')
    2378                 :             :             {
    2379                 :        1363 :               if (tmp)
    2380                 :             :                 {
    2381                 :        1359 :                   gfc_symbol *s;
    2382                 :        1359 :                   switch (tmp->u.i)
    2383                 :             :                     {
    2384                 :         862 :                     case INQUIRY_RE:
    2385                 :         862 :                     case INQUIRY_IM:
    2386                 :         862 :                       if (!gfc_notify_std (GFC_STD_F2008,
    2387                 :             :                                            "RE or IM part_ref at %C"))
    2388                 :             :                         return MATCH_ERROR;
    2389                 :             :                       break;
    2390                 :             : 
    2391                 :         250 :                     case INQUIRY_KIND:
    2392                 :         250 :                       if (!gfc_notify_std (GFC_STD_F2003,
    2393                 :             :                                            "KIND part_ref at %C"))
    2394                 :             :                         return MATCH_ERROR;
    2395                 :             :                       break;
    2396                 :             : 
    2397                 :         247 :                     case INQUIRY_LEN:
    2398                 :         247 :                       if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
    2399                 :             :                         return MATCH_ERROR;
    2400                 :             :                       break;
    2401                 :             :                     }
    2402                 :             : 
    2403                 :             :                   /* If necessary, infer the type of the primary expression
    2404                 :             :                      and the associate-name using the the inquiry ref..  */
    2405                 :        1350 :                   s = primary->symtree ? primary->symtree->n.sym : NULL;
    2406                 :        1346 :                   if (s && s->assoc && s->assoc->target
    2407                 :         258 :                       && (s->ts.type == BT_UNKNOWN
    2408                 :         138 :                           || (primary->ts.type == BT_UNKNOWN
    2409                 :          48 :                               && s->assoc->inferred_type
    2410                 :          48 :                               && s->ts.type == BT_DERIVED)))
    2411                 :             :                     {
    2412                 :         168 :                       if (tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
    2413                 :             :                         {
    2414                 :          72 :                           s->ts.type = BT_COMPLEX;
    2415                 :          72 :                           s->ts.kind = gfc_default_real_kind;;
    2416                 :          72 :                           s->assoc->inferred_type = 1;
    2417                 :          72 :                           primary->ts = s->ts;
    2418                 :             :                         }
    2419                 :          96 :                       else if (tmp->u.i == INQUIRY_LEN)
    2420                 :             :                         {
    2421                 :          48 :                           s->ts.type = BT_CHARACTER;
    2422                 :          48 :                           s->ts.kind = gfc_default_character_kind;;
    2423                 :          48 :                           s->assoc->inferred_type = 1;
    2424                 :          48 :                           primary->ts = s->ts;
    2425                 :             :                         }
    2426                 :          48 :                       else if (s->ts.type == BT_UNKNOWN)
    2427                 :             :                         {
    2428                 :             :                           /* KIND inquiry gives no clue as to symbol type.  */
    2429                 :          48 :                           primary->ref = tmp;
    2430                 :          48 :                           primary->ts.type = BT_INTEGER;
    2431                 :          48 :                           primary->ts.kind = gfc_default_integer_kind;
    2432                 :          48 :                           return MATCH_YES;
    2433                 :             :                         }
    2434                 :             :                     }
    2435                 :             : 
    2436                 :        1302 :                   if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
    2437                 :         858 :                       && primary->ts.type != BT_COMPLEX)
    2438                 :             :                     {
    2439                 :          12 :                         gfc_error ("The RE or IM part_ref at %C must be "
    2440                 :             :                                    "applied to a COMPLEX expression");
    2441                 :          12 :                         return MATCH_ERROR;
    2442                 :             :                     }
    2443                 :        1290 :                   else if (tmp->u.i == INQUIRY_LEN
    2444                 :         245 :                            && primary->ts.type != BT_CHARACTER)
    2445                 :             :                     {
    2446                 :           5 :                         gfc_error ("The LEN part_ref at %C must be applied "
    2447                 :             :                                    "to a CHARACTER expression");
    2448                 :           5 :                         return MATCH_ERROR;
    2449                 :             :                     }
    2450                 :             :                 }
    2451                 :        1289 :               if (primary->ts.type != BT_UNKNOWN)
    2452                 :      146654 :                 intrinsic = true;
    2453                 :             :             }
    2454                 :             :         }
    2455                 :             :       else
    2456                 :             :         inquiry = false;
    2457                 :             : 
    2458                 :      146654 :       if (sym && sym->f2k_derived)
    2459                 :      142727 :         tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
    2460                 :             :       else
    2461                 :             :         tbp = NULL;
    2462                 :             : 
    2463                 :      142727 :       if (tbp)
    2464                 :             :         {
    2465                 :        3734 :           gfc_symbol* tbp_sym;
    2466                 :             : 
    2467                 :        3734 :           if (!t)
    2468                 :             :             return MATCH_ERROR;
    2469                 :             : 
    2470                 :        3732 :           gcc_assert (!tail || !tail->next);
    2471                 :             : 
    2472                 :        3732 :           if (!(primary->expr_type == EXPR_VARIABLE
    2473                 :             :                 || (primary->expr_type == EXPR_STRUCTURE
    2474                 :           1 :                     && primary->symtree && primary->symtree->n.sym
    2475                 :           1 :                     && primary->symtree->n.sym->attr.flavor)))
    2476                 :             :             return MATCH_ERROR;
    2477                 :             : 
    2478                 :        3730 :           if (tbp->n.tb->is_generic)
    2479                 :             :             tbp_sym = NULL;
    2480                 :             :           else
    2481                 :        3077 :             tbp_sym = tbp->n.tb->u.specific->n.sym;
    2482                 :             : 
    2483                 :        3730 :           primary->expr_type = EXPR_COMPCALL;
    2484                 :        3730 :           primary->value.compcall.tbp = tbp->n.tb;
    2485                 :        3730 :           primary->value.compcall.name = tbp->name;
    2486                 :        3730 :           primary->value.compcall.ignore_pass = 0;
    2487                 :        3730 :           primary->value.compcall.assign = 0;
    2488                 :        3730 :           primary->value.compcall.base_object = NULL;
    2489                 :        3730 :           gcc_assert (primary->symtree->n.sym->attr.referenced);
    2490                 :        3730 :           if (tbp_sym)
    2491                 :        3077 :             primary->ts = tbp_sym->ts;
    2492                 :             :           else
    2493                 :         653 :             gfc_clear_ts (&primary->ts);
    2494                 :             : 
    2495                 :        3730 :           m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
    2496                 :             :                                         &primary->value.compcall.actual);
    2497                 :        3730 :           if (m == MATCH_ERROR)
    2498                 :             :             return MATCH_ERROR;
    2499                 :        3730 :           if (m == MATCH_NO)
    2500                 :             :             {
    2501                 :         162 :               if (sub_flag)
    2502                 :         161 :                 primary->value.compcall.actual = NULL;
    2503                 :             :               else
    2504                 :             :                 {
    2505                 :           1 :                   gfc_error ("Expected argument list at %C");
    2506                 :           1 :                   return MATCH_ERROR;
    2507                 :             :                 }
    2508                 :             :             }
    2509                 :             : 
    2510                 :      129559 :           break;
    2511                 :             :         }
    2512                 :             : 
    2513                 :      142920 :       previous = component;
    2514                 :             : 
    2515                 :      142920 :       if (!inquiry && !intrinsic)
    2516                 :      141632 :         component = gfc_find_component (sym, name, false, false, &tmp);
    2517                 :             :       else
    2518                 :             :         component = NULL;
    2519                 :             : 
    2520                 :      142920 :       if (intrinsic && !inquiry)
    2521                 :             :         {
    2522                 :           3 :           if (previous)
    2523                 :           2 :             gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
    2524                 :             :                         "type component %qs", name, previous->name);
    2525                 :             :           else
    2526                 :           1 :             gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
    2527                 :             :                         "type component", name);
    2528                 :           3 :           return MATCH_ERROR;
    2529                 :             :         }
    2530                 :      142917 :       else if (component == NULL && !inquiry)
    2531                 :             :         return MATCH_ERROR;
    2532                 :             : 
    2533                 :             :       /* Extend the reference chain determined by gfc_find_component or
    2534                 :             :          is_inquiry_ref.  */
    2535                 :      142870 :       if (primary->ref == NULL)
    2536                 :       88578 :         primary->ref = tmp;
    2537                 :             :       else
    2538                 :             :         {
    2539                 :             :           /* Set by the for loop below for the last component ref.  */
    2540                 :       54292 :           gcc_assert (tail != NULL);
    2541                 :       54292 :           tail->next = tmp;
    2542                 :             :         }
    2543                 :             : 
    2544                 :             :       /* The reference chain may be longer than one hop for union
    2545                 :             :          subcomponents; find the new tail.  */
    2546                 :      144846 :       for (tail = tmp; tail->next; tail = tail->next)
    2547                 :             :         ;
    2548                 :             : 
    2549                 :      142870 :       if (tmp && tmp->type == REF_INQUIRY)
    2550                 :             :         {
    2551                 :        1285 :           if (!primary->where.lb || !primary->where.nextc)
    2552                 :         989 :             primary->where = gfc_current_locus;
    2553                 :        1285 :           gfc_simplify_expr (primary, 0);
    2554                 :             : 
    2555                 :        1285 :           if (primary->expr_type == EXPR_CONSTANT)
    2556                 :         312 :             goto check_done;
    2557                 :             : 
    2558                 :         973 :           switch (tmp->u.i)
    2559                 :             :             {
    2560                 :         762 :             case INQUIRY_RE:
    2561                 :         762 :             case INQUIRY_IM:
    2562                 :         762 :               if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
    2563                 :             :                 return MATCH_ERROR;
    2564                 :             : 
    2565                 :         762 :               if (primary->ts.type != BT_COMPLEX)
    2566                 :             :                 {
    2567                 :           0 :                   gfc_error ("The RE or IM part_ref at %C must be "
    2568                 :             :                              "applied to a COMPLEX expression");
    2569                 :           0 :                   return MATCH_ERROR;
    2570                 :             :                 }
    2571                 :         762 :               primary->ts.type = BT_REAL;
    2572                 :         762 :               break;
    2573                 :             : 
    2574                 :         159 :             case INQUIRY_LEN:
    2575                 :         159 :               if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
    2576                 :             :                 return MATCH_ERROR;
    2577                 :             : 
    2578                 :         159 :               if (primary->ts.type != BT_CHARACTER)
    2579                 :             :                 {
    2580                 :           0 :                   gfc_error ("The LEN part_ref at %C must be applied "
    2581                 :             :                              "to a CHARACTER expression");
    2582                 :           0 :                   return MATCH_ERROR;
    2583                 :             :                 }
    2584                 :         159 :               primary->ts.u.cl = NULL;
    2585                 :         159 :               primary->ts.type = BT_INTEGER;
    2586                 :         159 :               primary->ts.kind = gfc_default_integer_kind;
    2587                 :         159 :               break;
    2588                 :             : 
    2589                 :          52 :             case INQUIRY_KIND:
    2590                 :          52 :               if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
    2591                 :             :                 return MATCH_ERROR;
    2592                 :             : 
    2593                 :          52 :               if (primary->ts.type == BT_CLASS
    2594                 :          52 :                   || primary->ts.type == BT_DERIVED)
    2595                 :             :                 {
    2596                 :           0 :                   gfc_error ("The KIND part_ref at %C must be applied "
    2597                 :             :                              "to an expression of intrinsic type");
    2598                 :           0 :                   return MATCH_ERROR;
    2599                 :             :                 }
    2600                 :          52 :               primary->ts.type = BT_INTEGER;
    2601                 :          52 :               primary->ts.kind = gfc_default_integer_kind;
    2602                 :          52 :               break;
    2603                 :             : 
    2604                 :           0 :             default:
    2605                 :           0 :               gcc_unreachable ();
    2606                 :             :             }
    2607                 :             : 
    2608                 :         973 :           goto check_done;
    2609                 :             :         }
    2610                 :             : 
    2611                 :      141585 :       primary->ts = component->ts;
    2612                 :             : 
    2613                 :      141585 :       if (component->attr.proc_pointer && ppc_arg)
    2614                 :             :         {
    2615                 :             :           /* Procedure pointer component call: Look for argument list.  */
    2616                 :         819 :           m = gfc_match_actual_arglist (sub_flag,
    2617                 :             :                                         &primary->value.compcall.actual);
    2618                 :         819 :           if (m == MATCH_ERROR)
    2619                 :             :             return MATCH_ERROR;
    2620                 :             : 
    2621                 :         819 :           if (m == MATCH_NO && !gfc_matching_ptr_assignment
    2622                 :         247 :               && !gfc_matching_procptr_assignment && !matching_actual_arglist)
    2623                 :             :             {
    2624                 :           2 :               gfc_error ("Procedure pointer component %qs requires an "
    2625                 :             :                          "argument list at %C", component->name);
    2626                 :           2 :               return MATCH_ERROR;
    2627                 :             :             }
    2628                 :             : 
    2629                 :         817 :           if (m == MATCH_YES)
    2630                 :         571 :             primary->expr_type = EXPR_PPC;
    2631                 :             : 
    2632                 :             :           break;
    2633                 :             :         }
    2634                 :             : 
    2635                 :      140766 :       if (component->as != NULL && !component->attr.proc_pointer)
    2636                 :             :         {
    2637                 :       45988 :           tail = extend_ref (primary, tail);
    2638                 :       45988 :           tail->type = REF_ARRAY;
    2639                 :             : 
    2640                 :       91976 :           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
    2641                 :       45988 :                           component->as->corank);
    2642                 :       45988 :           if (m != MATCH_YES)
    2643                 :           0 :             return m;
    2644                 :             :         }
    2645                 :       94778 :       else if (component->ts.type == BT_CLASS && component->attr.class_ok
    2646                 :        9561 :                && CLASS_DATA (component)->as && !component->attr.proc_pointer)
    2647                 :             :         {
    2648                 :        4543 :           tail = extend_ref (primary, tail);
    2649                 :        4543 :           tail->type = REF_ARRAY;
    2650                 :             : 
    2651                 :        9086 :           m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
    2652                 :             :                                    equiv_flag,
    2653                 :        4543 :                                    CLASS_DATA (component)->as->corank);
    2654                 :        4543 :           if (m != MATCH_YES)
    2655                 :           0 :             return m;
    2656                 :             :         }
    2657                 :             : 
    2658                 :       90235 : check_done:
    2659                 :             :       /* In principle, we could have eg. expr%re%kind so we must allow for
    2660                 :             :          this possibility.  */
    2661                 :      142051 :       if (gfc_match_char ('%') == MATCH_YES)
    2662                 :             :         {
    2663                 :       16668 :           if (component && (component->ts.type == BT_DERIVED
    2664                 :        2559 :                             || component->ts.type == BT_CLASS))
    2665                 :       16319 :             sym = component->ts.u.derived;
    2666                 :       16668 :           continue;
    2667                 :             :         }
    2668                 :      125383 :       else if (inquiry)
    2669                 :             :         break;
    2670                 :             : 
    2671                 :      115832 :       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
    2672                 :      131449 :           || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
    2673                 :             :         break;
    2674                 :             : 
    2675                 :         370 :       if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
    2676                 :         370 :         sym = component->ts.u.derived;
    2677                 :             :     }
    2678                 :             : 
    2679                 :     3994269 : check_substring:
    2680                 :     3994269 :   unknown = false;
    2681                 :     3994269 :   if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
    2682                 :             :     {
    2683                 :     2320952 :       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
    2684                 :             :        {
    2685                 :         352 :          gfc_set_default_type (sym, 0, sym->ns);
    2686                 :         352 :          primary->ts = sym->ts;
    2687                 :         352 :          unknown = true;
    2688                 :             :        }
    2689                 :             :     }
    2690                 :             : 
    2691                 :     3994269 :   if (primary->ts.type == BT_CHARACTER)
    2692                 :             :     {
    2693                 :      284802 :       bool def = primary->ts.deferred == 1;
    2694                 :      284802 :       switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
    2695                 :             :         {
    2696                 :       13236 :         case MATCH_YES:
    2697                 :       13236 :           if (tail == NULL)
    2698                 :        8315 :             primary->ref = substring;
    2699                 :             :           else
    2700                 :        4921 :             tail->next = substring;
    2701                 :             : 
    2702                 :       13236 :           if (primary->expr_type == EXPR_CONSTANT)
    2703                 :         753 :             primary->expr_type = EXPR_SUBSTRING;
    2704                 :             : 
    2705                 :       13236 :           if (substring)
    2706                 :       13023 :             primary->ts.u.cl = NULL;
    2707                 :             : 
    2708                 :             :           break;
    2709                 :             : 
    2710                 :      271566 :         case MATCH_NO:
    2711                 :      271566 :           if (unknown)
    2712                 :             :             {
    2713                 :         351 :               gfc_clear_ts (&primary->ts);
    2714                 :         351 :               gfc_clear_ts (&sym->ts);
    2715                 :             :             }
    2716                 :             :           break;
    2717                 :             : 
    2718                 :             :         case MATCH_ERROR:
    2719                 :             :           return MATCH_ERROR;
    2720                 :             :         }
    2721                 :             :     }
    2722                 :             : 
    2723                 :             :   /* F08:C611.  */
    2724                 :     3994269 :   if (primary->ts.type == BT_DERIVED && primary->ref
    2725                 :       24639 :       && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
    2726                 :             :     {
    2727                 :           6 :       gfc_error ("Nonpolymorphic reference to abstract type at %C");
    2728                 :           6 :       return MATCH_ERROR;
    2729                 :             :     }
    2730                 :             : 
    2731                 :             :   /* F08:C727.  */
    2732                 :     3994263 :   if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
    2733                 :             :     {
    2734                 :           3 :       gfc_error ("Coindexed procedure-pointer component at %C");
    2735                 :           3 :       return MATCH_ERROR;
    2736                 :             :     }
    2737                 :             : 
    2738                 :             :   return MATCH_YES;
    2739                 :             : }
    2740                 :             : 
    2741                 :             : 
    2742                 :             : /* Given an expression that is a variable, figure out what the
    2743                 :             :    ultimate variable's type and attribute is, traversing the reference
    2744                 :             :    structures if necessary.
    2745                 :             : 
    2746                 :             :    This subroutine is trickier than it looks.  We start at the base
    2747                 :             :    symbol and store the attribute.  Component references load a
    2748                 :             :    completely new attribute.
    2749                 :             : 
    2750                 :             :    A couple of rules come into play.  Subobjects of targets are always
    2751                 :             :    targets themselves.  If we see a component that goes through a
    2752                 :             :    pointer, then the expression must also be a target, since the
    2753                 :             :    pointer is associated with something (if it isn't core will soon be
    2754                 :             :    dumped).  If we see a full part or section of an array, the
    2755                 :             :    expression is also an array.
    2756                 :             : 
    2757                 :             :    We can have at most one full array reference.  */
    2758                 :             : 
    2759                 :             : symbol_attribute
    2760                 :     3188712 : gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
    2761                 :             : {
    2762                 :     3188712 :   int dimension, codimension, pointer, allocatable, target, optional;
    2763                 :     3188712 :   symbol_attribute attr;
    2764                 :     3188712 :   gfc_ref *ref;
    2765                 :     3188712 :   gfc_symbol *sym;
    2766                 :     3188712 :   gfc_component *comp;
    2767                 :     3188712 :   bool has_inquiry_part;
    2768                 :             : 
    2769                 :     3188712 :   if (expr->expr_type != EXPR_VARIABLE
    2770                 :       21525 :       && expr->expr_type != EXPR_FUNCTION
    2771                 :           9 :       && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
    2772                 :           0 :     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
    2773                 :             : 
    2774                 :     3188712 :   sym = expr->symtree->n.sym;
    2775                 :     3188712 :   attr = sym->attr;
    2776                 :             : 
    2777                 :     3188712 :   optional = attr.optional;
    2778                 :     3188712 :   if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
    2779                 :             :     {
    2780                 :      114514 :       dimension = CLASS_DATA (sym)->attr.dimension;
    2781                 :      114514 :       codimension = CLASS_DATA (sym)->attr.codimension;
    2782                 :      114514 :       pointer = CLASS_DATA (sym)->attr.class_pointer;
    2783                 :      114514 :       allocatable = CLASS_DATA (sym)->attr.allocatable;
    2784                 :             :     }
    2785                 :             :   else
    2786                 :             :     {
    2787                 :     3074198 :       dimension = attr.dimension;
    2788                 :     3074198 :       codimension = attr.codimension;
    2789                 :     3074198 :       pointer = attr.pointer;
    2790                 :     3074198 :       allocatable = attr.allocatable;
    2791                 :             :     }
    2792                 :             : 
    2793                 :     3188712 :   target = attr.target;
    2794                 :     3188712 :   if (pointer || attr.proc_pointer)
    2795                 :      163628 :     target = 1;
    2796                 :             : 
    2797                 :             :   /* F2018:11.1.3.3: Other attributes of associate names
    2798                 :             :      "The associating entity does not have the ALLOCATABLE or POINTER
    2799                 :             :      attributes; it has the TARGET attribute if and only if the selector is
    2800                 :             :      a variable and has either the TARGET or POINTER attribute."  */
    2801                 :     3188712 :   if (sym->attr.associate_var && sym->assoc && sym->assoc->target)
    2802                 :             :     {
    2803                 :       27098 :       if (sym->assoc->target->expr_type == EXPR_VARIABLE)
    2804                 :             :         {
    2805                 :       24827 :           symbol_attribute tgt_attr;
    2806                 :       24827 :           tgt_attr = gfc_expr_attr (sym->assoc->target);
    2807                 :       24827 :           target = (tgt_attr.pointer || tgt_attr.target);
    2808                 :             :         }
    2809                 :             :       else
    2810                 :             :         target = 0;
    2811                 :             :     }
    2812                 :             : 
    2813                 :     3188712 :   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
    2814                 :       49239 :     *ts = sym->ts;
    2815                 :             : 
    2816                 :             :   /* Catch left-overs from match_actual_arg, where an actual argument of a
    2817                 :             :      procedure is given a temporary ts.type == BT_PROCEDURE.  The fixup is
    2818                 :             :      needed for structure constructors in DATA statements, where a pointer
    2819                 :             :      is associated with a data target, and the argument has not been fully
    2820                 :             :      resolved yet.  Components references are dealt with further below.  */
    2821                 :       49239 :   if (ts != NULL
    2822                 :      956738 :       && expr->ts.type == BT_PROCEDURE
    2823                 :        1884 :       && expr->ref == NULL
    2824                 :        1884 :       && attr.flavor != FL_PROCEDURE
    2825                 :          25 :       && attr.target)
    2826                 :           1 :     *ts = sym->ts;
    2827                 :             : 
    2828                 :     3188712 :   has_inquiry_part = false;
    2829                 :     4458800 :   for (ref = expr->ref; ref; ref = ref->next)
    2830                 :     1271162 :     if (ref->type == REF_INQUIRY)
    2831                 :             :       {
    2832                 :             :         has_inquiry_part = true;
    2833                 :             :         optional = false;
    2834                 :             :         break;
    2835                 :             :       }
    2836                 :             : 
    2837                 :     4459881 :   for (ref = expr->ref; ref; ref = ref->next)
    2838                 :     1271169 :     switch (ref->type)
    2839                 :             :       {
    2840                 :      979305 :       case REF_ARRAY:
    2841                 :             : 
    2842                 :      979305 :         switch (ref->u.ar.type)
    2843                 :             :           {
    2844                 :             :           case AR_FULL:
    2845                 :     1271169 :             dimension = 1;
    2846                 :             :             break;
    2847                 :             : 
    2848                 :       97395 :           case AR_SECTION:
    2849                 :       97395 :             allocatable = pointer = 0;
    2850                 :       97395 :             dimension = 1;
    2851                 :       97395 :             optional = false;
    2852                 :       97395 :             break;
    2853                 :             : 
    2854                 :      292964 :           case AR_ELEMENT:
    2855                 :             :             /* Handle coarrays.  */
    2856                 :      292964 :             if (ref->u.ar.dimen > 0)
    2857                 :     1271169 :               allocatable = pointer = optional = false;
    2858                 :             :             break;
    2859                 :             : 
    2860                 :             :           case AR_UNKNOWN:
    2861                 :             :             /* For standard conforming code, AR_UNKNOWN should not happen.
    2862                 :             :                For nonconforming code, gfortran can end up here.  Treat it
    2863                 :             :                as a no-op.  */
    2864                 :             :             break;
    2865                 :             :           }
    2866                 :             : 
    2867                 :             :         break;
    2868                 :             : 
    2869                 :      277307 :       case REF_COMPONENT:
    2870                 :      277307 :         optional = false;
    2871                 :      277307 :         comp = ref->u.c.component;
    2872                 :      277307 :         attr = comp->attr;
    2873                 :      277307 :         if (ts != NULL && !has_inquiry_part)
    2874                 :             :           {
    2875                 :       71178 :             *ts = comp->ts;
    2876                 :             :             /* Don't set the string length if a substring reference
    2877                 :             :                follows.  */
    2878                 :       71178 :             if (ts->type == BT_CHARACTER
    2879                 :        8248 :                 && ref->next && ref->next->type == REF_SUBSTRING)
    2880                 :         208 :                 ts->u.cl = NULL;
    2881                 :             :           }
    2882                 :             : 
    2883                 :      277307 :         if (comp->ts.type == BT_CLASS)
    2884                 :             :           {
    2885                 :       18654 :             codimension = CLASS_DATA (comp)->attr.codimension;
    2886                 :       18654 :             pointer = CLASS_DATA (comp)->attr.class_pointer;
    2887                 :       18654 :             allocatable = CLASS_DATA (comp)->attr.allocatable;
    2888                 :             :           }
    2889                 :             :         else
    2890                 :             :           {
    2891                 :      258653 :             codimension = comp->attr.codimension;
    2892                 :      258653 :             if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
    2893                 :       12235 :               pointer = comp->attr.class_pointer;
    2894                 :             :             else
    2895                 :      246418 :               pointer = comp->attr.pointer;
    2896                 :      258653 :             allocatable = comp->attr.allocatable;
    2897                 :             :           }
    2898                 :      277307 :         if (pointer || attr.proc_pointer)
    2899                 :       47872 :           target = 1;
    2900                 :             : 
    2901                 :             :         break;
    2902                 :             : 
    2903                 :       14557 :       case REF_INQUIRY:
    2904                 :       14557 :       case REF_SUBSTRING:
    2905                 :       14557 :         allocatable = pointer = optional = false;
    2906                 :       14557 :         break;
    2907                 :             :       }
    2908                 :             : 
    2909                 :     3188712 :   attr.dimension = dimension;
    2910                 :     3188712 :   attr.codimension = codimension;
    2911                 :     3188712 :   attr.pointer = pointer;
    2912                 :     3188712 :   attr.allocatable = allocatable;
    2913                 :     3188712 :   attr.target = target;
    2914                 :     3188712 :   attr.save = sym->attr.save;
    2915                 :     3188712 :   attr.optional = optional;
    2916                 :             : 
    2917                 :     3188712 :   return attr;
    2918                 :             : }
    2919                 :             : 
    2920                 :             : 
    2921                 :             : /* Return the attribute from a general expression.  */
    2922                 :             : 
    2923                 :             : symbol_attribute
    2924                 :     2846224 : gfc_expr_attr (gfc_expr *e)
    2925                 :             : {
    2926                 :     2846224 :   symbol_attribute attr;
    2927                 :             : 
    2928                 :     2846224 :   switch (e->expr_type)
    2929                 :             :     {
    2930                 :     2202765 :     case EXPR_VARIABLE:
    2931                 :     2202765 :       attr = gfc_variable_attr (e, NULL);
    2932                 :     2202765 :       break;
    2933                 :             : 
    2934                 :       35182 :     case EXPR_FUNCTION:
    2935                 :       35182 :       gfc_clear_attr (&attr);
    2936                 :             : 
    2937                 :       35182 :       if (e->value.function.esym && e->value.function.esym->result)
    2938                 :             :         {
    2939                 :       13644 :           gfc_symbol *sym = e->value.function.esym->result;
    2940                 :       13644 :           attr = sym->attr;
    2941                 :       13644 :           if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
    2942                 :             :             {
    2943                 :        1385 :               attr.dimension = CLASS_DATA (sym)->attr.dimension;
    2944                 :        1385 :               attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
    2945                 :        1385 :               attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
    2946                 :             :             }
    2947                 :             :         }
    2948                 :       21538 :       else if (e->value.function.isym
    2949                 :       20575 :                && e->value.function.isym->transformational
    2950                 :       10324 :                && e->ts.type == BT_CLASS)
    2951                 :          24 :         attr = CLASS_DATA (e)->attr;
    2952                 :       21514 :       else if (e->symtree)
    2953                 :       21514 :         attr = gfc_variable_attr (e, NULL);
    2954                 :             : 
    2955                 :             :       /* TODO: NULL() returns pointers.  May have to take care of this
    2956                 :             :          here.  */
    2957                 :             : 
    2958                 :             :       break;
    2959                 :             : 
    2960                 :      608277 :     default:
    2961                 :      608277 :       gfc_clear_attr (&attr);
    2962                 :      608277 :       break;
    2963                 :             :     }
    2964                 :             : 
    2965                 :     2846224 :   return attr;
    2966                 :             : }
    2967                 :             : 
    2968                 :             : 
    2969                 :             : /* Given an expression, figure out what the ultimate expression
    2970                 :             :    attribute is.  This routine is similar to gfc_variable_attr with
    2971                 :             :    parts of gfc_expr_attr, but focuses more on the needs of
    2972                 :             :    coarrays.  For coarrays a codimension attribute is kind of
    2973                 :             :    "infectious" being propagated once set and never cleared.
    2974                 :             :    The coarray_comp is only set, when the expression refs a coarray
    2975                 :             :    component.  REFS_COMP is set when present to true only, when this EXPR
    2976                 :             :    refs a (non-_data) component.  To check whether EXPR refs an allocatable
    2977                 :             :    component in a derived type coarray *refs_comp needs to be set and
    2978                 :             :    coarray_comp has to false.  */
    2979                 :             : 
    2980                 :             : static symbol_attribute
    2981                 :        8267 : caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
    2982                 :             : {
    2983                 :        8267 :   int dimension, codimension, pointer, allocatable, target, coarray_comp;
    2984                 :        8267 :   symbol_attribute attr;
    2985                 :        8267 :   gfc_ref *ref;
    2986                 :        8267 :   gfc_symbol *sym;
    2987                 :        8267 :   gfc_component *comp;
    2988                 :             : 
    2989                 :        8267 :   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
    2990                 :           0 :     gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
    2991                 :             : 
    2992                 :        8267 :   sym = expr->symtree->n.sym;
    2993                 :        8267 :   gfc_clear_attr (&attr);
    2994                 :             : 
    2995                 :        8267 :   if (refs_comp)
    2996                 :        3874 :     *refs_comp = false;
    2997                 :             : 
    2998                 :        8267 :   if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
    2999                 :             :     {
    3000                 :         338 :       dimension = CLASS_DATA (sym)->attr.dimension;
    3001                 :         338 :       codimension = CLASS_DATA (sym)->attr.codimension;
    3002                 :         338 :       pointer = CLASS_DATA (sym)->attr.class_pointer;
    3003                 :         338 :       allocatable = CLASS_DATA (sym)->attr.allocatable;
    3004                 :         338 :       attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
    3005                 :         338 :       attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
    3006                 :             :     }
    3007                 :             :   else
    3008                 :             :     {
    3009                 :        7929 :       dimension = sym->attr.dimension;
    3010                 :        7929 :       codimension = sym->attr.codimension;
    3011                 :        7929 :       pointer = sym->attr.pointer;
    3012                 :        7929 :       allocatable = sym->attr.allocatable;
    3013                 :       15858 :       attr.alloc_comp = sym->ts.type == BT_DERIVED
    3014                 :        7929 :           ? sym->ts.u.derived->attr.alloc_comp : 0;
    3015                 :        7929 :       attr.pointer_comp = sym->ts.type == BT_DERIVED
    3016                 :        7929 :           ? sym->ts.u.derived->attr.pointer_comp : 0;
    3017                 :             :     }
    3018                 :             : 
    3019                 :        8267 :   target = coarray_comp = 0;
    3020                 :        8267 :   if (pointer || attr.proc_pointer)
    3021                 :         242 :     target = 1;
    3022                 :             : 
    3023                 :       17204 :   for (ref = expr->ref; ref; ref = ref->next)
    3024                 :        8937 :     switch (ref->type)
    3025                 :             :       {
    3026                 :        5614 :       case REF_ARRAY:
    3027                 :             : 
    3028                 :        5614 :         switch (ref->u.ar.type)
    3029                 :             :           {
    3030                 :             :           case AR_FULL:
    3031                 :             :           case AR_SECTION:
    3032                 :             :             dimension = 1;
    3033                 :        5614 :             break;
    3034                 :             : 
    3035                 :        3655 :           case AR_ELEMENT:
    3036                 :             :             /* Handle coarrays.  */
    3037                 :        3655 :             if (ref->u.ar.dimen > 0 && !in_allocate)
    3038                 :        5614 :               allocatable = pointer = 0;
    3039                 :             :             break;
    3040                 :             : 
    3041                 :           0 :           case AR_UNKNOWN:
    3042                 :             :             /* If any of start, end or stride is not integer, there will
    3043                 :             :                already have been an error issued.  */
    3044                 :           0 :             int errors;
    3045                 :           0 :             gfc_get_errors (NULL, &errors);
    3046                 :           0 :             if (errors == 0)
    3047                 :           0 :               gfc_internal_error ("gfc_caf_attr(): Bad array reference");
    3048                 :             :           }
    3049                 :             : 
    3050                 :             :         break;
    3051                 :             : 
    3052                 :        3323 :       case REF_COMPONENT:
    3053                 :        3323 :         comp = ref->u.c.component;
    3054                 :             : 
    3055                 :        3323 :         if (comp->ts.type == BT_CLASS)
    3056                 :             :           {
    3057                 :             :             /* Set coarray_comp only, when this component introduces the
    3058                 :             :                coarray.  */
    3059                 :          13 :             coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
    3060                 :          13 :             codimension |= CLASS_DATA (comp)->attr.codimension;
    3061                 :          13 :             pointer = CLASS_DATA (comp)->attr.class_pointer;
    3062                 :          13 :             allocatable = CLASS_DATA (comp)->attr.allocatable;
    3063                 :             :           }
    3064                 :             :         else
    3065                 :             :           {
    3066                 :             :             /* Set coarray_comp only, when this component introduces the
    3067                 :             :                coarray.  */
    3068                 :        3310 :             coarray_comp = !codimension && comp->attr.codimension;
    3069                 :        3310 :             codimension |= comp->attr.codimension;
    3070                 :        3310 :             pointer = comp->attr.pointer;
    3071                 :        3310 :             allocatable = comp->attr.allocatable;
    3072                 :             :           }
    3073                 :             : 
    3074                 :        3323 :         if (refs_comp && strcmp (comp->name, "_data") != 0
    3075                 :        1246 :             && (ref->next == NULL
    3076                 :         839 :                 || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
    3077                 :         924 :           *refs_comp = true;
    3078                 :             : 
    3079                 :        3323 :         if (pointer || attr.proc_pointer)
    3080                 :         678 :           target = 1;
    3081                 :             : 
    3082                 :             :         break;
    3083                 :             : 
    3084                 :             :       case REF_SUBSTRING:
    3085                 :             :       case REF_INQUIRY:
    3086                 :        8937 :         allocatable = pointer = 0;
    3087                 :             :         break;
    3088                 :             :       }
    3089                 :             : 
    3090                 :        8267 :   attr.dimension = dimension;
    3091                 :        8267 :   attr.codimension = codimension;
    3092                 :        8267 :   attr.pointer = pointer;
    3093                 :        8267 :   attr.allocatable = allocatable;
    3094                 :        8267 :   attr.target = target;
    3095                 :        8267 :   attr.save = sym->attr.save;
    3096                 :        8267 :   attr.coarray_comp = coarray_comp;
    3097                 :             : 
    3098                 :        8267 :   return attr;
    3099                 :             : }
    3100                 :             : 
    3101                 :             : 
    3102                 :             : symbol_attribute
    3103                 :       10130 : gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
    3104                 :             : {
    3105                 :       10130 :   symbol_attribute attr;
    3106                 :             : 
    3107                 :       10130 :   switch (e->expr_type)
    3108                 :             :     {
    3109                 :        8016 :     case EXPR_VARIABLE:
    3110                 :        8016 :       attr = caf_variable_attr (e, in_allocate, refs_comp);
    3111                 :        8016 :       break;
    3112                 :             : 
    3113                 :         253 :     case EXPR_FUNCTION:
    3114                 :         253 :       gfc_clear_attr (&attr);
    3115                 :             : 
    3116                 :         253 :       if (e->value.function.esym && e->value.function.esym->result)
    3117                 :             :         {
    3118                 :           2 :           gfc_symbol *sym = e->value.function.esym->result;
    3119                 :           2 :           attr = sym->attr;
    3120                 :           2 :           if (sym->ts.type == BT_CLASS)
    3121                 :             :             {
    3122                 :           0 :               attr.dimension = CLASS_DATA (sym)->attr.dimension;
    3123                 :           0 :               attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
    3124                 :           0 :               attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
    3125                 :           0 :               attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
    3126                 :           0 :               attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
    3127                 :           0 :                   ->attr.pointer_comp;
    3128                 :             :             }
    3129                 :             :         }
    3130                 :         251 :       else if (e->symtree)
    3131                 :         251 :         attr = caf_variable_attr (e, in_allocate, refs_comp);
    3132                 :             :       else
    3133                 :           0 :         gfc_clear_attr (&attr);
    3134                 :             :       break;
    3135                 :             : 
    3136                 :        1861 :     default:
    3137                 :        1861 :       gfc_clear_attr (&attr);
    3138                 :        1861 :       break;
    3139                 :             :     }
    3140                 :             : 
    3141                 :       10130 :   return attr;
    3142                 :             : }
    3143                 :             : 
    3144                 :             : 
    3145                 :             : /* Match a structure constructor.  The initial symbol has already been
    3146                 :             :    seen.  */
    3147                 :             : 
    3148                 :             : typedef struct gfc_structure_ctor_component
    3149                 :             : {
    3150                 :             :   char* name;
    3151                 :             :   gfc_expr* val;
    3152                 :             :   locus where;
    3153                 :             :   struct gfc_structure_ctor_component* next;
    3154                 :             : }
    3155                 :             : gfc_structure_ctor_component;
    3156                 :             : 
    3157                 :             : #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
    3158                 :             : 
    3159                 :             : static void
    3160                 :        8947 : gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
    3161                 :             : {
    3162                 :        8947 :   free (comp->name);
    3163                 :        8947 :   gfc_free_expr (comp->val);
    3164                 :        8947 :   free (comp);
    3165                 :        8947 : }
    3166                 :             : 
    3167                 :             : 
    3168                 :             : /* Translate the component list into the actual constructor by sorting it in
    3169                 :             :    the order required; this also checks along the way that each and every
    3170                 :             :    component actually has an initializer and handles default initializers
    3171                 :             :    for components without explicit value given.  */
    3172                 :             : static bool
    3173                 :        6304 : build_actual_constructor (gfc_structure_ctor_component **comp_head,
    3174                 :             :                           gfc_constructor_base *ctor_head, gfc_symbol *sym)
    3175                 :             : {
    3176                 :        6304 :   gfc_structure_ctor_component *comp_iter;
    3177                 :        6304 :   gfc_component *comp;
    3178                 :             : 
    3179                 :       16554 :   for (comp = sym->components; comp; comp = comp->next)
    3180                 :             :     {
    3181                 :       10255 :       gfc_structure_ctor_component **next_ptr;
    3182                 :       10255 :       gfc_expr *value = NULL;
    3183                 :             : 
    3184                 :             :       /* Try to find the initializer for the current component by name.  */
    3185                 :       10255 :       next_ptr = comp_head;
    3186                 :       11387 :       for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
    3187                 :             :         {
    3188                 :       10055 :           if (!strcmp (comp_iter->name, comp->name))
    3189                 :             :             break;
    3190                 :        1132 :           next_ptr = &comp_iter->next;
    3191                 :             :         }
    3192                 :             : 
    3193                 :             :       /* If an extension, try building the parent derived type by building
    3194                 :             :          a value expression for the parent derived type and calling self.  */
    3195                 :       10255 :       if (!comp_iter && comp == sym->components && sym->attr.extension)
    3196                 :             :         {
    3197                 :         103 :           value = gfc_get_structure_constructor_expr (comp->ts.type,
    3198                 :             :                                                       comp->ts.kind,
    3199                 :             :                                                       &gfc_current_locus);
    3200                 :         103 :           value->ts = comp->ts;
    3201                 :             : 
    3202                 :         103 :           if (!build_actual_constructor (comp_head,
    3203                 :             :                                          &value->value.constructor,
    3204                 :             :                                          comp->ts.u.derived))
    3205                 :             :             {
    3206                 :           0 :               gfc_free_expr (value);
    3207                 :           0 :               return false;
    3208                 :             :             }
    3209                 :             : 
    3210                 :         103 :           gfc_constructor_append_expr (ctor_head, value, NULL);
    3211                 :         103 :           continue;
    3212                 :             :         }
    3213                 :             : 
    3214                 :             :       /* If it was not found, apply NULL expression to set the component as
    3215                 :             :          unallocated. Then try the default initializer if there's any;
    3216                 :             :          otherwise, it's an error unless this is a deferred parameter.  */
    3217                 :        1229 :       if (!comp_iter)
    3218                 :             :         {
    3219                 :             :           /* F2018 7.5.10: If an allocatable component has no corresponding
    3220                 :             :              component-data-source, then that component has an allocation
    3221                 :             :              status of unallocated....  */
    3222                 :        1229 :           if (comp->attr.allocatable
    3223                 :        1128 :               || (comp->ts.type == BT_CLASS
    3224                 :           9 :                   && CLASS_DATA (comp)->attr.allocatable))
    3225                 :             :             {
    3226                 :         104 :               if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
    3227                 :             :                                    "allocatable component %qs given in the "
    3228                 :             :                                    "structure constructor at %C", comp->name))
    3229                 :             :                 return false;
    3230                 :         104 :               value = gfc_get_null_expr (&gfc_current_locus);
    3231                 :             :             }
    3232                 :             :           /* ....(Preceding sentence) If a component with default
    3233                 :             :              initialization has no corresponding component-data-source, then
    3234                 :             :              the default initialization is applied to that component.  */
    3235                 :        1125 :           else if (comp->initializer)
    3236                 :             :             {
    3237                 :         629 :               if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
    3238                 :             :                                    "with missing optional arguments at %C"))
    3239                 :             :                 return false;
    3240                 :         627 :               value = gfc_copy_expr (comp->initializer);
    3241                 :             :             }
    3242                 :             :           /* Do not trap components such as the string length for deferred
    3243                 :             :              length character components.  */
    3244                 :         496 :           else if (!comp->attr.artificial)
    3245                 :             :             {
    3246                 :           3 :               gfc_error ("No initializer for component %qs given in the"
    3247                 :             :                          " structure constructor at %C", comp->name);
    3248                 :           3 :               return false;
    3249                 :             :             }
    3250                 :             :         }
    3251                 :             :       else
    3252                 :        8923 :         value = comp_iter->val;
    3253                 :             : 
    3254                 :             :       /* Add the value to the constructor chain built.  */
    3255                 :       10147 :       gfc_constructor_append_expr (ctor_head, value, NULL);
    3256                 :             : 
    3257                 :             :       /* Remove the entry from the component list.  We don't want the expression
    3258                 :             :          value to be free'd, so set it to NULL.  */
    3259                 :       10147 :       if (comp_iter)
    3260                 :             :         {
    3261                 :        8923 :           *next_ptr = comp_iter->next;
    3262                 :        8923 :           comp_iter->val = NULL;
    3263                 :        8923 :           gfc_free_structure_ctor_component (comp_iter);
    3264                 :             :         }
    3265                 :             :     }
    3266                 :             :   return true;
    3267                 :             : }
    3268                 :             : 
    3269                 :             : 
    3270                 :             : bool
    3271                 :        6216 : gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
    3272                 :             :                                       gfc_actual_arglist **arglist,
    3273                 :             :                                       bool parent)
    3274                 :             : {
    3275                 :        6216 :   gfc_actual_arglist *actual;
    3276                 :        6216 :   gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
    3277                 :        6216 :   gfc_constructor_base ctor_head = NULL;
    3278                 :        6216 :   gfc_component *comp; /* Is set NULL when named component is first seen */
    3279                 :        6216 :   const char* last_name = NULL;
    3280                 :        6216 :   locus old_locus;
    3281                 :        6216 :   gfc_expr *expr;
    3282                 :             : 
    3283                 :        6216 :   expr = parent ? *cexpr : e;
    3284                 :        6216 :   old_locus = gfc_current_locus;
    3285                 :        6216 :   if (parent)
    3286                 :             :     ; /* gfc_current_locus = *arglist->expr ? ->where;*/
    3287                 :             :   else
    3288                 :        5580 :     gfc_current_locus = expr->where;
    3289                 :             : 
    3290                 :        6216 :   comp_tail = comp_head = NULL;
    3291                 :             : 
    3292                 :        6216 :   if (!parent && sym->attr.abstract)
    3293                 :             :     {
    3294                 :           1 :       gfc_error ("Cannot construct ABSTRACT type %qs at %L",
    3295                 :             :                  sym->name, &expr->where);
    3296                 :           1 :       goto cleanup;
    3297                 :             :     }
    3298                 :             : 
    3299                 :        6215 :   comp = sym->components;
    3300                 :        6215 :   actual = parent ? *arglist : expr->value.function.actual;
    3301                 :       14639 :   for ( ; actual; )
    3302                 :             :     {
    3303                 :        8947 :       gfc_component *this_comp = NULL;
    3304                 :             : 
    3305                 :        8947 :       if (!comp_head)
    3306                 :        5836 :         comp_tail = comp_head = gfc_get_structure_ctor_component ();
    3307                 :             :       else
    3308                 :             :         {
    3309                 :        3111 :           comp_tail->next = gfc_get_structure_ctor_component ();
    3310                 :        3111 :           comp_tail = comp_tail->next;
    3311                 :             :         }
    3312                 :        8947 :       if (actual->name)
    3313                 :             :         {
    3314                 :         835 :           if (!gfc_notify_std (GFC_STD_F2003, "Structure"
    3315                 :             :                                " constructor with named arguments at %C"))
    3316                 :           1 :             goto cleanup;
    3317                 :             : 
    3318                 :         834 :           comp_tail->name = xstrdup (actual->name);
    3319                 :         834 :           last_name = comp_tail->name;
    3320                 :         834 :           comp = NULL;
    3321                 :             :         }
    3322                 :             :       else
    3323                 :             :         {
    3324                 :             :           /* Components without name are not allowed after the first named
    3325                 :             :              component initializer!  */
    3326                 :        8112 :           if (!comp || comp->attr.artificial)
    3327                 :             :             {
    3328                 :           2 :               if (last_name)
    3329                 :           0 :                 gfc_error ("Component initializer without name after component"
    3330                 :             :                            " named %s at %L", last_name,
    3331                 :           0 :                            actual->expr ? &actual->expr->where
    3332                 :             :                                         : &gfc_current_locus);
    3333                 :             :               else
    3334                 :           2 :                 gfc_error ("Too many components in structure constructor at "
    3335                 :           2 :                            "%L", actual->expr ? &actual->expr->where
    3336                 :             :                                               : &gfc_current_locus);
    3337                 :           2 :               goto cleanup;
    3338                 :             :             }
    3339                 :             : 
    3340                 :        8110 :           comp_tail->name = xstrdup (comp->name);
    3341                 :             :         }
    3342                 :             : 
    3343                 :             :       /* Find the current component in the structure definition and check
    3344                 :             :              its access is not private.  */
    3345                 :        8944 :       if (comp)
    3346                 :        8110 :         this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
    3347                 :             :       else
    3348                 :             :         {
    3349                 :         834 :           this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
    3350                 :             :                                           false, false, NULL);
    3351                 :         834 :           comp = NULL; /* Reset needed!  */
    3352                 :             :         }
    3353                 :             : 
    3354                 :             :       /* Here we can check if a component name is given which does not
    3355                 :             :          correspond to any component of the defined structure.  */
    3356                 :        8944 :       if (!this_comp)
    3357                 :           8 :         goto cleanup;
    3358                 :             : 
    3359                 :             :       /* For a constant string constructor, make sure the length is
    3360                 :             :          correct; truncate or fill with blanks if needed.  */
    3361                 :        8936 :       if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
    3362                 :         956 :           && this_comp->ts.u.cl && this_comp->ts.u.cl->length
    3363                 :         954 :           && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
    3364                 :         942 :           && this_comp->ts.u.cl->length->ts.type == BT_INTEGER
    3365                 :         941 :           && actual->expr->ts.type == BT_CHARACTER
    3366                 :         929 :           && actual->expr->expr_type == EXPR_CONSTANT)
    3367                 :             :         {
    3368                 :         707 :           ptrdiff_t c, e1;
    3369                 :         707 :           c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
    3370                 :         707 :           e1 = actual->expr->value.character.length;
    3371                 :             : 
    3372                 :         707 :           if (c != e1)
    3373                 :             :             {
    3374                 :         230 :               ptrdiff_t i, to;
    3375                 :         230 :               gfc_char_t *dest;
    3376                 :         230 :               dest = gfc_get_wide_string (c + 1);
    3377                 :             : 
    3378                 :         230 :               to = e1 < c ? e1 : c;
    3379                 :        4373 :               for (i = 0; i < to; i++)
    3380                 :        4143 :                 dest[i] = actual->expr->value.character.string[i];
    3381                 :             : 
    3382                 :        5763 :               for (i = e1; i < c; i++)
    3383                 :        5533 :                 dest[i] = ' ';
    3384                 :             : 
    3385                 :         230 :               dest[c] = '\0';
    3386                 :         230 :               free (actual->expr->value.character.string);
    3387                 :             : 
    3388                 :         230 :               actual->expr->value.character.length = c;
    3389                 :         230 :               actual->expr->value.character.string = dest;
    3390                 :             : 
    3391                 :         230 :               if (warn_line_truncation && c < e1)
    3392                 :          14 :                 gfc_warning_now (OPT_Wcharacter_truncation,
    3393                 :             :                                  "CHARACTER expression will be truncated "
    3394                 :             :                                  "in constructor (%td/%td) at %L", c,
    3395                 :             :                                  e1, &actual->expr->where);
    3396                 :             :             }
    3397                 :             :         }
    3398                 :             : 
    3399                 :        8936 :       comp_tail->val = actual->expr;
    3400                 :        8936 :       if (actual->expr != NULL)
    3401                 :        8936 :         comp_tail->where = actual->expr->where;
    3402                 :        8936 :       actual->expr = NULL;
    3403                 :             : 
    3404                 :             :       /* Check if this component is already given a value.  */
    3405                 :       14371 :       for (comp_iter = comp_head; comp_iter != comp_tail;
    3406                 :        5435 :            comp_iter = comp_iter->next)
    3407                 :             :         {
    3408                 :        5436 :           gcc_assert (comp_iter);
    3409                 :        5436 :           if (!strcmp (comp_iter->name, comp_tail->name))
    3410                 :             :             {
    3411                 :           1 :               gfc_error ("Component %qs is initialized twice in the structure"
    3412                 :             :                          " constructor at %L", comp_tail->name,
    3413                 :             :                          comp_tail->val ? &comp_tail->where
    3414                 :             :                                         : &gfc_current_locus);
    3415                 :           1 :               goto cleanup;
    3416                 :             :             }
    3417                 :             :         }
    3418                 :             : 
    3419                 :             :       /* F2008, R457/C725, for PURE C1283.  */
    3420                 :          77 :       if (this_comp->attr.pointer && comp_tail->val
    3421                 :        9012 :           && gfc_is_coindexed (comp_tail->val))
    3422                 :             :         {
    3423                 :           2 :           gfc_error ("Coindexed expression to pointer component %qs in "
    3424                 :             :                      "structure constructor at %L", comp_tail->name,
    3425                 :             :                      &comp_tail->where);
    3426                 :           2 :           goto cleanup;
    3427                 :             :         }
    3428                 :             : 
    3429                 :             :           /* If not explicitly a parent constructor, gather up the components
    3430                 :             :              and build one.  */
    3431                 :        8933 :           if (comp && comp == sym->components
    3432                 :        5641 :                 && sym->attr.extension
    3433                 :         660 :                 && comp_tail->val
    3434                 :         660 :                 && (!gfc_bt_struct (comp_tail->val->ts.type)
    3435                 :          54 :                       ||
    3436                 :          54 :                     comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
    3437                 :             :             {
    3438                 :         636 :               bool m;
    3439                 :         636 :               gfc_actual_arglist *arg_null = NULL;
    3440                 :             : 
    3441                 :         636 :               actual->expr = comp_tail->val;
    3442                 :         636 :               comp_tail->val = NULL;
    3443                 :             : 
    3444                 :         636 :               m = gfc_convert_to_structure_constructor (NULL,
    3445                 :             :                                         comp->ts.u.derived, &comp_tail->val,
    3446                 :         636 :                                         comp->ts.u.derived->attr.zero_comp
    3447                 :             :                                           ? &arg_null : &actual, true);
    3448                 :         636 :               if (!m)
    3449                 :           0 :                 goto cleanup;
    3450                 :             : 
    3451                 :         636 :               if (comp->ts.u.derived->attr.zero_comp)
    3452                 :             :                 {
    3453                 :         126 :                   comp = comp->next;
    3454                 :         126 :                   continue;
    3455                 :             :                 }
    3456                 :             :             }
    3457                 :             : 
    3458                 :         510 :       if (comp)
    3459                 :        7976 :         comp = comp->next;
    3460                 :        8807 :       if (parent && !comp)
    3461                 :             :         break;
    3462                 :             : 
    3463                 :        8298 :       if (actual)
    3464                 :        8297 :         actual = actual->next;
    3465                 :             :     }
    3466                 :             : 
    3467                 :        6201 :   if (!build_actual_constructor (&comp_head, &ctor_head, sym))
    3468                 :           5 :     goto cleanup;
    3469                 :             : 
    3470                 :             :   /* No component should be left, as this should have caused an error in the
    3471                 :             :      loop constructing the component-list (name that does not correspond to any
    3472                 :             :      component in the structure definition).  */
    3473                 :        6196 :   if (comp_head && sym->attr.extension)
    3474                 :             :     {
    3475                 :           2 :       for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
    3476                 :             :         {
    3477                 :           1 :           gfc_error ("component %qs at %L has already been set by a "
    3478                 :             :                      "parent derived type constructor", comp_iter->name,
    3479                 :             :                      &comp_iter->where);
    3480                 :             :         }
    3481                 :           1 :       goto cleanup;
    3482                 :             :     }
    3483                 :             :   else
    3484                 :        6195 :     gcc_assert (!comp_head);
    3485                 :             : 
    3486                 :        6195 :   if (parent)
    3487                 :             :     {
    3488                 :         636 :       expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
    3489                 :         636 :       expr->ts.u.derived = sym;
    3490                 :         636 :       expr->value.constructor = ctor_head;
    3491                 :         636 :       *cexpr = expr;
    3492                 :             :     }
    3493                 :             :   else
    3494                 :             :     {
    3495                 :        5559 :       expr->ts.u.derived = sym;
    3496                 :        5559 :       expr->ts.kind = 0;
    3497                 :        5559 :       expr->ts.type = BT_DERIVED;
    3498                 :        5559 :       expr->value.constructor = ctor_head;
    3499                 :        5559 :       expr->expr_type = EXPR_STRUCTURE;
    3500                 :             :     }
    3501                 :             : 
    3502                 :        6195 :   gfc_current_locus = old_locus;
    3503                 :        6195 :   if (parent)
    3504                 :         636 :     *arglist = actual;
    3505                 :             :   return true;
    3506                 :             : 
    3507                 :          21 :   cleanup:
    3508                 :          21 :   gfc_current_locus = old_locus;
    3509                 :             : 
    3510                 :          45 :   for (comp_iter = comp_head; comp_iter; )
    3511                 :             :     {
    3512                 :          24 :       gfc_structure_ctor_component *next = comp_iter->next;
    3513                 :          24 :       gfc_free_structure_ctor_component (comp_iter);
    3514                 :          24 :       comp_iter = next;
    3515                 :             :     }
    3516                 :          21 :   gfc_constructor_free (ctor_head);
    3517                 :             : 
    3518                 :          21 :   return false;
    3519                 :             : }
    3520                 :             : 
    3521                 :             : 
    3522                 :             : match
    3523                 :          57 : gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
    3524                 :             : {
    3525                 :          57 :   match m;
    3526                 :          57 :   gfc_expr *e;
    3527                 :          57 :   gfc_symtree *symtree;
    3528                 :          57 :   bool t = true;
    3529                 :             : 
    3530                 :          57 :   gfc_get_ha_sym_tree (sym->name, &symtree);
    3531                 :             : 
    3532                 :          57 :   e = gfc_get_expr ();
    3533                 :          57 :   e->symtree = symtree;
    3534                 :          57 :   e->expr_type = EXPR_FUNCTION;
    3535                 :          57 :   e->where = gfc_current_locus;
    3536                 :             : 
    3537                 :          57 :   gcc_assert (gfc_fl_struct (sym->attr.flavor)
    3538                 :             :               && symtree->n.sym->attr.flavor == FL_PROCEDURE);
    3539                 :          57 :   e->value.function.esym = sym;
    3540                 :          57 :   e->symtree->n.sym->attr.generic = 1;
    3541                 :             : 
    3542                 :          57 :   m = gfc_match_actual_arglist (0, &e->value.function.actual);
    3543                 :          57 :   if (m != MATCH_YES)
    3544                 :             :     {
    3545                 :           0 :       gfc_free_expr (e);
    3546                 :           0 :       return m;
    3547                 :             :     }
    3548                 :             : 
    3549                 :          57 :   if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
    3550                 :             :     {
    3551                 :           1 :       gfc_free_expr (e);
    3552                 :           1 :       return MATCH_ERROR;
    3553                 :             :     }
    3554                 :             : 
    3555                 :             :   /* If a structure constructor is in a DATA statement, then each entity
    3556                 :             :      in the structure constructor must be a constant.  Try to reduce the
    3557                 :             :      expression here.  */
    3558                 :          56 :   if (gfc_in_match_data ())
    3559                 :          56 :     t = gfc_reduce_init_expr (e);
    3560                 :             : 
    3561                 :          56 :   if (t)
    3562                 :             :     {
    3563                 :          46 :       *result = e;
    3564                 :          46 :       return MATCH_YES;
    3565                 :             :     }
    3566                 :             :   else
    3567                 :             :     {
    3568                 :          10 :       gfc_free_expr (e);
    3569                 :          10 :       return MATCH_ERROR;
    3570                 :             :     }
    3571                 :             : }
    3572                 :             : 
    3573                 :             : 
    3574                 :             : /* If the symbol is an implicit do loop index and implicitly typed,
    3575                 :             :    it should not be host associated.  Provide a symtree from the
    3576                 :             :    current namespace.  */
    3577                 :             : static match
    3578                 :     5574731 : check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
    3579                 :             : {
    3580                 :     5574731 :   if ((*sym)->attr.flavor == FL_VARIABLE
    3581                 :     1325864 :       && (*sym)->ns != gfc_current_ns
    3582                 :             :       && (*sym)->attr.implied_index
    3583                 :             :       && (*sym)->attr.implicit_type
    3584                 :       48962 :       && !(*sym)->attr.use_assoc)
    3585                 :             :     {
    3586                 :          32 :       int i;
    3587                 :          32 :       i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
    3588                 :          32 :       if (i)
    3589                 :             :         return MATCH_ERROR;
    3590                 :          32 :       *sym = (*st)->n.sym;
    3591                 :             :     }
    3592                 :             :   return MATCH_YES;
    3593                 :             : }
    3594                 :             : 
    3595                 :             : 
    3596                 :             : /* Procedure pointer as function result: Replace the function symbol by the
    3597                 :             :    auto-generated hidden result variable named "ppr@".  */
    3598                 :             : 
    3599                 :             : static bool
    3600                 :     4138008 : replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
    3601                 :             : {
    3602                 :             :   /* Check for procedure pointer result variable.  */
    3603                 :     4138008 :   if ((*sym)->attr.function && !(*sym)->attr.external
    3604                 :     1219801 :       && (*sym)->result && (*sym)->result != *sym
    3605                 :        9291 :       && (*sym)->result->attr.proc_pointer
    3606                 :         323 :       && (*sym) == gfc_current_ns->proc_name
    3607                 :         283 :       && (*sym) == (*sym)->result->ns->proc_name
    3608                 :         283 :       && strcmp ("ppr@", (*sym)->result->name) == 0)
    3609                 :             :     {
    3610                 :             :       /* Automatic replacement with "hidden" result variable.  */
    3611                 :         283 :       (*sym)->result->attr.referenced = (*sym)->attr.referenced;
    3612                 :         283 :       *sym = (*sym)->result;
    3613                 :         283 :       *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
    3614                 :         283 :       return true;
    3615                 :             :     }
    3616                 :             :   return false;
    3617                 :             : }
    3618                 :             : 
    3619                 :             : 
    3620                 :             : /* Matches a variable name followed by anything that might follow it--
    3621                 :             :    array reference, argument list of a function, etc.  */
    3622                 :             : 
    3623                 :             : match
    3624                 :     3355899 : gfc_match_rvalue (gfc_expr **result)
    3625                 :             : {
    3626                 :     3355899 :   gfc_actual_arglist *actual_arglist;
    3627                 :     3355899 :   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
    3628                 :     3355899 :   gfc_state_data *st;
    3629                 :     3355899 :   gfc_symbol *sym;
    3630                 :     3355899 :   gfc_symtree *symtree;
    3631                 :     3355899 :   locus where, old_loc;
    3632                 :     3355899 :   gfc_expr *e;
    3633                 :     3355899 :   match m, m2;
    3634                 :     3355899 :   int i;
    3635                 :     3355899 :   gfc_typespec *ts;
    3636                 :     3355899 :   bool implicit_char;
    3637                 :     3355899 :   gfc_ref *ref;
    3638                 :             : 
    3639                 :     3355899 :   m = gfc_match ("%%loc");
    3640                 :     3355899 :   if (m == MATCH_YES)
    3641                 :             :     {
    3642                 :       10878 :       if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
    3643                 :             :         return MATCH_ERROR;
    3644                 :       10877 :       strncpy (name, "loc", 4);
    3645                 :             :     }
    3646                 :             : 
    3647                 :             :   else
    3648                 :             :     {
    3649                 :     3345021 :       m = gfc_match_name (name);
    3650                 :     3345021 :       if (m != MATCH_YES)
    3651                 :             :         return m;
    3652                 :             :     }
    3653                 :             : 
    3654                 :             :   /* Check if the symbol exists.  */
    3655                 :     3185276 :   if (gfc_find_sym_tree (name, NULL, 1, &symtree))
    3656                 :             :     return MATCH_ERROR;
    3657                 :             : 
    3658                 :             :   /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
    3659                 :             :      type. For derived types we create a generic symbol which links to the
    3660                 :             :      derived type symbol; STRUCTUREs are simpler and must not conflict with
    3661                 :             :      variables.  */
    3662                 :     3185274 :   if (!symtree)
    3663                 :      152021 :     if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
    3664                 :             :       return MATCH_ERROR;
    3665                 :     3185274 :   if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
    3666                 :             :     {
    3667                 :     3185274 :       if (gfc_find_state (COMP_INTERFACE)
    3668                 :     3185274 :           && !gfc_current_ns->has_import_set)
    3669                 :       73527 :         i = gfc_get_sym_tree (name, NULL, &symtree, false);
    3670                 :             :       else
    3671                 :     3111747 :         i = gfc_get_ha_sym_tree (name, &symtree);
    3672                 :     3185274 :       if (i)
    3673                 :             :         return MATCH_ERROR;
    3674                 :             :     }
    3675                 :             : 
    3676                 :             : 
    3677                 :     3185274 :   sym = symtree->n.sym;
    3678                 :     3185274 :   e = NULL;
    3679                 :     3185274 :   where = gfc_current_locus;
    3680                 :             : 
    3681                 :     3185274 :   replace_hidden_procptr_result (&sym, &symtree);
    3682                 :             : 
    3683                 :             :   /* If this is an implicit do loop index and implicitly typed,
    3684                 :             :      it should not be host associated.  */
    3685                 :     3185274 :   m = check_for_implicit_index (&symtree, &sym);
    3686                 :     3185274 :   if (m != MATCH_YES)
    3687                 :             :     return m;
    3688                 :             : 
    3689                 :     3185274 :   gfc_set_sym_referenced (sym);
    3690                 :     3185274 :   sym->attr.implied_index = 0;
    3691                 :             : 
    3692                 :     3185274 :   if (sym->attr.function && sym->result == sym)
    3693                 :             :     {
    3694                 :             :       /* See if this is a directly recursive function call.  */
    3695                 :      613780 :       gfc_gobble_whitespace ();
    3696                 :      613780 :       if (sym->attr.recursive
    3697                 :         100 :           && gfc_peek_ascii_char () == '('
    3698                 :          93 :           && gfc_current_ns->proc_name == sym
    3699                 :      613787 :           && !sym->attr.dimension)
    3700                 :             :         {
    3701                 :           4 :           gfc_error ("%qs at %C is the name of a recursive function "
    3702                 :             :                      "and so refers to the result variable. Use an "
    3703                 :             :                      "explicit RESULT variable for direct recursion "
    3704                 :             :                      "(12.5.2.1)", sym->name);
    3705                 :           4 :           return MATCH_ERROR;
    3706                 :             :         }
    3707                 :             : 
    3708                 :      613776 :       if (gfc_is_function_return_value (sym, gfc_current_ns))
    3709                 :        1579 :         goto variable;
    3710                 :             : 
    3711                 :      612197 :       if (sym->attr.entry
    3712                 :         187 :           && (sym->ns == gfc_current_ns
    3713                 :          27 :               || sym->ns == gfc_current_ns->parent))
    3714                 :             :         {
    3715                 :         180 :           gfc_entry_list *el = NULL;
    3716                 :             : 
    3717                 :         180 :           for (el = sym->ns->entries; el; el = el->next)
    3718                 :         180 :             if (sym == el->sym)
    3719                 :         180 :               goto variable;
    3720                 :             :         }
    3721                 :             :     }
    3722                 :             : 
    3723                 :     3183511 :   if (gfc_matching_procptr_assignment)
    3724                 :             :     {
    3725                 :             :       /* It can be a procedure or a derived-type procedure or a not-yet-known
    3726                 :             :          type.  */
    3727                 :        1287 :       if (sym->attr.flavor != FL_UNKNOWN
    3728                 :         965 :           && sym->attr.flavor != FL_PROCEDURE
    3729                 :             :           && sym->attr.flavor != FL_PARAMETER
    3730                 :             :           && sym->attr.flavor != FL_VARIABLE)
    3731                 :             :         {
    3732                 :           2 :           gfc_error ("Symbol at %C is not appropriate for an expression");
    3733                 :           2 :           return MATCH_ERROR;
    3734                 :             :         }
    3735                 :        1285 :       goto procptr0;
    3736                 :             :     }
    3737                 :             : 
    3738                 :     3182224 :   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
    3739                 :      625018 :     goto function0;
    3740                 :             : 
    3741                 :     2557206 :   if (sym->attr.generic)
    3742                 :       67525 :     goto generic_function;
    3743                 :             : 
    3744                 :     2489681 :   switch (sym->attr.flavor)
    3745                 :             :     {
    3746                 :     1167687 :     case FL_VARIABLE:
    3747                 :     1167687 :     variable:
    3748                 :     1167687 :       e = gfc_get_expr ();
    3749                 :             : 
    3750                 :     1167687 :       e->expr_type = EXPR_VARIABLE;
    3751                 :     1167687 :       e->symtree = symtree;
    3752                 :             : 
    3753                 :     1167687 :       m = gfc_match_varspec (e, 0, false, true);
    3754                 :     1167687 :       break;
    3755                 :             : 
    3756                 :      189978 :     case FL_PARAMETER:
    3757                 :             :       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
    3758                 :             :          end up here.  Unfortunately, sym->value->expr_type is set to
    3759                 :             :          EXPR_CONSTANT, and so the if () branch would be followed without
    3760                 :             :          the !sym->as check.  */
    3761                 :      189978 :       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
    3762                 :      164614 :         e = gfc_copy_expr (sym->value);
    3763                 :             :       else
    3764                 :             :         {
    3765                 :       25364 :           e = gfc_get_expr ();
    3766                 :       25364 :           e->expr_type = EXPR_VARIABLE;
    3767                 :             :         }
    3768                 :             : 
    3769                 :      189978 :       e->symtree = symtree;
    3770                 :      189978 :       m = gfc_match_varspec (e, 0, false, true);
    3771                 :             : 
    3772                 :      189978 :       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
    3773                 :             :         break;
    3774                 :             : 
    3775                 :             :       /* Variable array references to derived type parameters cause
    3776                 :             :          all sorts of headaches in simplification. Treating such
    3777                 :             :          expressions as variable works just fine for all array
    3778                 :             :          references.  */
    3779                 :      147642 :       if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
    3780                 :             :         {
    3781                 :        2489 :           for (ref = e->ref; ref; ref = ref->next)
    3782                 :        2303 :             if (ref->type == REF_ARRAY)
    3783                 :             :               break;
    3784                 :             : 
    3785                 :        2270 :           if (ref == NULL || ref->u.ar.type == AR_FULL)
    3786                 :             :             break;
    3787                 :             : 
    3788                 :         863 :           ref = e->ref;
    3789                 :         863 :           e->ref = NULL;
    3790                 :         863 :           gfc_free_expr (e);
    3791                 :         863 :           e = gfc_get_expr ();
    3792                 :         863 :           e->expr_type = EXPR_VARIABLE;
    3793                 :         863 :           e->symtree = symtree;
    3794                 :         863 :           e->ref = ref;
    3795                 :             :         }
    3796                 :             : 
    3797                 :             :       break;
    3798                 :             : 
    3799                 :           0 :     case FL_STRUCT:
    3800                 :           0 :     case FL_DERIVED:
    3801                 :           0 :       sym = gfc_use_derived (sym);
    3802                 :           0 :       if (sym == NULL)
    3803                 :             :         m = MATCH_ERROR;
    3804                 :             :       else
    3805                 :           0 :         goto generic_function;
    3806                 :             :       break;
    3807                 :             : 
    3808                 :             :     /* If we're here, then the name is known to be the name of a
    3809                 :             :        procedure, yet it is not sure to be the name of a function.  */
    3810                 :      882555 :     case FL_PROCEDURE:
    3811                 :             : 
    3812                 :             :     /* Procedure Pointer Assignments.  */
    3813                 :      882555 :     procptr0:
    3814                 :      882555 :       if (gfc_matching_procptr_assignment)
    3815                 :             :         {
    3816                 :        1285 :           gfc_gobble_whitespace ();
    3817                 :        1285 :           if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
    3818                 :             :             /* Parse functions returning a procptr.  */
    3819                 :         197 :             goto function0;
    3820                 :             : 
    3821                 :        1088 :           e = gfc_get_expr ();
    3822                 :        1088 :           e->expr_type = EXPR_VARIABLE;
    3823                 :        1088 :           e->symtree = symtree;
    3824                 :        1088 :           m = gfc_match_varspec (e, 0, false, true);
    3825                 :        1021 :           if (!e->ref && sym->attr.flavor == FL_UNKNOWN
    3826                 :         182 :               && sym->ts.type == BT_UNKNOWN
    3827                 :        1260 :               && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
    3828                 :             :             {
    3829                 :             :               m = MATCH_ERROR;
    3830                 :             :               break;
    3831                 :             :             }
    3832                 :             :           break;
    3833                 :             :         }
    3834                 :             : 
    3835                 :      881270 :       if (sym->attr.subroutine)
    3836                 :             :         {
    3837                 :          57 :           gfc_error ("Unexpected use of subroutine name %qs at %C",
    3838                 :             :                      sym->name);
    3839                 :          57 :           m = MATCH_ERROR;
    3840                 :          57 :           break;
    3841                 :             :         }
    3842                 :             : 
    3843                 :             :       /* At this point, the name has to be a non-statement function.
    3844                 :             :          If the name is the same as the current function being
    3845                 :             :          compiled, then we have a variable reference (to the function
    3846                 :             :          result) if the name is non-recursive.  */
    3847                 :             : 
    3848                 :      881213 :       st = gfc_enclosing_unit (NULL);
    3849                 :             : 
    3850                 :      881213 :       if (st != NULL
    3851                 :      839884 :           && st->state == COMP_FUNCTION
    3852                 :       74700 :           && st->sym == sym
    3853                 :           0 :           && !sym->attr.recursive)
    3854                 :             :         {
    3855                 :           0 :           e = gfc_get_expr ();
    3856                 :           0 :           e->symtree = symtree;
    3857                 :           0 :           e->expr_type = EXPR_VARIABLE;
    3858                 :             : 
    3859                 :           0 :           m = gfc_match_varspec (e, 0, false, true);
    3860                 :           0 :           break;
    3861                 :             :         }
    3862                 :             : 
    3863                 :             :     /* Match a function reference.  */
    3864                 :      881213 :     function0:
    3865                 :     1506428 :       m = gfc_match_actual_arglist (0, &actual_arglist);
    3866                 :     1506428 :       if (m == MATCH_NO)
    3867                 :             :         {
    3868                 :      527114 :           if (sym->attr.proc == PROC_ST_FUNCTION)
    3869                 :           1 :             gfc_error ("Statement function %qs requires argument list at %C",
    3870                 :             :                        sym->name);
    3871                 :             :           else
    3872                 :      527113 :             gfc_error ("Function %qs requires an argument list at %C",
    3873                 :             :                        sym->name);
    3874                 :             : 
    3875                 :             :           m = MATCH_ERROR;
    3876                 :             :           break;
    3877                 :             :         }
    3878                 :             : 
    3879                 :      979314 :       if (m != MATCH_YES)
    3880                 :             :         {
    3881                 :             :           m = MATCH_ERROR;
    3882                 :             :           break;
    3883                 :             :         }
    3884                 :             : 
    3885                 :      950561 :       gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
    3886                 :      950561 :       sym = symtree->n.sym;
    3887                 :             : 
    3888                 :      950561 :       replace_hidden_procptr_result (&sym, &symtree);
    3889                 :             : 
    3890                 :      950561 :       e = gfc_get_expr ();
    3891                 :      950561 :       e->symtree = symtree;
    3892                 :      950561 :       e->expr_type = EXPR_FUNCTION;
    3893                 :      950561 :       e->value.function.actual = actual_arglist;
    3894                 :      950561 :       e->where = gfc_current_locus;
    3895                 :             : 
    3896                 :      950561 :       if (sym->ts.type == BT_CLASS && sym->attr.class_ok
    3897                 :         192 :           && CLASS_DATA (sym)->as)
    3898                 :          77 :         e->rank = CLASS_DATA (sym)->as->rank;
    3899                 :      950484 :       else if (sym->as != NULL)
    3900                 :        1023 :         e->rank = sym->as->rank;
    3901                 :             : 
    3902                 :      950561 :       if (!sym->attr.function
    3903                 :      950561 :           && !gfc_add_function (&sym->attr, sym->name, NULL))
    3904                 :             :         {
    3905                 :             :           m = MATCH_ERROR;
    3906                 :             :           break;
    3907                 :             :         }
    3908                 :             : 
    3909                 :             :       /* Check here for the existence of at least one argument for the
    3910                 :             :          iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
    3911                 :             :          argument(s) given will be checked in gfc_iso_c_func_interface,
    3912                 :             :          during resolution of the function call.  */
    3913                 :      950561 :       if (sym->attr.is_iso_c == 1
    3914                 :           2 :           && (sym->from_intmod == INTMOD_ISO_C_BINDING
    3915                 :           2 :               && (sym->intmod_sym_id == ISOCBINDING_LOC
    3916                 :             :                   || sym->intmod_sym_id == ISOCBINDING_FUNLOC
    3917                 :           2 :                   || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
    3918                 :             :         {
    3919                 :             :           /* make sure we were given a param */
    3920                 :           0 :           if (actual_arglist == NULL)
    3921                 :             :             {
    3922                 :           0 :               gfc_error ("Missing argument to %qs at %C", sym->name);
    3923                 :           0 :               m = MATCH_ERROR;
    3924                 :           0 :               break;
    3925                 :             :             }
    3926                 :             :         }
    3927                 :             : 
    3928                 :      950561 :       if (sym->result == NULL)
    3929                 :      332672 :         sym->result = sym;
    3930                 :             : 
    3931                 :      950561 :       gfc_gobble_whitespace ();
    3932                 :             :       /* F08:C612.  */
    3933                 :      950561 :       if (gfc_peek_ascii_char() == '%')
    3934                 :             :         {
    3935                 :          12 :           gfc_error ("The leftmost part-ref in a data-ref cannot be a "
    3936                 :             :                      "function reference at %C");
    3937                 :          12 :           m = MATCH_ERROR;
    3938                 :          12 :           break;
    3939                 :             :         }
    3940                 :             : 
    3941                 :             :       m = MATCH_YES;
    3942                 :             :       break;
    3943                 :             : 
    3944                 :      251005 :     case FL_UNKNOWN:
    3945                 :             : 
    3946                 :             :       /* Special case for derived type variables that get their types
    3947                 :             :          via an IMPLICIT statement.  This can't wait for the
    3948                 :             :          resolution phase.  */
    3949                 :             : 
    3950                 :      251005 :       old_loc = gfc_current_locus;
    3951                 :      251005 :       if (gfc_match_member_sep (sym) == MATCH_YES
    3952                 :        8993 :           && sym->ts.type == BT_UNKNOWN
    3953                 :      251010 :           && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
    3954                 :           0 :         gfc_set_default_type (sym, 0, sym->ns);
    3955                 :      251005 :       gfc_current_locus = old_loc;
    3956                 :             : 
    3957                 :             :       /* If the symbol has a (co)dimension attribute, the expression is a
    3958                 :             :          variable.  */
    3959                 :             : 
    3960                 :      251005 :       if (sym->attr.dimension || sym->attr.codimension)
    3961                 :             :         {
    3962                 :       32216 :           if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
    3963                 :             :             {
    3964                 :             :               m = MATCH_ERROR;
    3965                 :             :               break;
    3966                 :             :             }
    3967                 :             : 
    3968                 :       32216 :           e = gfc_get_expr ();
    3969                 :       32216 :           e->symtree = symtree;
    3970                 :       32216 :           e->expr_type = EXPR_VARIABLE;
    3971                 :       32216 :           m = gfc_match_varspec (e, 0, false, true);
    3972                 :       32216 :           break;
    3973                 :             :         }
    3974                 :             : 
    3975                 :      218789 :       if (sym->ts.type == BT_CLASS && sym->attr.class_ok
    3976                 :        4263 :           && (CLASS_DATA (sym)->attr.dimension
    3977                 :        4263 :               || CLASS_DATA (sym)->attr.codimension))
    3978                 :             :         {
    3979                 :        1354 :           if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
    3980                 :             :             {
    3981                 :             :               m = MATCH_ERROR;
    3982                 :             :               break;
    3983                 :             :             }
    3984                 :             : 
    3985                 :        1354 :           e = gfc_get_expr ();
    3986                 :        1354 :           e->symtree = symtree;
    3987                 :        1354 :           e->expr_type = EXPR_VARIABLE;
    3988                 :        1354 :           m = gfc_match_varspec (e, 0, false, true);
    3989                 :        1354 :           break;
    3990                 :             :         }
    3991                 :             : 
    3992                 :             :       /* Name is not an array, so we peek to see if a '(' implies a
    3993                 :             :          function call or a substring reference.  Otherwise the
    3994                 :             :          variable is just a scalar.  */
    3995                 :             : 
    3996                 :      217435 :       gfc_gobble_whitespace ();
    3997                 :      217435 :       if (gfc_peek_ascii_char () != '(')
    3998                 :             :         {
    3999                 :             :           /* Assume a scalar variable */
    4000                 :       69159 :           e = gfc_get_expr ();
    4001                 :       69159 :           e->symtree = symtree;
    4002                 :       69159 :           e->expr_type = EXPR_VARIABLE;
    4003                 :             : 
    4004                 :       69159 :           if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
    4005                 :             :             {
    4006                 :             :               m = MATCH_ERROR;
    4007                 :             :               break;
    4008                 :             :             }
    4009                 :             : 
    4010                 :             :           /*FIXME:??? gfc_match_varspec does set this for us: */
    4011                 :       69159 :           e->ts = sym->ts;
    4012                 :       69159 :           m = gfc_match_varspec (e, 0, false, true);
    4013                 :       69159 :           break;
    4014                 :             :         }
    4015                 :             : 
    4016                 :             :       /* See if this is a function reference with a keyword argument
    4017                 :             :          as first argument. We do this because otherwise a spurious
    4018                 :             :          symbol would end up in the symbol table.  */
    4019                 :             : 
    4020                 :      148276 :       old_loc = gfc_current_locus;
    4021                 :      148276 :       m2 = gfc_match (" ( %n =", argname);
    4022                 :      148276 :       gfc_current_locus = old_loc;
    4023                 :             : 
    4024                 :      148276 :       e = gfc_get_expr ();
    4025                 :      148276 :       e->symtree = symtree;
    4026                 :             : 
    4027                 :      148276 :       if (m2 != MATCH_YES)
    4028                 :             :         {
    4029                 :             :           /* Try to figure out whether we're dealing with a character type.
    4030                 :             :              We're peeking ahead here, because we don't want to call
    4031                 :             :              match_substring if we're dealing with an implicitly typed
    4032                 :             :              non-character variable.  */
    4033                 :      147230 :           implicit_char = false;
    4034                 :      147230 :           if (sym->ts.type == BT_UNKNOWN)
    4035                 :             :             {
    4036                 :      142522 :               ts = gfc_get_default_type (sym->name, NULL);
    4037                 :      142522 :               if (ts->type == BT_CHARACTER)
    4038                 :             :                 implicit_char = true;
    4039                 :             :             }
    4040                 :             : 
    4041                 :             :           /* See if this could possibly be a substring reference of a name
    4042                 :             :              that we're not sure is a variable yet.  */
    4043                 :             : 
    4044                 :      147213 :           if ((implicit_char || sym->ts.type == BT_CHARACTER)
    4045                 :        1330 :               && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
    4046                 :             :             {
    4047                 :             : 
    4048                 :         866 :               e->expr_type = EXPR_VARIABLE;
    4049                 :             : 
    4050                 :         866 :               if (sym->attr.flavor != FL_VARIABLE
    4051                 :         866 :                   && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
    4052                 :             :                                       sym->name, NULL))
    4053                 :             :                 {
    4054                 :             :                   m = MATCH_ERROR;
    4055                 :             :                   break;
    4056                 :             :                 }
    4057                 :             : 
    4058                 :         866 :               if (sym->ts.type == BT_UNKNOWN
    4059                 :         866 :                   && !gfc_set_default_type (sym, 1, NULL))
    4060                 :             :                 {
    4061                 :             :                   m = MATCH_ERROR;
    4062                 :             :                   break;
    4063                 :             :                 }
    4064                 :             : 
    4065                 :         866 :               e->ts = sym->ts;
    4066                 :         866 :               if (e->ref)
    4067                 :         841 :                 e->ts.u.cl = NULL;
    4068                 :             :               m = MATCH_YES;
    4069                 :             :               break;
    4070                 :             :             }
    4071                 :             :         }
    4072                 :             : 
    4073                 :             :       /* Give up, assume we have a function.  */
    4074                 :             : 
    4075                 :      147410 :       gfc_get_sym_tree (name, NULL, &symtree, false);       /* Can't fail */
    4076                 :      147410 :       sym = symtree->n.sym;
    4077                 :      147410 :       e->expr_type = EXPR_FUNCTION;
    4078                 :             : 
    4079                 :      147410 :       if (!sym->attr.function
    4080                 :      147410 :           && !gfc_add_function (&sym->attr, sym->name, NULL))
    4081                 :             :         {
    4082                 :             :           m = MATCH_ERROR;
    4083                 :             :           break;
    4084                 :             :         }
    4085                 :             : 
    4086                 :      147410 :       sym->result = sym;
    4087                 :             : 
    4088                 :      147410 :       m = gfc_match_actual_arglist (0, &e->value.function.actual);
    4089                 :      147410 :       if (m == MATCH_NO)
    4090                 :           0 :         gfc_error ("Missing argument list in function %qs at %C", sym->name);
    4091                 :             : 
    4092                 :      147410 :       if (m != MATCH_YES)
    4093                 :             :         {
    4094                 :             :           m = MATCH_ERROR;
    4095                 :             :           break;
    4096                 :             :         }
    4097                 :             : 
    4098                 :             :       /* If our new function returns a character, array or structure
    4099                 :             :          type, it might have subsequent references.  */
    4100                 :             : 
    4101                 :      147309 :       m = gfc_match_varspec (e, 0, false, true);
    4102                 :      147309 :       if (m == MATCH_NO)
    4103                 :             :         m = MATCH_YES;
    4104                 :             : 
    4105                 :             :       break;
    4106                 :             : 
    4107                 :       67525 :     generic_function:
    4108                 :             :       /* Look for symbol first; if not found, look for STRUCTURE type symbol
    4109                 :             :          specially. Creates a generic symbol for derived types.  */
    4110                 :       67525 :       gfc_find_sym_tree (name, NULL, 1, &symtree);
    4111                 :       67525 :       if (!symtree)
    4112                 :           0 :         gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
    4113                 :       67525 :       if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
    4114                 :       67525 :         gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
    4115                 :             : 
    4116                 :       67525 :       e = gfc_get_expr ();
    4117                 :       67525 :       e->symtree = symtree;
    4118                 :       67525 :       e->expr_type = EXPR_FUNCTION;
    4119                 :             : 
    4120                 :       67525 :       if (gfc_fl_struct (sym->attr.flavor))
    4121                 :             :         {
    4122                 :           0 :           e->value.function.esym = sym;
    4123                 :           0 :           e->symtree->n.sym->attr.generic = 1;
    4124                 :             :         }
    4125                 :             : 
    4126                 :       67525 :       m = gfc_match_actual_arglist (0, &e->value.function.actual);
    4127                 :       67525 :       break;
    4128                 :             : 
    4129                 :             :     case FL_NAMELIST:
    4130                 :             :       m = MATCH_ERROR;
    4131                 :             :       break;
    4132                 :             : 
    4133                 :           5 :     default:
    4134                 :           5 :       gfc_error ("Symbol at %C is not appropriate for an expression");
    4135                 :           5 :       return MATCH_ERROR;
    4136                 :             :     }
    4137                 :             : 
    4138                 :     1676385 :   if (m == MATCH_YES)
    4139                 :             :     {
    4140                 :     2627598 :       e->where = where;
    4141                 :     2627598 :       *result = e;
    4142                 :             :     }
    4143                 :             :   else
    4144                 :      557665 :     gfc_free_expr (e);
    4145                 :             : 
    4146                 :             :   return m;
    4147                 :             : }
    4148                 :             : 
    4149                 :             : 
    4150                 :             : /* Match a variable, i.e. something that can be assigned to.  This
    4151                 :             :    starts as a symbol, can be a structure component or an array
    4152                 :             :    reference.  It can be a function if the function doesn't have a
    4153                 :             :    separate RESULT variable.  If the symbol has not been previously
    4154                 :             :    seen, we assume it is a variable.
    4155                 :             : 
    4156                 :             :    This function is called by two interface functions:
    4157                 :             :    gfc_match_variable, which has host_flag = 1, and
    4158                 :             :    gfc_match_equiv_variable, with host_flag = 0, to restrict the
    4159                 :             :    match of the symbol to the local scope.  */
    4160                 :             : 
    4161                 :             : static match
    4162                 :     2389482 : match_variable (gfc_expr **result, int equiv_flag, int host_flag)
    4163                 :             : {
    4164                 :     2389482 :   gfc_symbol *sym, *dt_sym;
    4165                 :     2389482 :   gfc_symtree *st;
    4166                 :     2389482 :   gfc_expr *expr;
    4167                 :     2389482 :   locus where, old_loc;
    4168                 :     2389482 :   match m;
    4169                 :             : 
    4170                 :             :   /* Since nothing has any business being an lvalue in a module
    4171                 :             :      specification block, an interface block or a contains section,
    4172                 :             :      we force the changed_symbols mechanism to work by setting
    4173                 :             :      host_flag to 0. This prevents valid symbols that have the name
    4174                 :             :      of keywords, such as 'end', being turned into variables by
    4175                 :             :      failed matching to assignments for, e.g., END INTERFACE.  */
    4176                 :     2389482 :   if (gfc_current_state () == COMP_MODULE
    4177                 :     2389482 :       || gfc_current_state () == COMP_SUBMODULE
    4178                 :             :       || gfc_current_state () == COMP_INTERFACE
    4179                 :             :       || gfc_current_state () == COMP_CONTAINS)
    4180                 :      167337 :     host_flag = 0;
    4181                 :             : 
    4182                 :     2389482 :   where = gfc_current_locus;
    4183                 :     2389482 :   m = gfc_match_sym_tree (&st, host_flag);
    4184                 :     2389481 :   if (m != MATCH_YES)
    4185                 :             :     return m;
    4186                 :             : 
    4187                 :     2389457 :   sym = st->n.sym;
    4188                 :             : 
    4189                 :             :   /* If this is an implicit do loop index and implicitly typed,
    4190                 :             :      it should not be host associated.  */
    4191                 :     2389457 :   m = check_for_implicit_index (&st, &sym);
    4192                 :     2389457 :   if (m != MATCH_YES)
    4193                 :             :     return m;
    4194                 :             : 
    4195                 :     2389457 :   sym->attr.implied_index = 0;
    4196                 :             : 
    4197                 :     2389457 :   gfc_set_sym_referenced (sym);
    4198                 :             : 
    4199                 :             :   /* STRUCTUREs may share names with variables, but derived types may not.  */
    4200                 :       12963 :   if (sym->attr.flavor == FL_PROCEDURE && sym->generic
    4201                 :     2389523 :       && (dt_sym = gfc_find_dt_in_generic (sym)))
    4202                 :             :     {
    4203                 :           5 :       if (dt_sym->attr.flavor == FL_DERIVED)
    4204                 :           5 :         gfc_error ("Derived type %qs cannot be used as a variable at %C",
    4205                 :             :                    sym->name);
    4206                 :           5 :       return MATCH_ERROR;
    4207                 :             :     }
    4208                 :             : 
    4209                 :     2389452 :   switch (sym->attr.flavor)
    4210                 :             :     {
    4211                 :             :     case FL_VARIABLE:
    4212                 :             :       /* Everything is alright.  */
    4213                 :             :       break;
    4214                 :             : 
    4215                 :     2216436 :     case FL_UNKNOWN:
    4216                 :     2216436 :       {
    4217                 :     2216436 :         sym_flavor flavor = FL_UNKNOWN;
    4218                 :             : 
    4219                 :     2216436 :         gfc_gobble_whitespace ();
    4220                 :             : 
    4221                 :     2216436 :         if (sym->attr.external || sym->attr.procedure
    4222                 :     2216436 :             || sym->attr.function || sym->attr.subroutine)
    4223                 :             :           flavor = FL_PROCEDURE;
    4224                 :             : 
    4225                 :             :         /* If it is not a procedure, is not typed and is host associated,
    4226                 :             :            we cannot give it a flavor yet.  */
    4227                 :     2216404 :         else if (sym->ns == gfc_current_ns->parent
    4228                 :        2363 :                    && sym->ts.type == BT_UNKNOWN)
    4229                 :             :           break;
    4230                 :             : 
    4231                 :             :         /* These are definitive indicators that this is a variable.  */
    4232                 :     2945804 :         else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
    4233                 :     2929930 :                  || sym->attr.pointer || sym->as != NULL)
    4234                 :             :           flavor = FL_VARIABLE;
    4235                 :             : 
    4236                 :             :         if (flavor != FL_UNKNOWN
    4237                 :     1503514 :             && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
    4238                 :             :           return MATCH_ERROR;
    4239                 :             :       }
    4240                 :             :       break;
    4241                 :             : 
    4242                 :          17 :     case FL_PARAMETER:
    4243                 :          17 :       if (equiv_flag)
    4244                 :             :         {
    4245                 :           0 :           gfc_error ("Named constant at %C in an EQUIVALENCE");
    4246                 :           0 :           return MATCH_ERROR;
    4247                 :             :         }
    4248                 :          17 :       if (gfc_in_match_data())
    4249                 :             :         {
    4250                 :           4 :           gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %C",
    4251                 :             :                       sym->name);
    4252                 :           4 :           return MATCH_ERROR;
    4253                 :             :         }
    4254                 :             :         /* Otherwise this is checked for an error given in the
    4255                 :             :            variable definition context checks.  */
    4256                 :             :       break;
    4257                 :             : 
    4258                 :       12958 :     case FL_PROCEDURE:
    4259                 :             :       /* Check for a nonrecursive function result variable.  */
    4260                 :       12958 :       if (sym->attr.function
    4261                 :       12958 :           && !sym->attr.external
    4262                 :       10940 :           && sym->result == sym
    4263                 :       23611 :           && (gfc_is_function_return_value (sym, gfc_current_ns)
    4264                 :        1917 :               || (sym->attr.entry
    4265                 :         467 :                   && sym->ns == gfc_current_ns)
    4266                 :        1457 :               || (sym->attr.entry
    4267                 :           7 :                   && sym->ns == gfc_current_ns->parent)))
    4268                 :             :         {
    4269                 :             :           /* If a function result is a derived type, then the derived
    4270                 :             :              type may still have to be resolved.  */
    4271                 :             : 
    4272                 :        9203 :           if (sym->ts.type == BT_DERIVED
    4273                 :        9203 :               && gfc_use_derived (sym->ts.u.derived) == NULL)
    4274                 :             :             return MATCH_ERROR;
    4275                 :             :           break;
    4276                 :             :         }
    4277                 :             : 
    4278                 :        3755 :       if (sym->attr.proc_pointer
    4279                 :        3755 :           || replace_hidden_procptr_result (&sym, &st))
    4280                 :             :         break;
    4281                 :             : 
    4282                 :             :       /* Fall through to error */
    4283                 :        2140 :       gcc_fallthrough ();
    4284                 :             : 
    4285                 :        2140 :     default:
    4286                 :        2140 :       gfc_error ("%qs at %C is not a variable", sym->name);
    4287                 :        2140 :       return MATCH_ERROR;
    4288                 :             :     }
    4289                 :             : 
    4290                 :             :   /* Special case for derived type variables that get their types
    4291                 :             :      via an IMPLICIT statement.  This can't wait for the
    4292                 :             :      resolution phase.  */
    4293                 :             : 
    4294                 :     2387304 :     {
    4295                 :     2387304 :       gfc_namespace * implicit_ns;
    4296                 :             : 
    4297                 :     2387304 :       if (gfc_current_ns->proc_name == sym)
    4298                 :             :         implicit_ns = gfc_current_ns;
    4299                 :             :       else
    4300                 :     2378888 :         implicit_ns = sym->ns;
    4301                 :             : 
    4302                 :     2387304 :       old_loc = gfc_current_locus;
    4303                 :     2387304 :       if (gfc_match_member_sep (sym) == MATCH_YES
    4304                 :       17627 :           && sym->ts.type == BT_UNKNOWN
    4305                 :     2387316 :           && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
    4306                 :           3 :         gfc_set_default_type (sym, 0, implicit_ns);
    4307                 :     2387304 :       gfc_current_locus = old_loc;
    4308                 :             :     }
    4309                 :             : 
    4310                 :     2387304 :   expr = gfc_get_expr ();
    4311                 :             : 
    4312                 :     2387304 :   expr->expr_type = EXPR_VARIABLE;
    4313                 :     2387304 :   expr->symtree = st;
    4314                 :     2387304 :   expr->ts = sym->ts;
    4315                 :     2387304 :   expr->where = where;
    4316                 :             : 
    4317                 :             :   /* Now see if we have to do more.  */
    4318                 :     2387304 :   m = gfc_match_varspec (expr, equiv_flag, false, false);
    4319                 :     2387304 :   if (m != MATCH_YES)
    4320                 :             :     {
    4321                 :          79 :       gfc_free_expr (expr);
    4322                 :          79 :       return m;
    4323                 :             :     }
    4324                 :             : 
    4325                 :     2387225 :   *result = expr;
    4326                 :     2387225 :   return MATCH_YES;
    4327                 :             : }
    4328                 :             : 
    4329                 :             : 
    4330                 :             : match
    4331                 :     2386507 : gfc_match_variable (gfc_expr **result, int equiv_flag)
    4332                 :             : {
    4333                 :     2386507 :   return match_variable (result, equiv_flag, 1);
    4334                 :             : }
    4335                 :             : 
    4336                 :             : 
    4337                 :             : match
    4338                 :        2975 : gfc_match_equiv_variable (gfc_expr **result)
    4339                 :             : {
    4340                 :        2975 :   return match_variable (result, 1, 0);
    4341                 :             : }
    4342                 :             : 
        

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.