LCOV - code coverage report
Current view: top level - gcc/fortran - primary.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 1864 2004 93.0 %
Date: 2020-03-28 11:57:23 Functions: 43 43 100.0 %
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-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Andy Vaught
       4                 :            : 
       5                 :            : This file is part of GCC.
       6                 :            : 
       7                 :            : GCC is free software; you can redistribute it and/or modify it under
       8                 :            : the terms of the GNU General Public License as published by the Free
       9                 :            : Software Foundation; either version 3, or (at your option) any later
      10                 :            : version.
      11                 :            : 
      12                 :            : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :            : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :            : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :            : for more details.
      16                 :            : 
      17                 :            : You should have received a copy of the GNU General Public License
      18                 :            : along with GCC; see the file COPYING3.  If not see
      19                 :            : <http://www.gnu.org/licenses/>.  */
      20                 :            : 
      21                 :            : #include "config.h"
      22                 :            : #include "system.h"
      23                 :            : #include "coretypes.h"
      24                 :            : #include "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                 :     340460 : match_kind_param (int *kind, int *is_iso_c)
      41                 :            : {
      42                 :     340460 :   char name[GFC_MAX_SYMBOL_LEN + 1];
      43                 :     340460 :   gfc_symbol *sym;
      44                 :     340460 :   match m;
      45                 :            : 
      46                 :     340460 :   *is_iso_c = 0;
      47                 :            : 
      48                 :     340460 :   m = gfc_match_small_literal_int (kind, NULL);
      49                 :     340460 :   if (m != MATCH_NO)
      50                 :            :     return m;
      51                 :            : 
      52                 :      62438 :   m = gfc_match_name (name);
      53                 :      62438 :   if (m != MATCH_YES)
      54                 :            :     return m;
      55                 :            : 
      56                 :      60710 :   if (gfc_find_symbol (name, NULL, 1, &sym))
      57                 :            :     return MATCH_ERROR;
      58                 :            : 
      59                 :      60710 :   if (sym == NULL)
      60                 :            :     return MATCH_NO;
      61                 :            : 
      62                 :      60709 :   *is_iso_c = sym->attr.is_iso_c;
      63                 :            : 
      64                 :      60709 :   if (sym->attr.flavor != FL_PARAMETER)
      65                 :            :     return MATCH_NO;
      66                 :            : 
      67                 :      60709 :   if (sym->value == NULL)
      68                 :            :     return MATCH_NO;
      69                 :            : 
      70                 :      60708 :   if (gfc_extract_int (sym->value, kind))
      71                 :            :     return MATCH_NO;
      72                 :            : 
      73                 :      60708 :   gfc_set_sym_referenced (sym);
      74                 :            : 
      75                 :      60708 :   if (*kind < 0)
      76                 :          0 :     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                 :    3020240 : get_kind (int *is_iso_c)
      92                 :            : {
      93                 :    3020240 :   int kind;
      94                 :    3020240 :   match m;
      95                 :            : 
      96                 :    3020240 :   *is_iso_c = 0;
      97                 :            : 
      98                 :    3020240 :   if (gfc_match_char ('_') != MATCH_YES)
      99                 :            :     return -2;
     100                 :            : 
     101                 :     340460 :   m = match_kind_param (&kind, is_iso_c);
     102                 :     340460 :   if (m == MATCH_NO)
     103                 :       1730 :     gfc_error ("Missing kind-parameter at %C");
     104                 :            : 
     105                 :     340460 :   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                 :            : int
     113                 :   18760900 : gfc_check_digit (char c, int radix)
     114                 :            : {
     115                 :   18760900 :   int r;
     116                 :            : 
     117                 :   18760900 :   switch (radix)
     118                 :            :     {
     119                 :      14978 :     case 2:
     120                 :      14978 :       r = ('0' <= c && c <= '1');
     121                 :      14978 :       break;
     122                 :            : 
     123                 :       4650 :     case 8:
     124                 :       4650 :       r = ('0' <= c && c <= '7');
     125                 :       4650 :       break;
     126                 :            : 
     127                 :   18681300 :     case 10:
     128                 :   18681300 :       r = ('0' <= c && c <= '9');
     129                 :   18681300 :       break;
     130                 :            : 
     131                 :      59963 :     case 16:
     132                 :      59963 :       r = ISXDIGIT (c);
     133                 :      59963 :       break;
     134                 :            : 
     135                 :          0 :     default:
     136                 :          0 :       gfc_internal_error ("gfc_check_digit(): bad radix");
     137                 :            :     }
     138                 :            : 
     139                 :   18760900 :   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                 :   10890800 : match_digits (int signflag, int radix, char *buffer)
     150                 :            : {
     151                 :   10890800 :   locus old_loc;
     152                 :   10890800 :   int length;
     153                 :   10890800 :   char c;
     154                 :            : 
     155                 :   10890800 :   length = 0;
     156                 :   10890800 :   c = gfc_next_ascii_char ();
     157                 :            : 
     158                 :   10890800 :   if (signflag && (c == '+' || c == '-'))
     159                 :            :     {
     160                 :       4580 :       if (buffer != NULL)
     161                 :       1759 :         *buffer++ = c;
     162                 :       4580 :       gfc_gobble_whitespace ();
     163                 :       4580 :       c = gfc_next_ascii_char ();
     164                 :       4580 :       length++;
     165                 :            :     }
     166                 :            : 
     167                 :   10890800 :   if (!gfc_check_digit (c, radix))
     168                 :            :     return -1;
     169                 :            : 
     170                 :    5665040 :   length++;
     171                 :    5665040 :   if (buffer != NULL)
     172                 :    2832520 :     *buffer++ = c;
     173                 :            : 
     174                 :   10025200 :   for (;;)
     175                 :            :     {
     176                 :    7845140 :       old_loc = gfc_current_locus;
     177                 :    7845140 :       c = gfc_next_ascii_char ();
     178                 :            : 
     179                 :    7845140 :       if (!gfc_check_digit (c, radix))
     180                 :            :         break;
     181                 :            : 
     182                 :    2180100 :       if (buffer != NULL)
     183                 :    1090050 :         *buffer++ = c;
     184                 :    2180100 :       length++;
     185                 :            :     }
     186                 :            : 
     187                 :    5665040 :   gfc_current_locus = old_loc;
     188                 :            : 
     189                 :    5665040 :   return length;
     190                 :            : }
     191                 :            : 
     192                 :            : /* Convert an integer string to an expression node.  */
     193                 :            : 
     194                 :            : static gfc_expr *
     195                 :    2827590 : convert_integer (const char *buffer, int kind, int radix, locus *where)
     196                 :            : {
     197                 :    2827590 :   gfc_expr *e;
     198                 :    2827590 :   const char *t;
     199                 :            : 
     200                 :    2827590 :   e = gfc_get_constant_expr (BT_INTEGER, kind, where);
     201                 :            :   /* A leading plus is allowed, but not by mpz_set_str.  */
     202                 :    2827590 :   if (buffer[0] == '+')
     203                 :         21 :     t = buffer + 1;
     204                 :            :   else
     205                 :            :     t = buffer;
     206                 :    2827590 :   mpz_set_str (e->value.integer, t, radix);
     207                 :            : 
     208                 :    2827590 :   return e;
     209                 :            : }
     210                 :            : 
     211                 :            : 
     212                 :            : /* Convert a real string to an expression node.  */
     213                 :            : 
     214                 :            : static gfc_expr *
     215                 :     159309 : convert_real (const char *buffer, int kind, locus *where)
     216                 :            : {
     217                 :     159309 :   gfc_expr *e;
     218                 :            : 
     219                 :     159309 :   e = gfc_get_constant_expr (BT_REAL, kind, where);
     220                 :     159309 :   mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
     221                 :            : 
     222                 :     159309 :   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                 :       5930 : convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
     231                 :            : {
     232                 :       5930 :   gfc_expr *e;
     233                 :            : 
     234                 :       5930 :   e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
     235                 :       5930 :   mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
     236                 :            :                  GFC_MPC_RND_MODE);
     237                 :            : 
     238                 :       5930 :   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                 :    8055040 : match_integer_constant (gfc_expr **result, int signflag)
     247                 :            : {
     248                 :    8055040 :   int length, kind, is_iso_c;
     249                 :    8055040 :   locus old_loc;
     250                 :    8055040 :   char *buffer;
     251                 :    8055040 :   gfc_expr *e;
     252                 :            : 
     253                 :    8055040 :   old_loc = gfc_current_locus;
     254                 :    8055040 :   gfc_gobble_whitespace ();
     255                 :            : 
     256                 :    8055040 :   length = match_digits (signflag, 10, NULL);
     257                 :    8055040 :   gfc_current_locus = old_loc;
     258                 :    8055040 :   if (length == -1)
     259                 :            :     return MATCH_NO;
     260                 :            : 
     261                 :    2829320 :   buffer = (char *) alloca (length + 1);
     262                 :    2829320 :   memset (buffer, '\0', length + 1);
     263                 :            : 
     264                 :    2829320 :   gfc_gobble_whitespace ();
     265                 :            : 
     266                 :    2829320 :   match_digits (signflag, 10, buffer);
     267                 :            : 
     268                 :    2829320 :   kind = get_kind (&is_iso_c);
     269                 :    2829320 :   if (kind == -2)
     270                 :    2538150 :     kind = gfc_default_integer_kind;
     271                 :    2829320 :   if (kind == -1)
     272                 :            :     return MATCH_ERROR;
     273                 :            : 
     274                 :    2827590 :   if (kind == 4 && flag_integer4_kind == 8)
     275                 :          0 :     kind = 8;
     276                 :            : 
     277                 :    2827590 :   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                 :    2827590 :   e = convert_integer (buffer, kind, 10, &gfc_current_locus);
     284                 :    2827590 :   e->ts.is_c_interop = is_iso_c;
     285                 :            : 
     286                 :    2827590 :   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                 :    2827590 :   *result = e;
     296                 :    2827590 :   return MATCH_YES;
     297                 :            : }
     298                 :            : 
     299                 :            : 
     300                 :            : /* Match a Hollerith constant.  */
     301                 :            : 
     302                 :            : static match
     303                 :    3995700 : match_hollerith_constant (gfc_expr **result)
     304                 :            : {
     305                 :    3995700 :   locus old_loc;
     306                 :    3995700 :   gfc_expr *e = NULL;
     307                 :    3995700 :   int num, pad;
     308                 :    3995700 :   int i;
     309                 :            : 
     310                 :    3995700 :   old_loc = gfc_current_locus;
     311                 :    3995700 :   gfc_gobble_whitespace ();
     312                 :            : 
     313                 :    3995700 :   if (match_integer_constant (&e, 0) == MATCH_YES
     314                 :    3995700 :       && gfc_match_char ('h') == MATCH_YES)
     315                 :            :     {
     316                 :       2648 :       if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
     317                 :         17 :         goto cleanup;
     318                 :            : 
     319                 :       2631 :       if (gfc_extract_int (e, &num, 1))
     320                 :          0 :         goto cleanup;
     321                 :       2631 :       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                 :       2630 :       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                 :       2629 :           gfc_free_expr (e);
     336                 :       2629 :           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                 :       2629 :           pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
     341                 :            : 
     342                 :       2629 :           e->representation.string = XCNEWVEC (char, num + pad + 1);
     343                 :            : 
     344                 :      14951 :           for (i = 0; i < num; i++)
     345                 :            :             {
     346                 :      12322 :               gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
     347                 :      12322 :               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                 :      12322 :               e->representation.string[i] = (unsigned char) c;
     355                 :            :             }
     356                 :            : 
     357                 :            :           /* Now pad with blanks and end with a null char.  */
     358                 :      11787 :           for (i = 0; i < pad; i++)
     359                 :       9158 :             e->representation.string[num + i] = ' ';
     360                 :            : 
     361                 :       2629 :           e->representation.string[num + i] = '\0';
     362                 :       2629 :           e->representation.length = num + pad;
     363                 :       2629 :           e->ts.u.pad = pad;
     364                 :            : 
     365                 :       2629 :           *result = e;
     366                 :       2629 :           return MATCH_YES;
     367                 :            :         }
     368                 :            :     }
     369                 :            : 
     370                 :    3993050 :   gfc_free_expr (e);
     371                 :    3993050 :   gfc_current_locus = old_loc;
     372                 :    3993050 :   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                 :    4146060 : match_boz_constant (gfc_expr **result)
     388                 :            : {
     389                 :    4146060 :   int radix, length, x_hex;
     390                 :    4146060 :   locus old_loc, start_loc;
     391                 :    4146060 :   char *buffer, post, delim;
     392                 :    4146060 :   gfc_expr *e;
     393                 :            : 
     394                 :    4146060 :   start_loc = old_loc = gfc_current_locus;
     395                 :    4146060 :   gfc_gobble_whitespace ();
     396                 :            : 
     397                 :    4146060 :   x_hex = 0;
     398                 :    4146060 :   switch (post = gfc_next_ascii_char ())
     399                 :            :     {
     400                 :            :     case 'b':
     401                 :            :       radix = 2;
     402                 :            :       post = 0;
     403                 :            :       break;
     404                 :      29348 :     case 'o':
     405                 :      29348 :       radix = 8;
     406                 :      29348 :       post = 0;
     407                 :      29348 :       break;
     408                 :      37937 :     case 'x':
     409                 :      37937 :       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                 :    3975240 :     default:
     423                 :    3975240 :       goto backup;
     424                 :            :     }
     425                 :            : 
     426                 :            :   /* No whitespace allowed here.  */
     427                 :            : 
     428                 :     170824 :   if (post == 0)
     429                 :     170799 :     delim = gfc_next_ascii_char ();
     430                 :            : 
     431                 :     170824 :   if (delim != '\'' && delim != '\"')
     432                 :     167624 :     goto backup;
     433                 :            : 
     434                 :       3200 :   if (x_hex
     435                 :       3200 :       && gfc_invalid_boz ("Hexadecimal constant at %L uses "
     436                 :            :                           "nonstandard X instead of Z", &gfc_current_locus))
     437                 :            :     return MATCH_ERROR;
     438                 :            : 
     439                 :       3198 :   old_loc = gfc_current_locus;
     440                 :            : 
     441                 :       3198 :   length = match_digits (0, radix, NULL);
     442                 :       3198 :   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                 :       3198 :   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                 :       3198 :   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 ("BOZ constant at %C uses nonstandard postfix "
     474                 :            :                            "syntax", &gfc_current_locus))
     475                 :            :         return MATCH_ERROR;
     476                 :            :     }
     477                 :            : 
     478                 :       3197 :   gfc_current_locus = old_loc;
     479                 :            : 
     480                 :       3197 :   buffer = (char *) alloca (length + 1);
     481                 :       3197 :   memset (buffer, '\0', length + 1);
     482                 :            : 
     483                 :       3197 :   match_digits (0, radix, buffer);
     484                 :       3197 :   gfc_next_ascii_char ();    /* Eat delimiter.  */
     485                 :       3197 :   if (post == 1)
     486                 :         24 :     gfc_next_ascii_char ();  /* Eat postfixed b, o, z, or x.  */
     487                 :            : 
     488                 :       3197 :   e = gfc_get_expr ();
     489                 :       3197 :   e->expr_type = EXPR_CONSTANT;
     490                 :       3197 :   e->ts.type = BT_BOZ;
     491                 :       3197 :   e->where = gfc_current_locus;
     492                 :       3197 :   e->boz.rdx = radix;
     493                 :       3197 :   e->boz.len = length;
     494                 :       3197 :   e->boz.str = XCNEWVEC (char, length + 1);
     495                 :       3197 :   strncpy (e->boz.str, buffer, length);
     496                 :            : 
     497                 :       3197 :   if (!gfc_in_match_data ()
     498                 :       3197 :       && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
     499                 :            :                           "statement at %L", &e->where)))
     500                 :            :     return MATCH_ERROR;
     501                 :            : 
     502                 :       3192 :   *result = e;
     503                 :       3192 :   return MATCH_YES;
     504                 :            : 
     505                 :    4142860 : backup:
     506                 :    4142860 :   gfc_current_locus = start_loc;
     507                 :    4142860 :   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                 :    4221310 : match_real_constant (gfc_expr **result, int signflag)
     516                 :            : {
     517                 :    4221310 :   int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
     518                 :    4221310 :   locus old_loc, temp_loc;
     519                 :    4221310 :   char *p, *buffer, c, exp_char;
     520                 :    4221310 :   gfc_expr *e;
     521                 :    4221310 :   bool negate;
     522                 :            : 
     523                 :    4221310 :   old_loc = gfc_current_locus;
     524                 :    4221310 :   gfc_gobble_whitespace ();
     525                 :            : 
     526                 :    4221310 :   e = NULL;
     527                 :            : 
     528                 :    4221310 :   default_exponent = 0;
     529                 :    4221310 :   count = 0;
     530                 :    4221310 :   seen_dp = 0;
     531                 :    4221310 :   seen_digits = 0;
     532                 :    4221310 :   exp_char = ' ';
     533                 :    4221310 :   negate = FALSE;
     534                 :            : 
     535                 :    4221310 :   c = gfc_next_ascii_char ();
     536                 :    4221310 :   if (signflag && (c == '+' || c == '-'))
     537                 :            :     {
     538                 :       5993 :       if (c == '-')
     539                 :       5861 :         negate = TRUE;
     540                 :            : 
     541                 :       5993 :       gfc_gobble_whitespace ();
     542                 :       5993 :       c = gfc_next_ascii_char ();
     543                 :            :     }
     544                 :            : 
     545                 :            :   /* Scan significand.  */
     546                 :    2534990 :   for (;; c = gfc_next_ascii_char (), count++)
     547                 :            :     {
     548                 :    6756300 :       if (c == '.')
     549                 :            :         {
     550                 :     195012 :           if (seen_dp)
     551                 :        204 :             goto done;
     552                 :            : 
     553                 :            :           /* Check to see if "." goes with a following operator like
     554                 :            :              ".eq.".  */
     555                 :     194808 :           temp_loc = gfc_current_locus;
     556                 :     194808 :           c = gfc_next_ascii_char ();
     557                 :            : 
     558                 :     194808 :           if (c == 'e' || c == 'd' || c == 'q')
     559                 :            :             {
     560                 :       6160 :               c = gfc_next_ascii_char ();
     561                 :       6160 :               if (c == '.')
     562                 :          0 :                 goto done;      /* Operator named .e. or .d.  */
     563                 :            :             }
     564                 :            : 
     565                 :     194808 :           if (ISALPHA (c))
     566                 :      41669 :             goto done;          /* Distinguish 1.e9 from 1.eq.2 */
     567                 :            : 
     568                 :     153139 :           gfc_current_locus = temp_loc;
     569                 :     153139 :           seen_dp = 1;
     570                 :     153139 :           continue;
     571                 :            :         }
     572                 :            : 
     573                 :    6561290 :       if (ISDIGIT (c))
     574                 :            :         {
     575                 :    2381850 :           seen_digits = 1;
     576                 :    2381850 :           continue;
     577                 :            :         }
     578                 :            : 
     579                 :    4179440 :       break;
     580                 :            :     }
     581                 :            : 
     582                 :    4179440 :   if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
     583                 :    4154380 :     goto done;
     584                 :      25055 :   exp_char = c;
     585                 :            : 
     586                 :            : 
     587                 :      25055 :   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                 :      25055 :   c = gfc_next_ascii_char ();
     600                 :      25055 :   count++;
     601                 :            : 
     602                 :      25055 :   if (c == '+' || c == '-')
     603                 :            :     {                           /* optional sign */
     604                 :       6419 :       c = gfc_next_ascii_char ();
     605                 :       6419 :       count++;
     606                 :            :     }
     607                 :            : 
     608                 :      25055 :   if (!ISDIGIT (c))
     609                 :            :     {
     610                 :            :       /* With -fdec, default exponent to 0 instead of complaining.  */
     611                 :         40 :       if (flag_dec)
     612                 :      25045 :         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                 :      52446 :   while (ISDIGIT (c))
     621                 :            :     {
     622                 :      27401 :       c = gfc_next_ascii_char ();
     623                 :      27401 :       count++;
     624                 :            :     }
     625                 :            : 
     626                 :      25045 : done:
     627                 :            :   /* Check that we have a numeric constant.  */
     628                 :    4221300 :   if (!seen_digits || (!seen_dp && exp_char == ' '))
     629                 :            :     {
     630                 :    4061990 :       gfc_current_locus = old_loc;
     631                 :    4061990 :       return MATCH_NO;
     632                 :            :     }
     633                 :            : 
     634                 :            :   /* Convert the number.  */
     635                 :     159311 :   gfc_current_locus = old_loc;
     636                 :     159311 :   gfc_gobble_whitespace ();
     637                 :            : 
     638                 :     159311 :   buffer = (char *) alloca (count + default_exponent + 1);
     639                 :     159311 :   memset (buffer, '\0', count + default_exponent + 1);
     640                 :            : 
     641                 :     159311 :   p = buffer;
     642                 :     159311 :   c = gfc_next_ascii_char ();
     643                 :     159311 :   if (c == '+' || c == '-')
     644                 :            :     {
     645                 :       3172 :       gfc_gobble_whitespace ();
     646                 :       3172 :       c = gfc_next_ascii_char ();
     647                 :            :     }
     648                 :            : 
     649                 :            :   /* Hack for mpfr_set_str().  */
     650                 :    1108670 :   for (;;)
     651                 :            :     {
     652                 :     633989 :       if (c == 'd' || c == 'q')
     653                 :      18069 :         *p = 'e';
     654                 :            :       else
     655                 :     615920 :         *p = c;
     656                 :     633989 :       p++;
     657                 :     633989 :       if (--count == 0)
     658                 :            :         break;
     659                 :            : 
     660                 :     474678 :       c = gfc_next_ascii_char ();
     661                 :            :     }
     662                 :     159311 :   if (default_exponent)
     663                 :         30 :     *p++ = '0';
     664                 :            : 
     665                 :     159311 :   kind = get_kind (&is_iso_c);
     666                 :     159311 :   if (kind == -1)
     667                 :          2 :     goto cleanup;
     668                 :            : 
     669                 :     159309 :   switch (exp_char)
     670                 :            :     {
     671                 :      18069 :     case 'd':
     672                 :      18069 :       if (kind != -2)
     673                 :            :         {
     674                 :          0 :           gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
     675                 :            :                      "kind");
     676                 :          0 :           goto cleanup;
     677                 :            :         }
     678                 :      18069 :       kind = gfc_default_double_kind;
     679                 :            : 
     680                 :      18069 :       if (kind == 4)
     681                 :            :         {
     682                 :          0 :           if (flag_real4_kind == 8)
     683                 :          0 :             kind = 8;
     684                 :          0 :           if (flag_real4_kind == 10)
     685                 :          0 :             kind = 10;
     686                 :          0 :           if (flag_real4_kind == 16)
     687                 :            :             kind = 16;
     688                 :            :         }
     689                 :            : 
     690                 :      18069 :       if (kind == 8)
     691                 :            :         {
     692                 :      18069 :           if (flag_real8_kind == 4)
     693                 :          0 :             kind = 4;
     694                 :      18069 :           if (flag_real8_kind == 10)
     695                 :          0 :             kind = 10;
     696                 :      18069 :           if (flag_real8_kind == 16)
     697                 :          0 :             kind = 16;
     698                 :            :         }
     699                 :            :       break;
     700                 :            : 
     701                 :          0 :     case 'q':
     702                 :          0 :       if (kind != -2)
     703                 :            :         {
     704                 :          0 :           gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
     705                 :            :                      "kind");
     706                 :          0 :           goto cleanup;
     707                 :            :         }
     708                 :            : 
     709                 :            :       /* The maximum possible real kind type parameter is 16.  First, try
     710                 :            :          that for the kind, then fallback to trying kind=10 (Intel 80 bit)
     711                 :            :          extended precision.  If neither value works, just given up.  */
     712                 :          0 :       kind = 16;
     713                 :          0 :       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
     714                 :            :         {
     715                 :          0 :           kind = 10;
     716                 :          0 :           if (gfc_validate_kind (BT_REAL, kind, true) < 0)
     717                 :            :             {
     718                 :          0 :               gfc_error ("Invalid exponent-letter %<q%> in "
     719                 :            :                          "real-literal-constant at %C");
     720                 :          0 :               goto cleanup;
     721                 :            :             }
     722                 :            :         }
     723                 :            :       break;
     724                 :            : 
     725                 :     141240 :     default:
     726                 :     141240 :       if (kind == -2)
     727                 :      92204 :         kind = gfc_default_real_kind;
     728                 :            : 
     729                 :     141240 :       if (kind == 4)
     730                 :            :         {
     731                 :     110855 :           if (flag_real4_kind == 8)
     732                 :          0 :             kind = 8;
     733                 :     110855 :           if (flag_real4_kind == 10)
     734                 :          0 :             kind = 10;
     735                 :     110855 :           if (flag_real4_kind == 16)
     736                 :            :             kind = 16;
     737                 :            :         }
     738                 :            : 
     739                 :     141240 :       if (kind == 8)
     740                 :            :         {
     741                 :      24216 :           if (flag_real8_kind == 4)
     742                 :          0 :             kind = 4;
     743                 :      24216 :           if (flag_real8_kind == 10)
     744                 :          0 :             kind = 10;
     745                 :      24216 :           if (flag_real8_kind == 16)
     746                 :          0 :             kind = 16;
     747                 :            :         }
     748                 :            : 
     749                 :     141240 :       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
     750                 :            :         {
     751                 :          0 :           gfc_error ("Invalid real kind %d at %C", kind);
     752                 :          0 :           goto cleanup;
     753                 :            :         }
     754                 :            :     }
     755                 :            : 
     756                 :     159309 :   e = convert_real (buffer, kind, &gfc_current_locus);
     757                 :     159309 :   if (negate)
     758                 :       3067 :     mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
     759                 :     159309 :   e->ts.is_c_interop = is_iso_c;
     760                 :            : 
     761                 :     159309 :   switch (gfc_range_check (e))
     762                 :            :     {
     763                 :            :     case ARITH_OK:
     764                 :            :       break;
     765                 :          1 :     case ARITH_OVERFLOW:
     766                 :          1 :       gfc_error ("Real constant overflows its kind at %C");
     767                 :          1 :       goto cleanup;
     768                 :            : 
     769                 :          0 :     case ARITH_UNDERFLOW:
     770                 :          0 :       if (warn_underflow)
     771                 :          0 :         gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
     772                 :          0 :       mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
     773                 :          0 :       break;
     774                 :            : 
     775                 :          0 :     default:
     776                 :          0 :       gfc_internal_error ("gfc_range_check() returned bad value");
     777                 :            :     }
     778                 :            : 
     779                 :            :   /* Warn about trailing digits which suggest the user added too many
     780                 :            :      trailing digits, which may cause the appearance of higher pecision
     781                 :            :      than the kind kan support.
     782                 :            : 
     783                 :            :      This is done by replacing the rightmost non-zero digit with zero
     784                 :            :      and comparing with the original value.  If these are equal, we
     785                 :            :      assume the user supplied more digits than intended (or forgot to
     786                 :            :      convert to the correct kind).
     787                 :            :   */
     788                 :            : 
     789                 :     159308 :   if (warn_conversion_extra)
     790                 :            :     {
     791                 :         21 :       mpfr_t r;
     792                 :         21 :       char *c1;
     793                 :         21 :       bool did_break;
     794                 :            : 
     795                 :         21 :       c1 = strchr (buffer, 'e');
     796                 :         21 :       if (c1 == NULL)
     797                 :         18 :         c1 = buffer + strlen(buffer);
     798                 :            : 
     799                 :         30 :       did_break = false;
     800                 :         30 :       for (p = c1; p > buffer;)
     801                 :            :         {
     802                 :         30 :           p--;
     803                 :         30 :           if (*p == '.')
     804                 :          7 :             continue;
     805                 :            : 
     806                 :         23 :           if (*p != '0')
     807                 :            :             {
     808                 :         21 :               *p = '0';
     809                 :         21 :               did_break = true;
     810                 :         21 :               break;
     811                 :            :             }
     812                 :            :         }
     813                 :            : 
     814                 :         21 :       if (did_break)
     815                 :            :         {
     816                 :         21 :           mpfr_init (r);
     817                 :         21 :           mpfr_set_str (r, buffer, 10, GFC_RND_MODE);
     818                 :         21 :           if (negate)
     819                 :          0 :             mpfr_neg (r, r, GFC_RND_MODE);
     820                 :            : 
     821                 :         21 :           mpfr_sub (r, r, e->value.real, GFC_RND_MODE);
     822                 :            : 
     823                 :         21 :           if (mpfr_cmp_ui (r, 0) == 0)
     824                 :          1 :             gfc_warning (OPT_Wconversion_extra, "Non-significant digits "
     825                 :            :                          "in %qs number at %C, maybe incorrect KIND",
     826                 :            :                          gfc_typename (&e->ts));
     827                 :            : 
     828                 :         21 :           mpfr_clear (r);
     829                 :            :         }
     830                 :            :     }
     831                 :            : 
     832                 :     159308 :   *result = e;
     833                 :     159308 :   return MATCH_YES;
     834                 :            : 
     835                 :          3 : cleanup:
     836                 :          3 :   gfc_free_expr (e);
     837                 :          3 :   return MATCH_ERROR;
     838                 :            : }
     839                 :            : 
     840                 :            : 
     841                 :            : /* Match a substring reference.  */
     842                 :            : 
     843                 :            : static match
     844                 :     385349 : match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
     845                 :            : {
     846                 :     385349 :   gfc_expr *start, *end;
     847                 :     385349 :   locus old_loc;
     848                 :     385349 :   gfc_ref *ref;
     849                 :     385349 :   match m;
     850                 :            : 
     851                 :     385349 :   start = NULL;
     852                 :     385349 :   end = NULL;
     853                 :            : 
     854                 :     385349 :   old_loc = gfc_current_locus;
     855                 :            : 
     856                 :     385349 :   m = gfc_match_char ('(');
     857                 :     385349 :   if (m != MATCH_YES)
     858                 :            :     return MATCH_NO;
     859                 :            : 
     860                 :      11369 :   if (gfc_match_char (':') != MATCH_YES)
     861                 :            :     {
     862                 :      10465 :       if (init)
     863                 :          0 :         m = gfc_match_init_expr (&start);
     864                 :            :       else
     865                 :      10465 :         m = gfc_match_expr (&start);
     866                 :            : 
     867                 :      10465 :       if (m != MATCH_YES)
     868                 :            :         {
     869                 :        154 :           m = MATCH_NO;
     870                 :        154 :           goto cleanup;
     871                 :            :         }
     872                 :            : 
     873                 :      10311 :       m = gfc_match_char (':');
     874                 :      10311 :       if (m != MATCH_YES)
     875                 :        453 :         goto cleanup;
     876                 :            :     }
     877                 :            : 
     878                 :      10762 :   if (gfc_match_char (')') != MATCH_YES)
     879                 :            :     {
     880                 :       9897 :       if (init)
     881                 :          0 :         m = gfc_match_init_expr (&end);
     882                 :            :       else
     883                 :       9897 :         m = gfc_match_expr (&end);
     884                 :            : 
     885                 :       9897 :       if (m == MATCH_NO)
     886                 :          2 :         goto syntax;
     887                 :       9895 :       if (m == MATCH_ERROR)
     888                 :          0 :         goto cleanup;
     889                 :            : 
     890                 :       9895 :       m = gfc_match_char (')');
     891                 :       9895 :       if (m == MATCH_NO)
     892                 :          3 :         goto syntax;
     893                 :            :     }
     894                 :            : 
     895                 :            :   /* Optimize away the (:) reference.  */
     896                 :      10757 :   if (start == NULL && end == NULL && !deferred)
     897                 :            :     ref = NULL;
     898                 :            :   else
     899                 :            :     {
     900                 :      10526 :       ref = gfc_get_ref ();
     901                 :            : 
     902                 :      10526 :       ref->type = REF_SUBSTRING;
     903                 :      10526 :       if (start == NULL)
     904                 :        671 :         start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
     905                 :      10526 :       ref->u.ss.start = start;
     906                 :      10526 :       if (end == NULL && cl)
     907                 :        634 :         end = gfc_copy_expr (cl->length);
     908                 :      10526 :       ref->u.ss.end = end;
     909                 :      10526 :       ref->u.ss.length = cl;
     910                 :            :     }
     911                 :            : 
     912                 :      10757 :   *result = ref;
     913                 :      10757 :   return MATCH_YES;
     914                 :            : 
     915                 :          5 : syntax:
     916                 :          5 :   gfc_error ("Syntax error in SUBSTRING specification at %C");
     917                 :          5 :   m = MATCH_ERROR;
     918                 :            : 
     919                 :        612 : cleanup:
     920                 :        612 :   gfc_free_expr (start);
     921                 :        612 :   gfc_free_expr (end);
     922                 :            : 
     923                 :        612 :   gfc_current_locus = old_loc;
     924                 :        612 :   return m;
     925                 :            : }
     926                 :            : 
     927                 :            : 
     928                 :            : /* Reads the next character of a string constant, taking care to
     929                 :            :    return doubled delimiters on the input as a single instance of
     930                 :            :    the delimiter.
     931                 :            : 
     932                 :            :    Special return values for "ret" argument are:
     933                 :            :      -1   End of the string, as determined by the delimiter
     934                 :            :      -2   Unterminated string detected
     935                 :            : 
     936                 :            :    Backslash codes are also expanded at this time.  */
     937                 :            : 
     938                 :            : static gfc_char_t
     939                 :    3027460 : next_string_char (gfc_char_t delimiter, int *ret)
     940                 :            : {
     941                 :    3027460 :   locus old_locus;
     942                 :    3027460 :   gfc_char_t c;
     943                 :            : 
     944                 :    3027460 :   c = gfc_next_char_literal (INSTRING_WARN);
     945                 :    3027460 :   *ret = 0;
     946                 :            : 
     947                 :    3027460 :   if (c == '\n')
     948                 :            :     {
     949                 :          4 :       *ret = -2;
     950                 :          4 :       return 0;
     951                 :            :     }
     952                 :            : 
     953                 :    3027450 :   if (flag_backslash && c == '\\')
     954                 :            :     {
     955                 :      12072 :       old_locus = gfc_current_locus;
     956                 :            : 
     957                 :      12072 :       if (gfc_match_special_char (&c) == MATCH_NO)
     958                 :          0 :         gfc_current_locus = old_locus;
     959                 :            : 
     960                 :      12072 :       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
     961                 :          0 :         gfc_warning (0, "Extension: backslash character at %C");
     962                 :            :     }
     963                 :            : 
     964                 :    3027450 :   if (c != delimiter)
     965                 :            :     return c;
     966                 :            : 
     967                 :     417198 :   old_locus = gfc_current_locus;
     968                 :     417198 :   c = gfc_next_char_literal (NONSTRING);
     969                 :            : 
     970                 :     417198 :   if (c == delimiter)
     971                 :            :     return c;
     972                 :     416380 :   gfc_current_locus = old_locus;
     973                 :            : 
     974                 :     416380 :   *ret = -1;
     975                 :     416380 :   return 0;
     976                 :            : }
     977                 :            : 
     978                 :            : 
     979                 :            : /* Special case of gfc_match_name() that matches a parameter kind name
     980                 :            :    before a string constant.  This takes case of the weird but legal
     981                 :            :    case of:
     982                 :            : 
     983                 :            :      kind_____'string'
     984                 :            : 
     985                 :            :    where kind____ is a parameter. gfc_match_name() will happily slurp
     986                 :            :    up all the underscores, which leads to problems.  If we return
     987                 :            :    MATCH_YES, the parse pointer points to the final underscore, which
     988                 :            :    is not part of the name.  We never return MATCH_ERROR-- errors in
     989                 :            :    the name will be detected later.  */
     990                 :            : 
     991                 :            : static match
     992                 :    2591290 : match_charkind_name (char *name)
     993                 :            : {
     994                 :    2591290 :   locus old_loc;
     995                 :    2591290 :   char c, peek;
     996                 :    2591290 :   int len;
     997                 :            : 
     998                 :    2591290 :   gfc_gobble_whitespace ();
     999                 :    2591290 :   c = gfc_next_ascii_char ();
    1000                 :    2591290 :   if (!ISALPHA (c))
    1001                 :            :     return MATCH_NO;
    1002                 :            : 
    1003                 :    2340520 :   *name++ = c;
    1004                 :    2340520 :   len = 1;
    1005                 :            : 
    1006                 :    9650260 :   for (;;)
    1007                 :            :     {
    1008                 :    9650260 :       old_loc = gfc_current_locus;
    1009                 :    9650260 :       c = gfc_next_ascii_char ();
    1010                 :            : 
    1011                 :    9650260 :       if (c == '_')
    1012                 :            :         {
    1013                 :     237916 :           peek = gfc_peek_ascii_char ();
    1014                 :            : 
    1015                 :     237916 :           if (peek == '\'' || peek == '\"')
    1016                 :            :             {
    1017                 :        773 :               gfc_current_locus = old_loc;
    1018                 :        773 :               *name = '\0';
    1019                 :        773 :               return MATCH_YES;
    1020                 :            :             }
    1021                 :            :         }
    1022                 :            : 
    1023                 :    9649490 :       if (!ISALNUM (c)
    1024                 :    2576890 :           && c != '_'
    1025                 :    2339740 :           && (c != '$' || !flag_dollar_ok))
    1026                 :            :         break;
    1027                 :            : 
    1028                 :    7309750 :       *name++ = c;
    1029                 :    7309750 :       if (++len > GFC_MAX_SYMBOL_LEN)
    1030                 :            :         break;
    1031                 :            :     }
    1032                 :            : 
    1033                 :            :   return MATCH_NO;
    1034                 :            : }
    1035                 :            : 
    1036                 :            : 
    1037                 :            : /* See if the current input matches a character constant.  Lots of
    1038                 :            :    contortions have to be done to match the kind parameter which comes
    1039                 :            :    before the actual string.  The main consideration is that we don't
    1040                 :            :    want to error out too quickly.  For example, we don't actually do
    1041                 :            :    any validation of the kinds until we have actually seen a legal
    1042                 :            :    delimiter.  Using match_kind_param() generates errors too quickly.  */
    1043                 :            : 
    1044                 :            : static match
    1045                 :    4354240 : match_string_constant (gfc_expr **result)
    1046                 :            : {
    1047                 :    4354240 :   char name[GFC_MAX_SYMBOL_LEN + 1], peek;
    1048                 :    4354240 :   size_t length;
    1049                 :    4354240 :   int kind,save_warn_ampersand, ret;
    1050                 :    4354240 :   locus old_locus, start_locus;
    1051                 :    4354240 :   gfc_symbol *sym;
    1052                 :    4354240 :   gfc_expr *e;
    1053                 :    4354240 :   match m;
    1054                 :    4354240 :   gfc_char_t c, delimiter, *p;
    1055                 :            : 
    1056                 :    4354240 :   old_locus = gfc_current_locus;
    1057                 :            : 
    1058                 :    4354240 :   gfc_gobble_whitespace ();
    1059                 :            : 
    1060                 :    4354240 :   c = gfc_next_char ();
    1061                 :    4354240 :   if (c == '\'' || c == '"')
    1062                 :            :     {
    1063                 :     191745 :       kind = gfc_default_character_kind;
    1064                 :     191745 :       start_locus = gfc_current_locus;
    1065                 :     191745 :       goto got_delim;
    1066                 :            :     }
    1067                 :            : 
    1068                 :    4162500 :   if (gfc_wide_is_digit (c))
    1069                 :            :     {
    1070                 :    1571210 :       kind = 0;
    1071                 :            : 
    1072                 :    3731900 :       while (gfc_wide_is_digit (c))
    1073                 :            :         {
    1074                 :    2162850 :           kind = kind * 10 + c - '0';
    1075                 :    2162850 :           if (kind > 9999999)
    1076                 :       2161 :             goto no_match;
    1077                 :    2160690 :           c = gfc_next_char ();
    1078                 :            :         }
    1079                 :            : 
    1080                 :            :     }
    1081                 :            :   else
    1082                 :            :     {
    1083                 :    2591290 :       gfc_current_locus = old_locus;
    1084                 :            : 
    1085                 :    2591290 :       m = match_charkind_name (name);
    1086                 :    2591290 :       if (m != MATCH_YES)
    1087                 :    2590520 :         goto no_match;
    1088                 :            : 
    1089                 :        773 :       if (gfc_find_symbol (name, NULL, 1, &sym)
    1090                 :        773 :           || sym == NULL
    1091                 :       1545 :           || sym->attr.flavor != FL_PARAMETER)
    1092                 :          1 :         goto no_match;
    1093                 :            : 
    1094                 :        772 :       kind = -1;
    1095                 :        772 :       c = gfc_next_char ();
    1096                 :            :     }
    1097                 :            : 
    1098                 :    1569820 :   if (c == ' ')
    1099                 :            :     {
    1100                 :      58165 :       gfc_gobble_whitespace ();
    1101                 :      58165 :       c = gfc_next_char ();
    1102                 :            :     }
    1103                 :            : 
    1104                 :    1569820 :   if (c != '_')
    1105                 :    1411180 :     goto no_match;
    1106                 :            : 
    1107                 :     158642 :   gfc_gobble_whitespace ();
    1108                 :            : 
    1109                 :     158642 :   c = gfc_next_char ();
    1110                 :     158642 :   if (c != '\'' && c != '"')
    1111                 :     142178 :     goto no_match;
    1112                 :            : 
    1113                 :      16464 :   start_locus = gfc_current_locus;
    1114                 :            : 
    1115                 :      16464 :   if (kind == -1)
    1116                 :            :     {
    1117                 :        772 :       if (gfc_extract_int (sym->value, &kind, 1))
    1118                 :            :         return MATCH_ERROR;
    1119                 :        772 :       gfc_set_sym_referenced (sym);
    1120                 :            :     }
    1121                 :            : 
    1122                 :      16464 :   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
    1123                 :            :     {
    1124                 :          0 :       gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
    1125                 :          0 :       return MATCH_ERROR;
    1126                 :            :     }
    1127                 :            : 
    1128                 :      16464 : got_delim:
    1129                 :            :   /* Scan the string into a block of memory by first figuring out how
    1130                 :            :      long it is, allocating the structure, then re-reading it.  This
    1131                 :            :      isn't particularly efficient, but string constants aren't that
    1132                 :            :      common in most code.  TODO: Use obstacks?  */
    1133                 :            : 
    1134                 :     208209 :   delimiter = c;
    1135                 :     208209 :   length = 0;
    1136                 :            : 
    1137                 :    2819590 :   for (;;)
    1138                 :            :     {
    1139                 :    1513900 :       c = next_string_char (delimiter, &ret);
    1140                 :    1513900 :       if (ret == -1)
    1141                 :            :         break;
    1142                 :    1305700 :       if (ret == -2)
    1143                 :            :         {
    1144                 :          4 :           gfc_current_locus = start_locus;
    1145                 :          4 :           gfc_error ("Unterminated character constant beginning at %C");
    1146                 :          4 :           return MATCH_ERROR;
    1147                 :            :         }
    1148                 :            : 
    1149                 :    1305690 :       length++;
    1150                 :            :     }
    1151                 :            : 
    1152                 :            :   /* Peek at the next character to see if it is a b, o, z, or x for the
    1153                 :            :      postfixed BOZ literal constants.  */
    1154                 :     208205 :   peek = gfc_peek_ascii_char ();
    1155                 :     208205 :   if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
    1156                 :         25 :     goto no_match;
    1157                 :            : 
    1158                 :     208180 :   e = gfc_get_character_expr (kind, &start_locus, NULL, length);
    1159                 :            : 
    1160                 :     208180 :   gfc_current_locus = start_locus;
    1161                 :            : 
    1162                 :            :   /* We disable the warning for the following loop as the warning has already
    1163                 :            :      been printed in the loop above.  */
    1164                 :     208180 :   save_warn_ampersand = warn_ampersand;
    1165                 :     208180 :   warn_ampersand = false;
    1166                 :            : 
    1167                 :     208180 :   p = e->value.character.string;
    1168                 :    1513560 :   for (size_t i = 0; i < length; i++)
    1169                 :            :     {
    1170                 :    1305380 :       c = next_string_char (delimiter, &ret);
    1171                 :            : 
    1172                 :    1305380 :       if (!gfc_check_character_range (c, kind))
    1173                 :            :         {
    1174                 :          5 :           gfc_free_expr (e);
    1175                 :          5 :           gfc_error ("Character %qs in string at %C is not representable "
    1176                 :            :                      "in character kind %d", gfc_print_wide_char (c), kind);
    1177                 :          5 :           return MATCH_ERROR;
    1178                 :            :         }
    1179                 :            : 
    1180                 :    1305380 :       *p++ = c;
    1181                 :            :     }
    1182                 :            : 
    1183                 :     208175 :   *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
    1184                 :     208175 :   warn_ampersand = save_warn_ampersand;
    1185                 :            : 
    1186                 :     208175 :   next_string_char (delimiter, &ret);
    1187                 :     208175 :   if (ret != -1)
    1188                 :          0 :     gfc_internal_error ("match_string_constant(): Delimiter not found");
    1189                 :            : 
    1190                 :     208175 :   if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
    1191                 :        256 :     e->expr_type = EXPR_SUBSTRING;
    1192                 :            : 
    1193                 :     208175 :   *result = e;
    1194                 :            : 
    1195                 :     208175 :   return MATCH_YES;
    1196                 :            : 
    1197                 :    4146060 : no_match:
    1198                 :    4146060 :   gfc_current_locus = old_locus;
    1199                 :    4146060 :   return MATCH_NO;
    1200                 :            : }
    1201                 :            : 
    1202                 :            : 
    1203                 :            : /* Match a .true. or .false.  Returns 1 if a .true. was found,
    1204                 :            :    0 if a .false. was found, and -1 otherwise.  */
    1205                 :            : static int
    1206                 :    2586110 : match_logical_constant_string (void)
    1207                 :            : {
    1208                 :    2586110 :   locus orig_loc = gfc_current_locus;
    1209                 :            : 
    1210                 :    2586110 :   gfc_gobble_whitespace ();
    1211                 :    2586110 :   if (gfc_next_ascii_char () == '.')
    1212                 :            :     {
    1213                 :      31612 :       char ch = gfc_next_ascii_char ();
    1214                 :      31612 :       if (ch == 'f')
    1215                 :            :         {
    1216                 :      15780 :           if (gfc_next_ascii_char () == 'a'
    1217                 :      15780 :               && gfc_next_ascii_char () == 'l'
    1218                 :      15780 :               && gfc_next_ascii_char () == 's'
    1219                 :      15780 :               && gfc_next_ascii_char () == 'e'
    1220                 :      31560 :               && gfc_next_ascii_char () == '.')
    1221                 :            :             /* Matched ".false.".  */
    1222                 :            :             return 0;
    1223                 :            :         }
    1224                 :      15832 :       else if (ch == 't')
    1225                 :            :         {
    1226                 :      15831 :           if (gfc_next_ascii_char () == 'r'
    1227                 :      15831 :               && gfc_next_ascii_char () == 'u'
    1228                 :      15831 :               && gfc_next_ascii_char () == 'e'
    1229                 :      31662 :               && gfc_next_ascii_char () == '.')
    1230                 :            :             /* Matched ".true.".  */
    1231                 :            :             return 1;
    1232                 :            :         }
    1233                 :            :     }
    1234                 :    2554500 :   gfc_current_locus = orig_loc;
    1235                 :    2554500 :   return -1;
    1236                 :            : }
    1237                 :            : 
    1238                 :            : /* Match a .true. or .false.  */
    1239                 :            : 
    1240                 :            : static match
    1241                 :    2586110 : match_logical_constant (gfc_expr **result)
    1242                 :            : {
    1243                 :    2586110 :   gfc_expr *e;
    1244                 :    2586110 :   int i, kind, is_iso_c;
    1245                 :            : 
    1246                 :    2586110 :   i = match_logical_constant_string ();
    1247                 :    2586110 :   if (i == -1)
    1248                 :            :     return MATCH_NO;
    1249                 :            : 
    1250                 :      31611 :   kind = get_kind (&is_iso_c);
    1251                 :      31611 :   if (kind == -1)
    1252                 :            :     return MATCH_ERROR;
    1253                 :      31611 :   if (kind == -2)
    1254                 :      31362 :     kind = gfc_default_logical_kind;
    1255                 :            : 
    1256                 :      31611 :   if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
    1257                 :            :     {
    1258                 :          4 :       gfc_error ("Bad kind for logical constant at %C");
    1259                 :          4 :       return MATCH_ERROR;
    1260                 :            :     }
    1261                 :            : 
    1262                 :      31607 :   e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
    1263                 :      31607 :   e->ts.is_c_interop = is_iso_c;
    1264                 :            : 
    1265                 :      31607 :   *result = e;
    1266                 :      31607 :   return MATCH_YES;
    1267                 :            : }
    1268                 :            : 
    1269                 :            : 
    1270                 :            : /* Match a real or imaginary part of a complex constant that is a
    1271                 :            :    symbolic constant.  */
    1272                 :            : 
    1273                 :            : static match
    1274                 :     106635 : match_sym_complex_part (gfc_expr **result)
    1275                 :            : {
    1276                 :     106635 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1277                 :     106635 :   gfc_symbol *sym;
    1278                 :     106635 :   gfc_expr *e;
    1279                 :     106635 :   match m;
    1280                 :            : 
    1281                 :     106635 :   m = gfc_match_name (name);
    1282                 :     106635 :   if (m != MATCH_YES)
    1283                 :            :     return m;
    1284                 :            : 
    1285                 :      33022 :   if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
    1286                 :            :     return MATCH_NO;
    1287                 :            : 
    1288                 :      30518 :   if (sym->attr.flavor != FL_PARAMETER)
    1289                 :            :     {
    1290                 :            :       /* Give the matcher for implied do-loops a chance to run.  This yields
    1291                 :            :          a much saner error message for "write(*,*) (i, i=1, 6" where the
    1292                 :            :          right parenthesis is missing.  */
    1293                 :      29610 :       char c;
    1294                 :      29610 :       gfc_gobble_whitespace ();
    1295                 :      29610 :       c = gfc_peek_ascii_char ();
    1296                 :      29610 :       if (c == '=' || c == ',')
    1297                 :            :         {
    1298                 :            :           m = MATCH_NO;
    1299                 :            :         }
    1300                 :            :       else
    1301                 :            :         {
    1302                 :      27275 :           gfc_error ("Expected PARAMETER symbol in complex constant at %C");
    1303                 :      27275 :           m = MATCH_ERROR;
    1304                 :            :         }
    1305                 :      29610 :       return m;
    1306                 :            :     }
    1307                 :            : 
    1308                 :        908 :   if (!sym->value)
    1309                 :          2 :     goto error;
    1310                 :            : 
    1311                 :        906 :   if (!gfc_numeric_ts (&sym->value->ts))
    1312                 :            :     {
    1313                 :        266 :       gfc_error ("Numeric PARAMETER required in complex constant at %C");
    1314                 :        266 :       return MATCH_ERROR;
    1315                 :            :     }
    1316                 :            : 
    1317                 :        640 :   if (sym->value->rank != 0)
    1318                 :            :     {
    1319                 :         75 :       gfc_error ("Scalar PARAMETER required in complex constant at %C");
    1320                 :         75 :       return MATCH_ERROR;
    1321                 :            :     }
    1322                 :            : 
    1323                 :        565 :   if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
    1324                 :            :                        "complex constant at %C"))
    1325                 :            :     return MATCH_ERROR;
    1326                 :            : 
    1327                 :        562 :   switch (sym->value->ts.type)
    1328                 :            :     {
    1329                 :         16 :     case BT_REAL:
    1330                 :         16 :       e = gfc_copy_expr (sym->value);
    1331                 :         16 :       break;
    1332                 :            : 
    1333                 :          1 :     case BT_COMPLEX:
    1334                 :          1 :       e = gfc_complex2real (sym->value, sym->value->ts.kind);
    1335                 :          1 :       if (e == NULL)
    1336                 :          0 :         goto error;
    1337                 :            :       break;
    1338                 :            : 
    1339                 :        545 :     case BT_INTEGER:
    1340                 :        545 :       e = gfc_int2real (sym->value, gfc_default_real_kind);
    1341                 :        545 :       if (e == NULL)
    1342                 :          0 :         goto error;
    1343                 :            :       break;
    1344                 :            : 
    1345                 :          0 :     default:
    1346                 :          0 :       gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
    1347                 :            :     }
    1348                 :            : 
    1349                 :        562 :   *result = e;          /* e is a scalar, real, constant expression.  */
    1350                 :        562 :   return MATCH_YES;
    1351                 :            : 
    1352                 :          2 : error:
    1353                 :          2 :   gfc_error ("Error converting PARAMETER constant in complex constant at %C");
    1354                 :          2 :   return MATCH_ERROR;
    1355                 :            : }
    1356                 :            : 
    1357                 :            : 
    1358                 :            : /* Match a real or imaginary part of a complex number.  */
    1359                 :            : 
    1360                 :            : static match
    1361                 :     106635 : match_complex_part (gfc_expr **result)
    1362                 :            : {
    1363                 :     106635 :   match m;
    1364                 :            : 
    1365                 :     106635 :   m = match_sym_complex_part (result);
    1366                 :     106635 :   if (m != MATCH_NO)
    1367                 :            :     return m;
    1368                 :            : 
    1369                 :      78452 :   m = match_real_constant (result, 1);
    1370                 :      78452 :   if (m != MATCH_NO)
    1371                 :            :     return m;
    1372                 :            : 
    1373                 :      66292 :   return match_integer_constant (result, 1);
    1374                 :            : }
    1375                 :            : 
    1376                 :            : 
    1377                 :            : /* Try to match a complex constant.  */
    1378                 :            : 
    1379                 :            : static match
    1380                 :    4363160 : match_complex_constant (gfc_expr **result)
    1381                 :            : {
    1382                 :    4363160 :   gfc_expr *e, *real, *imag;
    1383                 :    4363160 :   gfc_error_buffer old_error;
    1384                 :    4363160 :   gfc_typespec target;
    1385                 :    4363160 :   locus old_loc;
    1386                 :    4363160 :   int kind;
    1387                 :    4363160 :   match m;
    1388                 :            : 
    1389                 :    4363160 :   old_loc = gfc_current_locus;
    1390                 :    4363160 :   real = imag = e = NULL;
    1391                 :            : 
    1392                 :    4363160 :   m = gfc_match_char ('(');
    1393                 :    4363160 :   if (m != MATCH_YES)
    1394                 :            :     return m;
    1395                 :            : 
    1396                 :      97722 :   gfc_push_error (&old_error);
    1397                 :            : 
    1398                 :      97722 :   m = match_complex_part (&real);
    1399                 :      97722 :   if (m == MATCH_NO)
    1400                 :            :     {
    1401                 :      50582 :       gfc_free_error (&old_error);
    1402                 :      50582 :       goto cleanup;
    1403                 :            :     }
    1404                 :            : 
    1405                 :      47140 :   if (gfc_match_char (',') == MATCH_NO)
    1406                 :            :     {
    1407                 :            :       /* It is possible that gfc_int2real issued a warning when
    1408                 :            :          converting an integer to real.  Throw this away here.  */
    1409                 :            : 
    1410                 :      38223 :       gfc_clear_warning ();
    1411                 :      38223 :       gfc_pop_error (&old_error);
    1412                 :      38223 :       m = MATCH_NO;
    1413                 :      38223 :       goto cleanup;
    1414                 :            :     }
    1415                 :            : 
    1416                 :            :   /* If m is error, then something was wrong with the real part and we
    1417                 :            :      assume we have a complex constant because we've seen the ','.  An
    1418                 :            :      ambiguous case here is the start of an iterator list of some
    1419                 :            :      sort. These sort of lists are matched prior to coming here.  */
    1420                 :            : 
    1421                 :       8917 :   if (m == MATCH_ERROR)
    1422                 :            :     {
    1423                 :          4 :       gfc_free_error (&old_error);
    1424                 :          4 :       goto cleanup;
    1425                 :            :     }
    1426                 :       8913 :   gfc_pop_error (&old_error);
    1427                 :            : 
    1428                 :       8913 :   m = match_complex_part (&imag);
    1429                 :       8913 :   if (m == MATCH_NO)
    1430                 :       2849 :     goto syntax;
    1431                 :       6064 :   if (m == MATCH_ERROR)
    1432                 :        121 :     goto cleanup;
    1433                 :            : 
    1434                 :       5943 :   m = gfc_match_char (')');
    1435                 :       5943 :   if (m == MATCH_NO)
    1436                 :            :     {
    1437                 :            :       /* Give the matcher for implied do-loops a chance to run.  This
    1438                 :            :          yields a much saner error message for (/ (i, 4=i, 6) /).  */
    1439                 :         13 :       if (gfc_peek_ascii_char () == '=')
    1440                 :            :         {
    1441                 :          0 :           m = MATCH_ERROR;
    1442                 :          0 :           goto cleanup;
    1443                 :            :         }
    1444                 :            :       else
    1445                 :         13 :     goto syntax;
    1446                 :            :     }
    1447                 :            : 
    1448                 :       5930 :   if (m == MATCH_ERROR)
    1449                 :          0 :     goto cleanup;
    1450                 :            : 
    1451                 :            :   /* Decide on the kind of this complex number.  */
    1452                 :       5930 :   if (real->ts.type == BT_REAL)
    1453                 :            :     {
    1454                 :       5517 :       if (imag->ts.type == BT_REAL)
    1455                 :       5492 :         kind = gfc_kind_max (real, imag);
    1456                 :            :       else
    1457                 :         25 :         kind = real->ts.kind;
    1458                 :            :     }
    1459                 :            :   else
    1460                 :            :     {
    1461                 :        413 :       if (imag->ts.type == BT_REAL)
    1462                 :          7 :         kind = imag->ts.kind;
    1463                 :            :       else
    1464                 :        406 :         kind = gfc_default_real_kind;
    1465                 :            :     }
    1466                 :       5930 :   gfc_clear_ts (&target);
    1467                 :       5930 :   target.type = BT_REAL;
    1468                 :       5930 :   target.kind = kind;
    1469                 :            : 
    1470                 :       5930 :   if (real->ts.type != BT_REAL || kind != real->ts.kind)
    1471                 :        414 :     gfc_convert_type (real, &target, 2);
    1472                 :       5930 :   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
    1473                 :        469 :     gfc_convert_type (imag, &target, 2);
    1474                 :            : 
    1475                 :       5930 :   e = convert_complex (real, imag, kind);
    1476                 :       5930 :   e->where = gfc_current_locus;
    1477                 :            : 
    1478                 :       5930 :   gfc_free_expr (real);
    1479                 :       5930 :   gfc_free_expr (imag);
    1480                 :            : 
    1481                 :       5930 :   *result = e;
    1482                 :       5930 :   return MATCH_YES;
    1483                 :            : 
    1484                 :       2862 : syntax:
    1485                 :       2862 :   gfc_error ("Syntax error in COMPLEX constant at %C");
    1486                 :       2862 :   m = MATCH_ERROR;
    1487                 :            : 
    1488                 :      91792 : cleanup:
    1489                 :      91792 :   gfc_free_expr (e);
    1490                 :      91792 :   gfc_free_expr (real);
    1491                 :      91792 :   gfc_free_expr (imag);
    1492                 :      91792 :   gfc_current_locus = old_loc;
    1493                 :            : 
    1494                 :      91792 :   return m;
    1495                 :            : }
    1496                 :            : 
    1497                 :            : 
    1498                 :            : /* Match constants in any of several forms.  Returns nonzero for a
    1499                 :            :    match, zero for no match.  */
    1500                 :            : 
    1501                 :            : match
    1502                 :    4363160 : gfc_match_literal_constant (gfc_expr **result, int signflag)
    1503                 :            : {
    1504                 :    4363160 :   match m;
    1505                 :            : 
    1506                 :    4363160 :   m = match_complex_constant (result);
    1507                 :    4363160 :   if (m != MATCH_NO)
    1508                 :            :     return m;
    1509                 :            : 
    1510                 :    4354240 :   m = match_string_constant (result);
    1511                 :    4354240 :   if (m != MATCH_NO)
    1512                 :            :     return m;
    1513                 :            : 
    1514                 :    4146060 :   m = match_boz_constant (result);
    1515                 :    4146060 :   if (m != MATCH_NO)
    1516                 :            :     return m;
    1517                 :            : 
    1518                 :    4142860 :   m = match_real_constant (result, signflag);
    1519                 :    4142860 :   if (m != MATCH_NO)
    1520                 :            :     return m;
    1521                 :            : 
    1522                 :    3995700 :   m = match_hollerith_constant (result);
    1523                 :    3995700 :   if (m != MATCH_NO)
    1524                 :            :     return m;
    1525                 :            : 
    1526                 :    3993050 :   m = match_integer_constant (result, signflag);
    1527                 :    3993050 :   if (m != MATCH_NO)
    1528                 :            :     return m;
    1529                 :            : 
    1530                 :    2586110 :   m = match_logical_constant (result);
    1531                 :    2586110 :   if (m != MATCH_NO)
    1532                 :      31611 :     return m;
    1533                 :            : 
    1534                 :            :   return MATCH_NO;
    1535                 :            : }
    1536                 :            : 
    1537                 :            : 
    1538                 :            : /* This checks if a symbol is the return value of an encompassing function.
    1539                 :            :    Function nesting can be maximally two levels deep, but we may have
    1540                 :            :    additional local namespaces like BLOCK etc.  */
    1541                 :            : 
    1542                 :            : bool
    1543                 :     529856 : gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
    1544                 :            : {
    1545                 :     529856 :   if (!sym->attr.function || (sym->result != sym))
    1546                 :            :     return false;
    1547                 :    1081510 :   while (ns)
    1548                 :            :     {
    1549                 :     596752 :       if (ns->proc_name == sym)
    1550                 :            :         return true;
    1551                 :     587059 :       ns = ns->parent;
    1552                 :            :     }
    1553                 :            :   return false;
    1554                 :            : }
    1555                 :            : 
    1556                 :            : 
    1557                 :            : /* Match a single actual argument value.  An actual argument is
    1558                 :            :    usually an expression, but can also be a procedure name.  If the
    1559                 :            :    argument is a single name, it is not always possible to tell
    1560                 :            :    whether the name is a dummy procedure or not.  We treat these cases
    1561                 :            :    by creating an argument that looks like a dummy procedure and
    1562                 :            :    fixing things later during resolution.  */
    1563                 :            : 
    1564                 :            : static match
    1565                 :    1305270 : match_actual_arg (gfc_expr **result)
    1566                 :            : {
    1567                 :    1305270 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1568                 :    1305270 :   gfc_symtree *symtree;
    1569                 :    1305270 :   locus where, w;
    1570                 :    1305270 :   gfc_expr *e;
    1571                 :    1305270 :   char c;
    1572                 :            : 
    1573                 :    1305270 :   gfc_gobble_whitespace ();
    1574                 :    1305270 :   where = gfc_current_locus;
    1575                 :            : 
    1576                 :    1305270 :   switch (gfc_match_name (name))
    1577                 :            :     {
    1578                 :            :     case MATCH_ERROR:
    1579                 :            :       return MATCH_ERROR;
    1580                 :            : 
    1581                 :            :     case MATCH_NO:
    1582                 :            :       break;
    1583                 :            : 
    1584                 :     806183 :     case MATCH_YES:
    1585                 :     806183 :       w = gfc_current_locus;
    1586                 :     806183 :       gfc_gobble_whitespace ();
    1587                 :     806183 :       c = gfc_next_ascii_char ();
    1588                 :     806183 :       gfc_current_locus = w;
    1589                 :            : 
    1590                 :     806183 :       if (c != ',' && c != ')')
    1591                 :            :         break;
    1592                 :            : 
    1593                 :     403654 :       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
    1594                 :            :         break;
    1595                 :            :       /* Handle error elsewhere.  */
    1596                 :            : 
    1597                 :            :       /* Eliminate a couple of common cases where we know we don't
    1598                 :            :          have a function argument.  */
    1599                 :     403654 :       if (symtree == NULL)
    1600                 :            :         {
    1601                 :      10859 :           gfc_get_sym_tree (name, NULL, &symtree, false);
    1602                 :      10859 :           gfc_set_sym_referenced (symtree->n.sym);
    1603                 :            :         }
    1604                 :            :       else
    1605                 :            :         {
    1606                 :     392795 :           gfc_symbol *sym;
    1607                 :            : 
    1608                 :     392795 :           sym = symtree->n.sym;
    1609                 :     392795 :           gfc_set_sym_referenced (sym);
    1610                 :     392795 :           if (sym->attr.flavor == FL_NAMELIST)
    1611                 :            :             {
    1612                 :       1010 :               gfc_error ("Namelist %qs cannot be an argument at %L",
    1613                 :            :               sym->name, &where);
    1614                 :       1010 :               break;
    1615                 :            :             }
    1616                 :     391785 :           if (sym->attr.flavor != FL_PROCEDURE
    1617                 :     367954 :               && sym->attr.flavor != FL_UNKNOWN)
    1618                 :            :             break;
    1619                 :            : 
    1620                 :     107453 :           if (sym->attr.in_common && !sym->attr.proc_pointer)
    1621                 :            :             {
    1622                 :        224 :               if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
    1623                 :            :                                    sym->name, &sym->declared_at))
    1624                 :            :                 return MATCH_ERROR;
    1625                 :            :               break;
    1626                 :            :             }
    1627                 :            : 
    1628                 :            :           /* If the symbol is a function with itself as the result and
    1629                 :            :              is being defined, then we have a variable.  */
    1630                 :     107229 :           if (sym->attr.function && sym->result == sym)
    1631                 :            :             {
    1632                 :       2282 :               if (gfc_is_function_return_value (sym, gfc_current_ns))
    1633                 :            :                 break;
    1634                 :            : 
    1635                 :       1705 :               if (sym->attr.entry
    1636                 :         31 :                   && (sym->ns == gfc_current_ns
    1637                 :       1707 :                       || sym->ns == gfc_current_ns->parent))
    1638                 :            :                 {
    1639                 :         30 :                   gfc_entry_list *el = NULL;
    1640                 :            : 
    1641                 :         30 :                   for (el = sym->ns->entries; el; el = el->next)
    1642                 :         30 :                     if (sym == el->sym)
    1643                 :            :                       break;
    1644                 :            : 
    1645                 :         30 :                   if (el)
    1646                 :            :                     break;
    1647                 :            :                 }
    1648                 :            :             }
    1649                 :            :         }
    1650                 :            : 
    1651                 :     117481 :       e = gfc_get_expr ();      /* Leave it unknown for now */
    1652                 :     117481 :       e->symtree = symtree;
    1653                 :     117481 :       e->expr_type = EXPR_VARIABLE;
    1654                 :     117481 :       e->ts.type = BT_PROCEDURE;
    1655                 :     117481 :       e->where = where;
    1656                 :            : 
    1657                 :     117481 :       *result = e;
    1658                 :     117481 :       return MATCH_YES;
    1659                 :            :     }
    1660                 :            : 
    1661                 :    1187790 :   gfc_current_locus = where;
    1662                 :    1187790 :   return gfc_match_expr (result);
    1663                 :            : }
    1664                 :            : 
    1665                 :            : 
    1666                 :            : /* Match a keyword argument or type parameter spec list..  */
    1667                 :            : 
    1668                 :            : static match
    1669                 :    1299910 : match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
    1670                 :            : {
    1671                 :    1299910 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1672                 :    1299910 :   gfc_actual_arglist *a;
    1673                 :    1299910 :   locus name_locus;
    1674                 :    1299910 :   match m;
    1675                 :            : 
    1676                 :    1299910 :   name_locus = gfc_current_locus;
    1677                 :    1299910 :   m = gfc_match_name (name);
    1678                 :            : 
    1679                 :    1299910 :   if (m != MATCH_YES)
    1680                 :     434491 :     goto cleanup;
    1681                 :     865420 :   if (gfc_match_char ('=') != MATCH_YES)
    1682                 :            :     {
    1683                 :     765750 :       m = MATCH_NO;
    1684                 :     765750 :       goto cleanup;
    1685                 :            :     }
    1686                 :            : 
    1687                 :      99670 :   if (pdt)
    1688                 :            :     {
    1689                 :        214 :       if (gfc_match_char ('*') == MATCH_YES)
    1690                 :            :         {
    1691                 :         18 :           actual->spec_type = SPEC_ASSUMED;
    1692                 :         18 :           goto add_name;
    1693                 :            :         }
    1694                 :        196 :       else if (gfc_match_char (':') == MATCH_YES)
    1695                 :            :         {
    1696                 :         14 :           actual->spec_type = SPEC_DEFERRED;
    1697                 :         14 :           goto add_name;
    1698                 :            :         }
    1699                 :            :       else
    1700                 :        182 :         actual->spec_type = SPEC_EXPLICIT;
    1701                 :            :     }
    1702                 :            : 
    1703                 :      99638 :   m = match_actual_arg (&actual->expr);
    1704                 :      99638 :   if (m != MATCH_YES)
    1705                 :       6867 :     goto cleanup;
    1706                 :            : 
    1707                 :            :   /* Make sure this name has not appeared yet.  */
    1708                 :      92771 : add_name:
    1709                 :      92803 :   if (name[0] != '\0')
    1710                 :            :     {
    1711                 :     288194 :       for (a = base; a; a = a->next)
    1712                 :     195401 :         if (a->name != NULL && strcmp (a->name, name) == 0)
    1713                 :            :           {
    1714                 :         10 :             gfc_error ("Keyword %qs at %C has already appeared in the "
    1715                 :            :                        "current argument list", name);
    1716                 :         10 :             return MATCH_ERROR;
    1717                 :            :           }
    1718                 :            :     }
    1719                 :            : 
    1720                 :      92793 :   actual->name = gfc_get_string ("%s", name);
    1721                 :      92793 :   return MATCH_YES;
    1722                 :            : 
    1723                 :    1207110 : cleanup:
    1724                 :    1207110 :   gfc_current_locus = name_locus;
    1725                 :    1207110 :   return m;
    1726                 :            : }
    1727                 :            : 
    1728                 :            : 
    1729                 :            : /* Match an argument list function, such as %VAL.  */
    1730                 :            : 
    1731                 :            : static match
    1732                 :    1273690 : match_arg_list_function (gfc_actual_arglist *result)
    1733                 :            : {
    1734                 :    1273690 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    1735                 :    1273690 :   locus old_locus;
    1736                 :    1273690 :   match m;
    1737                 :            : 
    1738                 :    1273690 :   old_locus = gfc_current_locus;
    1739                 :            : 
    1740                 :    1273690 :   if (gfc_match_char ('%') != MATCH_YES)
    1741                 :            :     {
    1742                 :    1273440 :       m = MATCH_NO;
    1743                 :    1273440 :       goto cleanup;
    1744                 :            :     }
    1745                 :            : 
    1746                 :        245 :   m = gfc_match ("%n (", name);
    1747                 :        245 :   if (m != MATCH_YES)
    1748                 :          0 :     goto cleanup;
    1749                 :            : 
    1750                 :        245 :   if (name[0] != '\0')
    1751                 :            :     {
    1752                 :        245 :       switch (name[0])
    1753                 :            :         {
    1754                 :         76 :         case 'l':
    1755                 :         76 :           if (gfc_str_startswith (name, "loc"))
    1756                 :            :             {
    1757                 :         76 :               result->name = "%LOC";
    1758                 :         76 :               break;
    1759                 :            :             }
    1760                 :            :           /* FALLTHRU */
    1761                 :         72 :         case 'r':
    1762                 :         72 :           if (gfc_str_startswith (name, "ref"))
    1763                 :            :             {
    1764                 :         72 :               result->name = "%REF";
    1765                 :         72 :               break;
    1766                 :            :             }
    1767                 :            :           /* FALLTHRU */
    1768                 :         97 :         case 'v':
    1769                 :         97 :           if (gfc_str_startswith (name, "val"))
    1770                 :            :             {
    1771                 :         97 :               result->name = "%VAL";
    1772                 :         97 :               break;
    1773                 :            :             }
    1774                 :            :           /* FALLTHRU */
    1775                 :          0 :         default:
    1776                 :          0 :           m = MATCH_ERROR;
    1777                 :          0 :           goto cleanup;
    1778                 :            :         }
    1779                 :            :     }
    1780                 :            : 
    1781                 :        245 :   if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
    1782                 :            :     {
    1783                 :          1 :       m = MATCH_ERROR;
    1784                 :          1 :       goto cleanup;
    1785                 :            :     }
    1786                 :            : 
    1787                 :        244 :   m = match_actual_arg (&result->expr);
    1788                 :        244 :   if (m != MATCH_YES)
    1789                 :          0 :     goto cleanup;
    1790                 :            : 
    1791                 :        244 :   if (gfc_match_char (')') != MATCH_YES)
    1792                 :            :     {
    1793                 :          0 :       m = MATCH_NO;
    1794                 :          0 :       goto cleanup;
    1795                 :            :     }
    1796                 :            : 
    1797                 :            :   return MATCH_YES;
    1798                 :            : 
    1799                 :    1273440 : cleanup:
    1800                 :    1273440 :   gfc_current_locus = old_locus;
    1801                 :    1273440 :   return m;
    1802                 :            : }
    1803                 :            : 
    1804                 :            : 
    1805                 :            : /* Matches an actual argument list of a function or subroutine, from
    1806                 :            :    the opening parenthesis to the closing parenthesis.  The argument
    1807                 :            :    list is assumed to allow keyword arguments because we don't know if
    1808                 :            :    the symbol associated with the procedure has an implicit interface
    1809                 :            :    or not.  We make sure keywords are unique. If sub_flag is set,
    1810                 :            :    we're matching the argument list of a subroutine.
    1811                 :            : 
    1812                 :            :    NOTE: An alternative use for this function is to match type parameter
    1813                 :            :    spec lists, which are so similar to actual argument lists that the
    1814                 :            :    machinery can be reused. This use is flagged by the optional argument
    1815                 :            :    'pdt'.  */
    1816                 :            : 
    1817                 :            : match
    1818                 :    1360120 : gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
    1819                 :            : {
    1820                 :    1360120 :   gfc_actual_arglist *head, *tail;
    1821                 :    1360120 :   int seen_keyword;
    1822                 :    1360120 :   gfc_st_label *label;
    1823                 :    1360120 :   locus old_loc;
    1824                 :    1360120 :   match m;
    1825                 :            : 
    1826                 :    1360120 :   *argp = tail = NULL;
    1827                 :    1360120 :   old_loc = gfc_current_locus;
    1828                 :            : 
    1829                 :    1360120 :   seen_keyword = 0;
    1830                 :            : 
    1831                 :    1360120 :   if (gfc_match_char ('(') == MATCH_NO)
    1832                 :     821647 :     return (sub_flag) ? MATCH_YES : MATCH_NO;
    1833                 :            : 
    1834                 :     938897 :   if (gfc_match_char (')') == MATCH_YES)
    1835                 :            :     return MATCH_YES;
    1836                 :            : 
    1837                 :     920450 :   head = NULL;
    1838                 :            : 
    1839                 :     920450 :   matching_actual_arglist++;
    1840                 :            : 
    1841                 :    1300200 :   for (;;)
    1842                 :            :     {
    1843                 :    1300200 :       if (head == NULL)
    1844                 :     920450 :         head = tail = gfc_get_actual_arglist ();
    1845                 :            :       else
    1846                 :            :         {
    1847                 :     379747 :           tail->next = gfc_get_actual_arglist ();
    1848                 :     379747 :           tail = tail->next;
    1849                 :            :         }
    1850                 :            : 
    1851                 :    1300200 :       if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
    1852                 :            :         {
    1853                 :        234 :           m = gfc_match_st_label (&label);
    1854                 :        234 :           if (m == MATCH_NO)
    1855                 :          0 :             gfc_error ("Expected alternate return label at %C");
    1856                 :        234 :           if (m != MATCH_YES)
    1857                 :          0 :             goto cleanup;
    1858                 :            : 
    1859                 :        234 :           if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
    1860                 :            :                                "at %C"))
    1861                 :          0 :             goto cleanup;
    1862                 :            : 
    1863                 :        234 :           tail->label = label;
    1864                 :        234 :           goto next;
    1865                 :            :         }
    1866                 :            : 
    1867                 :    1299960 :       if (pdt && !seen_keyword)
    1868                 :            :         {
    1869                 :       1016 :           if (gfc_match_char (':') == MATCH_YES)
    1870                 :            :             {
    1871                 :        144 :               tail->spec_type = SPEC_DEFERRED;
    1872                 :        144 :               goto next;
    1873                 :            :             }
    1874                 :        872 :           else if (gfc_match_char ('*') == MATCH_YES)
    1875                 :            :             {
    1876                 :        169 :               tail->spec_type = SPEC_ASSUMED;
    1877                 :        169 :               goto next;
    1878                 :            :             }
    1879                 :            :           else
    1880                 :        703 :             tail->spec_type = SPEC_EXPLICIT;
    1881                 :            : 
    1882                 :        703 :           m = match_keyword_arg (tail, head, pdt);
    1883                 :        703 :           if (m == MATCH_YES)
    1884                 :            :             {
    1885                 :        197 :               seen_keyword = 1;
    1886                 :        197 :               goto next;
    1887                 :            :             }
    1888                 :        506 :           if (m == MATCH_ERROR)
    1889                 :          0 :             goto cleanup;
    1890                 :            :         }
    1891                 :            : 
    1892                 :            :       /* After the first keyword argument is seen, the following
    1893                 :            :          arguments must also have keywords.  */
    1894                 :    1299450 :       if (seen_keyword)
    1895                 :            :         {
    1896                 :      25765 :           m = match_keyword_arg (tail, head, pdt);
    1897                 :            : 
    1898                 :      25765 :           if (m == MATCH_ERROR)
    1899                 :         22 :             goto cleanup;
    1900                 :      25743 :           if (m == MATCH_NO)
    1901                 :            :             {
    1902                 :        535 :               gfc_error ("Missing keyword name in actual argument list at %C");
    1903                 :        535 :               goto cleanup;
    1904                 :            :             }
    1905                 :            : 
    1906                 :            :         }
    1907                 :            :       else
    1908                 :            :         {
    1909                 :            :           /* Try an argument list function, like %VAL.  */
    1910                 :    1273690 :           m = match_arg_list_function (tail);
    1911                 :    1273690 :           if (m == MATCH_ERROR)
    1912                 :          1 :             goto cleanup;
    1913                 :            : 
    1914                 :            :           /* See if we have the first keyword argument.  */
    1915                 :    1273690 :           if (m == MATCH_NO)
    1916                 :            :             {
    1917                 :    1273440 :               m = match_keyword_arg (tail, head, false);
    1918                 :    1273440 :               if (m == MATCH_YES)
    1919                 :      67388 :                 seen_keyword = 1;
    1920                 :    1273440 :               if (m == MATCH_ERROR)
    1921                 :        666 :                 goto cleanup;
    1922                 :            :             }
    1923                 :            : 
    1924                 :    1273020 :           if (m == MATCH_NO)
    1925                 :            :             {
    1926                 :            :               /* Try for a non-keyword argument.  */
    1927                 :    1205390 :               m = match_actual_arg (&tail->expr);
    1928                 :    1205390 :               if (m == MATCH_ERROR)
    1929                 :       1432 :                 goto cleanup;
    1930                 :    1203960 :               if (m == MATCH_NO)
    1931                 :      13514 :                 goto syntax;
    1932                 :            :             }
    1933                 :            :         }
    1934                 :            : 
    1935                 :            : 
    1936                 :      67632 :     next:
    1937                 :    1284030 :       if (gfc_match_char (')') == MATCH_YES)
    1938                 :            :         break;
    1939                 :     386158 :       if (gfc_match_char (',') != MATCH_YES)
    1940                 :       6411 :         goto syntax;
    1941                 :            :     }
    1942                 :            : 
    1943                 :     897869 :   *argp = head;
    1944                 :     897869 :   matching_actual_arglist--;
    1945                 :     897869 :   return MATCH_YES;
    1946                 :            : 
    1947                 :      19925 : syntax:
    1948                 :      19925 :   gfc_error ("Syntax error in argument list at %C");
    1949                 :            : 
    1950                 :      22581 : cleanup:
    1951                 :      22581 :   gfc_free_actual_arglist (head);
    1952                 :      22581 :   gfc_current_locus = old_loc;
    1953                 :      22581 :   matching_actual_arglist--;
    1954                 :      22581 :   return MATCH_ERROR;
    1955                 :            : }
    1956                 :            : 
    1957                 :            : 
    1958                 :            : /* Used by gfc_match_varspec() to extend the reference list by one
    1959                 :            :    element.  */
    1960                 :            : 
    1961                 :            : static gfc_ref *
    1962                 :     431431 : extend_ref (gfc_expr *primary, gfc_ref *tail)
    1963                 :            : {
    1964                 :     431431 :   if (primary->ref == NULL)
    1965                 :     394240 :     primary->ref = tail = gfc_get_ref ();
    1966                 :            :   else
    1967                 :            :     {
    1968                 :      37191 :       if (tail == NULL)
    1969                 :          0 :         gfc_internal_error ("extend_ref(): Bad tail");
    1970                 :      37191 :       tail->next = gfc_get_ref ();
    1971                 :      37191 :       tail = tail->next;
    1972                 :            :     }
    1973                 :            : 
    1974                 :     431431 :   return tail;
    1975                 :            : }
    1976                 :            : 
    1977                 :            : 
    1978                 :            : /* Used by gfc_match_varspec() to match an inquiry reference.  */
    1979                 :            : 
    1980                 :            : static bool
    1981                 :       1184 : is_inquiry_ref (const char *name, gfc_ref **ref)
    1982                 :            : {
    1983                 :       1184 :   inquiry_type type;
    1984                 :            : 
    1985                 :       1184 :   if (name == NULL)
    1986                 :            :     return false;
    1987                 :            : 
    1988                 :       1184 :   if (ref) *ref = NULL;
    1989                 :            : 
    1990                 :       1184 :   if (strcmp (name, "re") == 0)
    1991                 :            :     type = INQUIRY_RE;
    1992                 :        882 :   else if (strcmp (name, "im") == 0)
    1993                 :            :     type = INQUIRY_IM;
    1994                 :        614 :   else if (strcmp (name, "kind") == 0)
    1995                 :            :     type = INQUIRY_KIND;
    1996                 :        353 :   else if (strcmp (name, "len") == 0)
    1997                 :            :     type = INQUIRY_LEN;
    1998                 :            :   else
    1999                 :            :     return false;
    2000                 :            : 
    2001                 :       1036 :   if (ref)
    2002                 :            :     {
    2003                 :       1036 :       *ref = gfc_get_ref ();
    2004                 :       1036 :       (*ref)->type = REF_INQUIRY;
    2005                 :       1036 :       (*ref)->u.i = type;
    2006                 :            :     }
    2007                 :            : 
    2008                 :            :   return true;
    2009                 :            : }
    2010                 :            : 
    2011                 :            : 
    2012                 :            : /* Match any additional specifications associated with the current
    2013                 :            :    variable like member references or substrings.  If equiv_flag is
    2014                 :            :    set we only match stuff that is allowed inside an EQUIVALENCE
    2015                 :            :    statement.  sub_flag tells whether we expect a type-bound procedure found
    2016                 :            :    to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
    2017                 :            :    components, 'ppc_arg' determines whether the PPC may be called (with an
    2018                 :            :    argument list), or whether it may just be referred to as a pointer.  */
    2019                 :            : 
    2020                 :            : match
    2021                 :    2934420 : gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
    2022                 :            :                    bool ppc_arg)
    2023                 :            : {
    2024                 :    2934420 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    2025                 :    2934420 :   gfc_ref *substring, *tail, *tmp;
    2026                 :    2934420 :   gfc_component *component;
    2027                 :    2934420 :   gfc_symbol *sym = primary->symtree->n.sym;
    2028                 :    2934420 :   gfc_expr *tgt_expr = NULL;
    2029                 :    2934420 :   match m;
    2030                 :    2934420 :   bool unknown;
    2031                 :    2934420 :   bool inquiry;
    2032                 :    2934420 :   bool intrinsic;
    2033                 :    2934420 :   locus old_loc;
    2034                 :    2934420 :   char sep;
    2035                 :            : 
    2036                 :    2934420 :   tail = NULL;
    2037                 :            : 
    2038                 :    2934420 :   gfc_gobble_whitespace ();
    2039                 :            : 
    2040                 :    2934420 :   if (gfc_peek_ascii_char () == '[')
    2041                 :            :     {
    2042                 :       2574 :       if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
    2043                 :       2574 :           || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    2044                 :         79 :               && CLASS_DATA (sym)->attr.dimension))
    2045                 :            :         {
    2046                 :          0 :           gfc_error ("Array section designator, e.g. '(:)', is required "
    2047                 :            :                      "besides the coarray designator '[...]' at %C");
    2048                 :          0 :           return MATCH_ERROR;
    2049                 :            :         }
    2050                 :       2574 :       if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
    2051                 :       2573 :           || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
    2052                 :         79 :               && !CLASS_DATA (sym)->attr.codimension))
    2053                 :            :         {
    2054                 :          1 :           gfc_error ("Coarray designator at %C but %qs is not a coarray",
    2055                 :            :                      sym->name);
    2056                 :          1 :           return MATCH_ERROR;
    2057                 :            :         }
    2058                 :            :     }
    2059                 :            : 
    2060                 :    2934420 :   if (sym->assoc && sym->assoc->target)
    2061                 :       2920 :     tgt_expr = sym->assoc->target;
    2062                 :            : 
    2063                 :            :   /* For associate names, we may not yet know whether they are arrays or not.
    2064                 :            :      If the selector expression is unambiguously an array; eg. a full array
    2065                 :            :      or an array section, then the associate name must be an array and we can
    2066                 :            :      fix it now. Otherwise, if parentheses follow and it is not a character
    2067                 :            :      type, we have to assume that it actually is one for now.  The final
    2068                 :            :      decision will be made at resolution, of course.  */
    2069                 :    2934420 :   if (sym->assoc
    2070                 :      10746 :       && gfc_peek_ascii_char () == '('
    2071                 :       1963 :       && sym->ts.type != BT_CLASS
    2072                 :    2936290 :       && !sym->attr.dimension)
    2073                 :            :     {
    2074                 :        279 :       gfc_ref *ref = NULL;
    2075                 :            : 
    2076                 :        279 :       if (!sym->assoc->dangling && tgt_expr)
    2077                 :            :         {
    2078                 :        279 :            if (tgt_expr->expr_type == EXPR_VARIABLE)
    2079                 :        224 :              gfc_resolve_expr (tgt_expr);
    2080                 :            : 
    2081                 :        279 :            ref = tgt_expr->ref;
    2082                 :        468 :            for (; ref; ref = ref->next)
    2083                 :        393 :               if (ref->type == REF_ARRAY
    2084                 :        264 :                   && (ref->u.ar.type == AR_FULL
    2085                 :         84 :                       || ref->u.ar.type == AR_SECTION))
    2086                 :            :                 break;
    2087                 :            :         }
    2088                 :            : 
    2089                 :        279 :       if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
    2090                 :         57 :                   && sym->assoc->st
    2091                 :         57 :                   && sym->assoc->st->n.sym
    2092                 :         57 :                   && sym->assoc->st->n.sym->attr.dimension == 0))
    2093                 :            :         {
    2094                 :        261 :           sym->attr.dimension = 1;
    2095                 :        261 :           if (sym->as == NULL
    2096                 :        261 :               && sym->assoc->st
    2097                 :        261 :               && sym->assoc->st->n.sym
    2098                 :        261 :               && sym->assoc->st->n.sym->as)
    2099                 :          0 :             sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
    2100                 :            :         }
    2101                 :            :     }
    2102                 :    2934140 :   else if (sym->ts.type == BT_CLASS
    2103                 :      27338 :            && tgt_expr
    2104                 :         92 :            && tgt_expr->expr_type == EXPR_VARIABLE
    2105                 :         92 :            && sym->ts.u.derived != tgt_expr->ts.u.derived)
    2106                 :            :     {
    2107                 :         36 :       gfc_resolve_expr (tgt_expr);
    2108                 :         36 :       if (tgt_expr->rank)
    2109                 :         24 :         sym->ts.u.derived = tgt_expr->ts.u.derived;
    2110                 :            :     }
    2111                 :            : 
    2112                 :       2950 :   if ((equiv_flag && gfc_peek_ascii_char () == '(')
    2113                 :    2932850 :       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
    2114                 :    2916950 :       || (sym->attr.dimension && sym->ts.type != BT_CLASS
    2115                 :     368096 :           && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
    2116                 :     368111 :           && !(gfc_matching_procptr_assignment
    2117                 :     368081 :                && sym->attr.flavor == FL_PROCEDURE))
    2118                 :    5483310 :       || (sym->ts.type == BT_CLASS && sym->attr.class_ok
    2119                 :      27212 :           && (CLASS_DATA (sym)->attr.dimension
    2120                 :      27212 :               || CLASS_DATA (sym)->attr.codimension)))
    2121                 :            :     {
    2122                 :     394240 :       gfc_array_spec *as;
    2123                 :            : 
    2124                 :     394240 :       tail = extend_ref (primary, tail);
    2125                 :     394240 :       tail->type = REF_ARRAY;
    2126                 :            : 
    2127                 :            :       /* In EQUIVALENCE, we don't know yet whether we are seeing
    2128                 :            :          an array, character variable or array of character
    2129                 :            :          variables.  We'll leave the decision till resolve time.  */
    2130                 :            : 
    2131                 :     394240 :       if (equiv_flag)
    2132                 :            :         as = NULL;
    2133                 :     392241 :       else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
    2134                 :       8793 :         as = CLASS_DATA (sym)->as;
    2135                 :            :       else
    2136                 :     383448 :         as = sym->as;
    2137                 :            : 
    2138                 :     394240 :       m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
    2139                 :            :                                as ? as->corank : 0);
    2140                 :     394240 :       if (m != MATCH_YES)
    2141                 :            :         return m;
    2142                 :            : 
    2143                 :     394193 :       gfc_gobble_whitespace ();
    2144                 :     394193 :       if (equiv_flag && gfc_peek_ascii_char () == '(')
    2145                 :            :         {
    2146                 :         74 :           tail = extend_ref (primary, tail);
    2147                 :         74 :           tail->type = REF_ARRAY;
    2148                 :            : 
    2149                 :         74 :           m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
    2150                 :         74 :           if (m != MATCH_YES)
    2151                 :            :             return m;
    2152                 :            :         }
    2153                 :            :     }
    2154                 :            : 
    2155                 :    2934370 :   primary->ts = sym->ts;
    2156                 :            : 
    2157                 :    2934370 :   if (equiv_flag)
    2158                 :            :     return MATCH_YES;
    2159                 :            : 
    2160                 :            :   /* With DEC extensions, member separator may be '.' or '%'.  */
    2161                 :    2931420 :   sep = gfc_peek_ascii_char ();
    2162                 :    2931420 :   m = gfc_match_member_sep (sym);
    2163                 :    2931420 :   if (m == MATCH_ERROR)
    2164                 :            :     return MATCH_ERROR;
    2165                 :            : 
    2166                 :    2931420 :   inquiry = false;
    2167                 :    2931420 :   if (m == MATCH_YES && sep == '%'
    2168                 :      84570 :       && primary->ts.type != BT_CLASS
    2169                 :      71422 :       && primary->ts.type != BT_DERIVED)
    2170                 :            :     {
    2171                 :        532 :       match mm;
    2172                 :        532 :       old_loc = gfc_current_locus;
    2173                 :        532 :       mm = gfc_match_name (name);
    2174                 :        532 :       if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
    2175                 :            :         inquiry = true;
    2176                 :        532 :       gfc_current_locus = old_loc;
    2177                 :            :     }
    2178                 :            : 
    2179                 :    1728260 :   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
    2180                 :    2931500 :       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
    2181                 :          1 :     gfc_set_default_type (sym, 0, sym->ns);
    2182                 :            : 
    2183                 :            :   /* See if there is a usable typespec in the "no IMPLICIT type" error.  */
    2184                 :    2931420 :   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
    2185                 :            :     {
    2186                 :         76 :       bool permissible;
    2187                 :            : 
    2188                 :            :       /* These target expressions can be resolved at any time.  */
    2189                 :         66 :       permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
    2190                 :         76 :                     && (tgt_expr->symtree->n.sym->attr.use_assoc
    2191                 :         60 :                         || tgt_expr->symtree->n.sym->attr.host_assoc
    2192                 :          6 :                         || tgt_expr->symtree->n.sym->attr.if_source
    2193                 :          6 :                                                                 == IFSRC_DECL);
    2194                 :        158 :       permissible = permissible
    2195                 :         16 :                     || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
    2196                 :            : 
    2197                 :            :       if (permissible)
    2198                 :            :         {
    2199                 :         66 :           gfc_resolve_expr (tgt_expr);
    2200                 :         66 :           sym->ts = tgt_expr->ts;
    2201                 :            :         }
    2202                 :            : 
    2203                 :         76 :       if (sym->ts.type == BT_UNKNOWN)
    2204                 :            :         {
    2205                 :         10 :           gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
    2206                 :         10 :           return MATCH_ERROR;
    2207                 :            :         }
    2208                 :            :     }
    2209                 :    2931340 :   else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
    2210                 :    2801440 :            && m == MATCH_YES && !inquiry)
    2211                 :            :     {
    2212                 :          3 :       gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
    2213                 :            :                  sep, sym->name);
    2214                 :          3 :       return MATCH_ERROR;
    2215                 :            :     }
    2216                 :            : 
    2217                 :    2931410 :   if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
    2218                 :     130418 :       || m != MATCH_YES)
    2219                 :    2844770 :     goto check_substring;
    2220                 :            : 
    2221                 :      86640 :   if (!inquiry)
    2222                 :      86187 :     sym = sym->ts.u.derived;
    2223                 :            :   else
    2224                 :            :     sym = NULL;
    2225                 :            : 
    2226                 :     100857 :   for (;;)
    2227                 :            :     {
    2228                 :     100857 :       bool t;
    2229                 :     100857 :       gfc_symtree *tbp;
    2230                 :            : 
    2231                 :     100857 :       m = gfc_match_name (name);
    2232                 :     100857 :       if (m == MATCH_NO)
    2233                 :          0 :         gfc_error ("Expected structure component name at %C");
    2234                 :     100857 :       if (m != MATCH_YES)
    2235                 :         71 :         return MATCH_ERROR;
    2236                 :            : 
    2237                 :     100857 :       intrinsic = false;
    2238                 :     100857 :       if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
    2239                 :            :         {
    2240                 :        652 :           inquiry = is_inquiry_ref (name, &tmp);
    2241                 :        652 :           if (inquiry)
    2242                 :        583 :             sym = NULL;
    2243                 :            : 
    2244                 :        652 :           if (sep == '%')
    2245                 :            :             {
    2246                 :        652 :               if (tmp)
    2247                 :            :                 {
    2248                 :        583 :                   if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
    2249                 :        321 :                       && primary->ts.type != BT_COMPLEX)
    2250                 :            :                     {
    2251                 :         12 :                         gfc_error ("The RE or IM part_ref at %C must be "
    2252                 :            :                                    "applied to a COMPLEX expression");
    2253                 :         12 :                         return MATCH_ERROR;
    2254                 :            :                     }
    2255                 :        571 :                   else if (tmp->u.i == INQUIRY_LEN
    2256                 :        115 :                            && primary->ts.type != BT_CHARACTER)
    2257                 :            :                     {
    2258                 :          5 :                         gfc_error ("The LEN part_ref at %C must be applied "
    2259                 :            :                                    "to a CHARACTER expression");
    2260                 :          5 :                         return MATCH_ERROR;
    2261                 :            :                     }
    2262                 :            :                 }
    2263                 :        635 :               if (primary->ts.type != BT_UNKNOWN)
    2264                 :        568 :                 intrinsic = true;
    2265                 :            :             }
    2266                 :            :         }
    2267                 :            :       else
    2268                 :            :         inquiry = false;
    2269                 :            : 
    2270                 :     100840 :       if (sym && sym->f2k_derived)
    2271                 :      95721 :         tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
    2272                 :            :       else
    2273                 :            :         tbp = NULL;
    2274                 :            : 
    2275                 :      95721 :       if (tbp)
    2276                 :            :         {
    2277                 :       3312 :           gfc_symbol* tbp_sym;
    2278                 :            : 
    2279                 :       3312 :           if (!t)
    2280                 :            :             return MATCH_ERROR;
    2281                 :            : 
    2282                 :       3310 :           gcc_assert (!tail || !tail->next);
    2283                 :            : 
    2284                 :       3310 :           if (!(primary->expr_type == EXPR_VARIABLE
    2285                 :            :                 || (primary->expr_type == EXPR_STRUCTURE
    2286                 :          1 :                     && primary->symtree && primary->symtree->n.sym
    2287                 :          1 :                     && primary->symtree->n.sym->attr.flavor)))
    2288                 :            :             return MATCH_ERROR;
    2289                 :            : 
    2290                 :       3308 :           if (tbp->n.tb->is_generic)
    2291                 :            :             tbp_sym = NULL;
    2292                 :            :           else
    2293                 :       2688 :             tbp_sym = tbp->n.tb->u.specific->n.sym;
    2294                 :            : 
    2295                 :       3308 :           primary->expr_type = EXPR_COMPCALL;
    2296                 :       3308 :           primary->value.compcall.tbp = tbp->n.tb;
    2297                 :       3308 :           primary->value.compcall.name = tbp->name;
    2298                 :       3308 :           primary->value.compcall.ignore_pass = 0;
    2299                 :       3308 :           primary->value.compcall.assign = 0;
    2300                 :       3308 :           primary->value.compcall.base_object = NULL;
    2301                 :       3308 :           gcc_assert (primary->symtree->n.sym->attr.referenced);
    2302                 :       3308 :           if (tbp_sym)
    2303                 :       2688 :             primary->ts = tbp_sym->ts;
    2304                 :            :           else
    2305                 :        620 :             gfc_clear_ts (&primary->ts);
    2306                 :            : 
    2307                 :       3308 :           m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
    2308                 :            :                                         &primary->value.compcall.actual);
    2309                 :       3308 :           if (m == MATCH_ERROR)
    2310                 :            :             return MATCH_ERROR;
    2311                 :       3308 :           if (m == MATCH_NO)
    2312                 :            :             {
    2313                 :        160 :               if (sub_flag)
    2314                 :        159 :                 primary->value.compcall.actual = NULL;
    2315                 :            :               else
    2316                 :            :                 {
    2317                 :          1 :                   gfc_error ("Expected argument list at %C");
    2318                 :          1 :                   return MATCH_ERROR;
    2319                 :            :                 }
    2320                 :            :             }
    2321                 :            : 
    2322                 :      86569 :           break;
    2323                 :            :         }
    2324                 :            : 
    2325                 :      97528 :       if (!inquiry && !intrinsic)
    2326                 :      96961 :         component = gfc_find_component (sym, name, false, false, &tmp);
    2327                 :            :       else
    2328                 :            :         component = NULL;
    2329                 :            : 
    2330                 :            :       /* In some cases, returning MATCH_NO gives a better error message. Most
    2331                 :            :          cases return "Unclassifiable statement at..."  */
    2332                 :      97528 :       if (intrinsic && !inquiry)
    2333                 :            :         return MATCH_NO;
    2334                 :      97527 :       else if (component == NULL && !inquiry)
    2335                 :            :         return MATCH_ERROR;
    2336                 :            : 
    2337                 :            :       /* Extend the reference chain determined by gfc_find_component or
    2338                 :            :          is_inquiry_ref.  */
    2339                 :      97485 :       if (primary->ref == NULL)
    2340                 :      55546 :         primary->ref = tmp;
    2341                 :            :       else
    2342                 :            :         {
    2343                 :            :           /* Set by the for loop below for the last component ref.  */
    2344                 :      41939 :           gcc_assert (tail != NULL);
    2345                 :      41939 :           tail->next = tmp;
    2346                 :            :         }
    2347                 :            : 
    2348                 :            :       /* The reference chain may be longer than one hop for union
    2349                 :            :          subcomponents; find the new tail.  */
    2350                 :      99461 :       for (tail = tmp; tail->next; tail = tail->next)
    2351                 :            :         ;
    2352                 :            : 
    2353                 :      97485 :       if (tmp && tmp->type == REF_INQUIRY)
    2354                 :            :         {
    2355                 :        566 :           if (!primary->where.lb || !primary->where.nextc)
    2356                 :        325 :             primary->where = gfc_current_locus;
    2357                 :        566 :           gfc_simplify_expr (primary, 0);
    2358                 :            : 
    2359                 :        566 :           if (primary->expr_type == EXPR_CONSTANT)
    2360                 :        260 :             goto check_done;
    2361                 :            : 
    2362                 :        306 :           switch (tmp->u.i)
    2363                 :            :             {
    2364                 :        225 :             case INQUIRY_RE:
    2365                 :        225 :             case INQUIRY_IM:
    2366                 :        225 :               if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
    2367                 :            :                 return MATCH_ERROR;
    2368                 :            : 
    2369                 :        223 :               if (primary->ts.type != BT_COMPLEX)
    2370                 :            :                 {
    2371                 :          0 :                   gfc_error ("The RE or IM part_ref at %C must be "
    2372                 :            :                              "applied to a COMPLEX expression");
    2373                 :          0 :                   return MATCH_ERROR;
    2374                 :            :                 }
    2375                 :        223 :               primary->ts.type = BT_REAL;
    2376                 :        223 :               break;
    2377                 :            : 
    2378                 :         52 :             case INQUIRY_LEN:
    2379                 :         52 :               if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
    2380                 :            :                 return MATCH_ERROR;
    2381                 :            : 
    2382                 :         50 :               if (primary->ts.type != BT_CHARACTER)
    2383                 :            :                 {
    2384                 :          0 :                   gfc_error ("The LEN part_ref at %C must be applied "
    2385                 :            :                              "to a CHARACTER expression");
    2386                 :          0 :                   return MATCH_ERROR;
    2387                 :            :                 }
    2388                 :         50 :               primary->ts.u.cl = NULL;
    2389                 :         50 :               primary->ts.type = BT_INTEGER;
    2390                 :         50 :               primary->ts.kind = gfc_default_integer_kind;
    2391                 :         50 :               break;
    2392                 :            : 
    2393                 :         29 :             case INQUIRY_KIND:
    2394                 :         29 :               if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
    2395                 :            :                 return MATCH_ERROR;
    2396                 :            : 
    2397                 :         28 :               if (primary->ts.type == BT_CLASS
    2398                 :         28 :                   || primary->ts.type == BT_DERIVED)
    2399                 :            :                 {
    2400                 :          0 :                   gfc_error ("The KIND part_ref at %C must be applied "
    2401                 :            :                              "to an expression of intrinsic type");
    2402                 :          0 :                   return MATCH_ERROR;
    2403                 :            :                 }
    2404                 :         28 :               primary->ts.type = BT_INTEGER;
    2405                 :         28 :               primary->ts.kind = gfc_default_integer_kind;
    2406                 :         28 :               break;
    2407                 :            : 
    2408                 :          0 :             default:
    2409                 :          0 :               gcc_unreachable ();
    2410                 :            :             }
    2411                 :            : 
    2412                 :        301 :           goto check_done;
    2413                 :            :         }
    2414                 :            : 
    2415                 :      96919 :       primary->ts = component->ts;
    2416                 :            : 
    2417                 :      96919 :       if (component->attr.proc_pointer && ppc_arg)
    2418                 :            :         {
    2419                 :            :           /* Procedure pointer component call: Look for argument list.  */
    2420                 :        790 :           m = gfc_match_actual_arglist (sub_flag,
    2421                 :            :                                         &primary->value.compcall.actual);
    2422                 :        790 :           if (m == MATCH_ERROR)
    2423                 :            :             return MATCH_ERROR;
    2424                 :            : 
    2425                 :        790 :           if (m == MATCH_NO && !gfc_matching_ptr_assignment
    2426                 :        244 :               && !gfc_matching_procptr_assignment && !matching_actual_arglist)
    2427                 :            :             {
    2428                 :          1 :               gfc_error ("Procedure pointer component %qs requires an "
    2429                 :            :                          "argument list at %C", component->name);
    2430                 :          1 :               return MATCH_ERROR;
    2431                 :            :             }
    2432                 :            : 
    2433                 :        789 :           if (m == MATCH_YES)
    2434                 :        545 :             primary->expr_type = EXPR_PPC;
    2435                 :            : 
    2436                 :            :           break;
    2437                 :            :         }
    2438                 :            : 
    2439                 :      96129 :       if (component->as != NULL && !component->attr.proc_pointer)
    2440                 :            :         {
    2441                 :      35045 :           tail = extend_ref (primary, tail);
    2442                 :      35045 :           tail->type = REF_ARRAY;
    2443                 :            : 
    2444                 :      70090 :           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
    2445                 :      35045 :                           component->as->corank);
    2446                 :      35045 :           if (m != MATCH_YES)
    2447                 :          0 :             return m;
    2448                 :            :         }
    2449                 :      61084 :       else if (component->ts.type == BT_CLASS && component->attr.class_ok
    2450                 :       4441 :                && CLASS_DATA (component)->as && !component->attr.proc_pointer)
    2451                 :            :         {
    2452                 :       2072 :           tail = extend_ref (primary, tail);
    2453                 :       2072 :           tail->type = REF_ARRAY;
    2454                 :            : 
    2455                 :       4144 :           m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
    2456                 :            :                                    equiv_flag,
    2457                 :       2072 :                                    CLASS_DATA (component)->as->corank);
    2458                 :       2072 :           if (m != MATCH_YES)
    2459                 :          0 :             return m;
    2460                 :            :         }
    2461                 :            : 
    2462                 :      59012 : check_done:
    2463                 :            :       /* In principle, we could have eg. expr%re%kind so we must allow for
    2464                 :            :          this possibility.  */
    2465                 :      96690 :       if (gfc_match_char ('%') == MATCH_YES)
    2466                 :            :         {
    2467                 :      13847 :           if (component && (component->ts.type == BT_DERIVED
    2468                 :       1311 :                             || component->ts.type == BT_CLASS))
    2469                 :      13715 :             sym = component->ts.u.derived;
    2470                 :      13847 :           continue;
    2471                 :            :         }
    2472                 :      82843 :       else if (inquiry)
    2473                 :            :         break;
    2474                 :            : 
    2475                 :      75703 :       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
    2476                 :      85544 :           || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
    2477                 :            :         break;
    2478                 :            : 
    2479                 :        370 :       if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
    2480                 :        370 :         sym = component->ts.u.derived;
    2481                 :            :     }
    2482                 :            : 
    2483                 :    2931340 : check_substring:
    2484                 :    2931340 :   unknown = false;
    2485                 :    2931340 :   if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
    2486                 :            :     {
    2487                 :    1728180 :       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
    2488                 :            :        {
    2489                 :        352 :          gfc_set_default_type (sym, 0, sym->ns);
    2490                 :        352 :          primary->ts = sym->ts;
    2491                 :        352 :          unknown = true;
    2492                 :            :        }
    2493                 :            :     }
    2494                 :            : 
    2495                 :    2931340 :   if (primary->ts.type == BT_CHARACTER)
    2496                 :            :     {
    2497                 :     176067 :       bool def = primary->ts.deferred == 1;
    2498                 :     176067 :       switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
    2499                 :            :         {
    2500                 :       9862 :         case MATCH_YES:
    2501                 :       9862 :           if (tail == NULL)
    2502                 :       7941 :             primary->ref = substring;
    2503                 :            :           else
    2504                 :       1921 :             tail->next = substring;
    2505                 :            : 
    2506                 :       9862 :           if (primary->expr_type == EXPR_CONSTANT)
    2507                 :        723 :             primary->expr_type = EXPR_SUBSTRING;
    2508                 :            : 
    2509                 :       9862 :           if (substring)
    2510                 :       9655 :             primary->ts.u.cl = NULL;
    2511                 :            : 
    2512                 :            :           break;
    2513                 :            : 
    2514                 :     166205 :         case MATCH_NO:
    2515                 :     166205 :           if (unknown)
    2516                 :            :             {
    2517                 :        351 :               gfc_clear_ts (&primary->ts);
    2518                 :        351 :               gfc_clear_ts (&sym->ts);
    2519                 :            :             }
    2520                 :            :           break;
    2521                 :            : 
    2522                 :            :         case MATCH_ERROR:
    2523                 :            :           return MATCH_ERROR;
    2524                 :            :         }
    2525                 :            :     }
    2526                 :            : 
    2527                 :            :   /* F08:C611.  */
    2528                 :    2931340 :   if (primary->ts.type == BT_DERIVED && primary->ref
    2529                 :      14574 :       && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
    2530                 :            :     {
    2531                 :          6 :       gfc_error ("Nonpolymorphic reference to abstract type at %C");
    2532                 :          6 :       return MATCH_ERROR;
    2533                 :            :     }
    2534                 :            : 
    2535                 :            :   /* F08:C727.  */
    2536                 :    2931330 :   if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
    2537                 :            :     {
    2538                 :          3 :       gfc_error ("Coindexed procedure-pointer component at %C");
    2539                 :          3 :       return MATCH_ERROR;
    2540                 :            :     }
    2541                 :            : 
    2542                 :            :   return MATCH_YES;
    2543                 :            : }
    2544                 :            : 
    2545                 :            : 
    2546                 :            : /* Given an expression that is a variable, figure out what the
    2547                 :            :    ultimate variable's type and attribute is, traversing the reference
    2548                 :            :    structures if necessary.
    2549                 :            : 
    2550                 :            :    This subroutine is trickier than it looks.  We start at the base
    2551                 :            :    symbol and store the attribute.  Component references load a
    2552                 :            :    completely new attribute.
    2553                 :            : 
    2554                 :            :    A couple of rules come into play.  Subobjects of targets are always
    2555                 :            :    targets themselves.  If we see a component that goes through a
    2556                 :            :    pointer, then the expression must also be a target, since the
    2557                 :            :    pointer is associated with something (if it isn't core will soon be
    2558                 :            :    dumped).  If we see a full part or section of an array, the
    2559                 :            :    expression is also an array.
    2560                 :            : 
    2561                 :            :    We can have at most one full array reference.  */
    2562                 :            : 
    2563                 :            : symbol_attribute
    2564                 :    2123800 : gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
    2565                 :            : {
    2566                 :    2123800 :   int dimension, codimension, pointer, allocatable, target;
    2567                 :    2123800 :   symbol_attribute attr;
    2568                 :    2123800 :   gfc_ref *ref;
    2569                 :    2123800 :   gfc_symbol *sym;
    2570                 :    2123800 :   gfc_component *comp;
    2571                 :    2123800 :   bool has_inquiry_part;
    2572                 :            : 
    2573                 :    2123800 :   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
    2574                 :          0 :     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
    2575                 :            : 
    2576                 :    2123800 :   sym = expr->symtree->n.sym;
    2577                 :    2123800 :   attr = sym->attr;
    2578                 :            : 
    2579                 :    2123800 :   if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
    2580                 :            :     {
    2581                 :      68289 :       dimension = CLASS_DATA (sym)->attr.dimension;
    2582                 :      68289 :       codimension = CLASS_DATA (sym)->attr.codimension;
    2583                 :      68289 :       pointer = CLASS_DATA (sym)->attr.class_pointer;
    2584                 :      68289 :       allocatable = CLASS_DATA (sym)->attr.allocatable;
    2585                 :            :     }
    2586                 :            :   else
    2587                 :            :     {
    2588                 :    2055510 :       dimension = attr.dimension;
    2589                 :    2055510 :       codimension = attr.codimension;
    2590                 :    2055510 :       pointer = attr.pointer;
    2591                 :    2055510 :       allocatable = attr.allocatable;
    2592                 :            :     }
    2593                 :            : 
    2594                 :    2123800 :   target = attr.target;
    2595                 :    2123800 :   if (pointer || attr.proc_pointer)
    2596                 :     107418 :     target = 1;
    2597                 :            : 
    2598                 :    2123800 :   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
    2599                 :      45931 :     *ts = sym->ts;
    2600                 :            : 
    2601                 :    2123800 :   has_inquiry_part = false;
    2602                 :    2993620 :   for (ref = expr->ref; ref; ref = ref->next)
    2603                 :     870540 :     if (ref->type == REF_INQUIRY)
    2604                 :            :       {
    2605                 :            :         has_inquiry_part = true;
    2606                 :            :         break;
    2607                 :            :       }
    2608                 :            : 
    2609                 :    2994350 :   for (ref = expr->ref; ref; ref = ref->next)
    2610                 :     870547 :     switch (ref->type)
    2611                 :            :       {
    2612                 :     674698 :       case REF_ARRAY:
    2613                 :            : 
    2614                 :     674698 :         switch (ref->u.ar.type)
    2615                 :            :           {
    2616                 :     378493 :           case AR_FULL:
    2617                 :     378493 :             dimension = 1;
    2618                 :     378493 :             break;
    2619                 :            : 
    2620                 :      70555 :           case AR_SECTION:
    2621                 :      70555 :             allocatable = pointer = 0;
    2622                 :      70555 :             dimension = 1;
    2623                 :      70555 :             break;
    2624                 :            : 
    2625                 :     225646 :           case AR_ELEMENT:
    2626                 :            :             /* Handle coarrays.  */
    2627                 :     225646 :             if (ref->u.ar.dimen > 0)
    2628                 :     210399 :               allocatable = pointer = 0;
    2629                 :            :             break;
    2630                 :            : 
    2631                 :            :           case AR_UNKNOWN:
    2632                 :            :             /* For standard conforming code, AR_UNKNOWN should not happen.
    2633                 :            :                For nonconforming code, gfortran can end up here.  Treat it
    2634                 :            :                as a no-op.  */
    2635                 :            :             break;
    2636                 :            :           }
    2637                 :            : 
    2638                 :            :         break;
    2639                 :            : 
    2640                 :     184374 :       case REF_COMPONENT:
    2641                 :     184374 :         comp = ref->u.c.component;
    2642                 :     184374 :         attr = comp->attr;
    2643                 :     184374 :         if (ts != NULL && !has_inquiry_part)
    2644                 :            :           {
    2645                 :      50887 :             *ts = comp->ts;
    2646                 :            :             /* Don't set the string length if a substring reference
    2647                 :            :                follows.  */
    2648                 :      50887 :             if (ts->type == BT_CHARACTER
    2649                 :       6047 :                 && ref->next && ref->next->type == REF_SUBSTRING)
    2650                 :        137 :                 ts->u.cl = NULL;
    2651                 :            :           }
    2652                 :            : 
    2653                 :     184374 :         if (comp->ts.type == BT_CLASS)
    2654                 :            :           {
    2655                 :      10536 :             codimension = CLASS_DATA (comp)->attr.codimension;
    2656                 :      10536 :             pointer = CLASS_DATA (comp)->attr.class_pointer;
    2657                 :      10536 :             allocatable = CLASS_DATA (comp)->attr.allocatable;
    2658                 :            :           }
    2659                 :            :         else
    2660                 :            :           {
    2661                 :     173838 :             codimension = comp->attr.codimension;
    2662                 :     173838 :             pointer = comp->attr.pointer;
    2663                 :     173838 :             allocatable = comp->attr.allocatable;
    2664                 :            :           }
    2665                 :     184374 :         if (pointer || attr.proc_pointer)
    2666                 :      26590 :           target = 1;
    2667                 :            : 
    2668                 :            :         break;
    2669                 :            : 
    2670                 :      11475 :       case REF_INQUIRY:
    2671                 :      11475 :       case REF_SUBSTRING:
    2672                 :      11475 :         allocatable = pointer = 0;
    2673                 :      11475 :         break;
    2674                 :            :       }
    2675                 :            : 
    2676                 :    2123800 :   attr.dimension = dimension;
    2677                 :    2123800 :   attr.codimension = codimension;
    2678                 :    2123800 :   attr.pointer = pointer;
    2679                 :    2123800 :   attr.allocatable = allocatable;
    2680                 :    2123800 :   attr.target = target;
    2681                 :    2123800 :   attr.save = sym->attr.save;
    2682                 :            : 
    2683                 :    2123800 :   return attr;
    2684                 :            : }
    2685                 :            : 
    2686                 :            : 
    2687                 :            : /* Return the attribute from a general expression.  */
    2688                 :            : 
    2689                 :            : symbol_attribute
    2690                 :    1800450 : gfc_expr_attr (gfc_expr *e)
    2691                 :            : {
    2692                 :    1800450 :   symbol_attribute attr;
    2693                 :            : 
    2694                 :    1800450 :   switch (e->expr_type)
    2695                 :            :     {
    2696                 :    1384290 :     case EXPR_VARIABLE:
    2697                 :    1384290 :       attr = gfc_variable_attr (e, NULL);
    2698                 :    1384290 :       break;
    2699                 :            : 
    2700                 :      18158 :     case EXPR_FUNCTION:
    2701                 :      18158 :       gfc_clear_attr (&attr);
    2702                 :            : 
    2703                 :      18158 :       if (e->value.function.esym && e->value.function.esym->result)
    2704                 :            :         {
    2705                 :       7323 :           gfc_symbol *sym = e->value.function.esym->result;
    2706                 :       7323 :           attr = sym->attr;
    2707                 :       7323 :           if (sym->ts.type == BT_CLASS)
    2708                 :            :             {
    2709                 :        567 :               attr.dimension = CLASS_DATA (sym)->attr.dimension;
    2710                 :        567 :               attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
    2711                 :        567 :               attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
    2712                 :            :             }
    2713                 :            :         }
    2714                 :      10835 :       else if (e->value.function.isym
    2715                 :      10028 :                && e->value.function.isym->transformational
    2716                 :       1498 :                && e->ts.type == BT_CLASS)
    2717                 :         30 :         attr = CLASS_DATA (e)->attr;
    2718                 :            :       else
    2719                 :      10805 :         attr = gfc_variable_attr (e, NULL);
    2720                 :            : 
    2721                 :            :       /* TODO: NULL() returns pointers.  May have to take care of this
    2722                 :            :          here.  */
    2723                 :            : 
    2724                 :            :       break;
    2725                 :            : 
    2726                 :     398006 :     default:
    2727                 :     398006 :       gfc_clear_attr (&attr);
    2728                 :     398006 :       break;
    2729                 :            :     }
    2730                 :            : 
    2731                 :    1800450 :   return attr;
    2732                 :            : }
    2733                 :            : 
    2734                 :            : 
    2735                 :            : /* Given an expression, figure out what the ultimate expression
    2736                 :            :    attribute is.  This routine is similar to gfc_variable_attr with
    2737                 :            :    parts of gfc_expr_attr, but focuses more on the needs of
    2738                 :            :    coarrays.  For coarrays a codimension attribute is kind of
    2739                 :            :    "infectious" being propagated once set and never cleared.
    2740                 :            :    The coarray_comp is only set, when the expression refs a coarray
    2741                 :            :    component.  REFS_COMP is set when present to true only, when this EXPR
    2742                 :            :    refs a (non-_data) component.  To check whether EXPR refs an allocatable
    2743                 :            :    component in a derived type coarray *refs_comp needs to be set and
    2744                 :            :    coarray_comp has to false.  */
    2745                 :            : 
    2746                 :            : static symbol_attribute
    2747                 :       7403 : caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
    2748                 :            : {
    2749                 :       7403 :   int dimension, codimension, pointer, allocatable, target, coarray_comp;
    2750                 :       7403 :   symbol_attribute attr;
    2751                 :       7403 :   gfc_ref *ref;
    2752                 :       7403 :   gfc_symbol *sym;
    2753                 :       7403 :   gfc_component *comp;
    2754                 :            : 
    2755                 :       7403 :   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
    2756                 :          0 :     gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
    2757                 :            : 
    2758                 :       7403 :   sym = expr->symtree->n.sym;
    2759                 :       7403 :   gfc_clear_attr (&attr);
    2760                 :            : 
    2761                 :       7403 :   if (refs_comp)
    2762                 :       3786 :     *refs_comp = false;
    2763                 :            : 
    2764                 :       7403 :   if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
    2765                 :            :     {
    2766                 :        334 :       dimension = CLASS_DATA (sym)->attr.dimension;
    2767                 :        334 :       codimension = CLASS_DATA (sym)->attr.codimension;
    2768                 :        334 :       pointer = CLASS_DATA (sym)->attr.class_pointer;
    2769                 :        334 :       allocatable = CLASS_DATA (sym)->attr.allocatable;
    2770                 :        334 :       attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
    2771                 :        334 :       attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
    2772                 :            :     }
    2773                 :            :   else
    2774                 :            :     {
    2775                 :       7069 :       dimension = sym->attr.dimension;
    2776                 :       7069 :       codimension = sym->attr.codimension;
    2777                 :       7069 :       pointer = sym->attr.pointer;
    2778                 :       7069 :       allocatable = sym->attr.allocatable;
    2779                 :      14138 :       attr.alloc_comp = sym->ts.type == BT_DERIVED
    2780                 :       7069 :           ? sym->ts.u.derived->attr.alloc_comp : 0;
    2781                 :       7069 :       attr.pointer_comp = sym->ts.type == BT_DERIVED
    2782                 :       7069 :           ? sym->ts.u.derived->attr.pointer_comp : 0;
    2783                 :            :     }
    2784                 :            : 
    2785                 :       7403 :   target = coarray_comp = 0;
    2786                 :       7403 :   if (pointer || attr.proc_pointer)
    2787                 :        233 :     target = 1;
    2788                 :            : 
    2789                 :      16275 :   for (ref = expr->ref; ref; ref = ref->next)
    2790                 :       8872 :     switch (ref->type)
    2791                 :            :       {
    2792                 :       5608 :       case REF_ARRAY:
    2793                 :            : 
    2794                 :       5608 :         switch (ref->u.ar.type)
    2795                 :            :           {
    2796                 :            :           case AR_FULL:
    2797                 :            :           case AR_SECTION:
    2798                 :            :             dimension = 1;
    2799                 :       5608 :             break;
    2800                 :            : 
    2801                 :       3643 :           case AR_ELEMENT:
    2802                 :            :             /* Handle coarrays.  */
    2803                 :       3643 :             if (ref->u.ar.dimen > 0 && !in_allocate)
    2804                 :        765 :               allocatable = pointer = 0;
    2805                 :            :             break;
    2806                 :            : 
    2807                 :          0 :           case AR_UNKNOWN:
    2808                 :            :             /* If any of start, end or stride is not integer, there will
    2809                 :            :                already have been an error issued.  */
    2810                 :          0 :             int errors;
    2811                 :          0 :             gfc_get_errors (NULL, &errors);
    2812                 :          0 :             if (errors == 0)
    2813                 :          0 :               gfc_internal_error ("gfc_caf_attr(): Bad array reference");
    2814                 :            :           }
    2815                 :            : 
    2816                 :            :         break;
    2817                 :            : 
    2818                 :       3264 :       case REF_COMPONENT:
    2819                 :       3264 :         comp = ref->u.c.component;
    2820                 :            : 
    2821                 :       3264 :         if (comp->ts.type == BT_CLASS)
    2822                 :            :           {
    2823                 :            :             /* Set coarray_comp only, when this component introduces the
    2824                 :            :                coarray.  */
    2825                 :         12 :             coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
    2826                 :         12 :             codimension |= CLASS_DATA (comp)->attr.codimension;
    2827                 :         12 :             pointer = CLASS_DATA (comp)->attr.class_pointer;
    2828                 :         12 :             allocatable = CLASS_DATA (comp)->attr.allocatable;
    2829                 :            :           }
    2830                 :            :         else
    2831                 :            :           {
    2832                 :            :             /* Set coarray_comp only, when this component introduces the
    2833                 :            :                coarray.  */
    2834                 :       3252 :             coarray_comp = !codimension && comp->attr.codimension;
    2835                 :       3252 :             codimension |= comp->attr.codimension;
    2836                 :       3252 :             pointer = comp->attr.pointer;
    2837                 :       3252 :             allocatable = comp->attr.allocatable;
    2838                 :            :           }
    2839                 :            : 
    2840                 :       3264 :         if (refs_comp && strcmp (comp->name, "_data") != 0
    2841                 :       1218 :             && (ref->next == NULL
    2842                 :        816 :                 || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
    2843                 :        899 :           *refs_comp = true;
    2844                 :            : 
    2845                 :       3264 :         if (pointer || attr.proc_pointer)
    2846                 :        678 :           target = 1;
    2847                 :            : 
    2848                 :            :         break;
    2849                 :            : 
    2850                 :          0 :       case REF_SUBSTRING:
    2851                 :          0 :       case REF_INQUIRY:
    2852                 :          0 :         allocatable = pointer = 0;
    2853                 :          0 :         break;
    2854                 :            :       }
    2855                 :            : 
    2856                 :       7403 :   attr.dimension = dimension;
    2857                 :       7403 :   attr.codimension = codimension;
    2858                 :       7403 :   attr.pointer = pointer;
    2859                 :       7403 :   attr.allocatable = allocatable;
    2860                 :       7403 :   attr.target = target;
    2861                 :       7403 :   attr.save = sym->attr.save;
    2862                 :       7403 :   attr.coarray_comp = coarray_comp;
    2863                 :            : 
    2864                 :       7403 :   return attr;
    2865                 :            : }
    2866                 :            : 
    2867                 :            : 
    2868                 :            : symbol_attribute
    2869                 :       9222 : gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
    2870                 :            : {
    2871                 :       9222 :   symbol_attribute attr;
    2872                 :            : 
    2873                 :       9222 :   switch (e->expr_type)
    2874                 :            :     {
    2875                 :       7139 :     case EXPR_VARIABLE:
    2876                 :       7139 :       attr = caf_variable_attr (e, in_allocate, refs_comp);
    2877                 :       7139 :       break;
    2878                 :            : 
    2879                 :        266 :     case EXPR_FUNCTION:
    2880                 :        266 :       gfc_clear_attr (&attr);
    2881                 :            : 
    2882                 :        266 :       if (e->value.function.esym && e->value.function.esym->result)
    2883                 :            :         {
    2884                 :          2 :           gfc_symbol *sym = e->value.function.esym->result;
    2885                 :          2 :           attr = sym->attr;
    2886                 :          2 :           if (sym->ts.type == BT_CLASS)
    2887                 :            :             {
    2888                 :          0 :               attr.dimension = CLASS_DATA (sym)->attr.dimension;
    2889                 :          0 :               attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
    2890                 :          0 :               attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
    2891                 :          0 :               attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
    2892                 :          0 :               attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
    2893                 :          0 :                   ->attr.pointer_comp;
    2894                 :            :             }
    2895                 :            :         }
    2896                 :        264 :       else if (e->symtree)
    2897                 :        264 :         attr = caf_variable_attr (e, in_allocate, refs_comp);
    2898                 :            :       else
    2899                 :          0 :         gfc_clear_attr (&attr);
    2900                 :            :       break;
    2901                 :            : 
    2902                 :       1817 :     default:
    2903                 :       1817 :       gfc_clear_attr (&attr);
    2904                 :       1817 :       break;
    2905                 :            :     }
    2906                 :            : 
    2907                 :       9222 :   return attr;
    2908                 :            : }
    2909                 :            : 
    2910                 :            : 
    2911                 :            : /* Match a structure constructor.  The initial symbol has already been
    2912                 :            :    seen.  */
    2913                 :            : 
    2914                 :            : typedef struct gfc_structure_ctor_component
    2915                 :            : {
    2916                 :            :   char* name;
    2917                 :            :   gfc_expr* val;
    2918                 :            :   locus where;
    2919                 :            :   struct gfc_structure_ctor_component* next;
    2920                 :            : }
    2921                 :            : gfc_structure_ctor_component;
    2922                 :            : 
    2923                 :            : #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
    2924                 :            : 
    2925                 :            : static void
    2926                 :       6117 : gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
    2927                 :            : {
    2928                 :       6117 :   free (comp->name);
    2929                 :       6117 :   gfc_free_expr (comp->val);
    2930                 :       6117 :   free (comp);
    2931                 :       6117 : }
    2932                 :            : 
    2933                 :            : 
    2934                 :            : /* Translate the component list into the actual constructor by sorting it in
    2935                 :            :    the order required; this also checks along the way that each and every
    2936                 :            :    component actually has an initializer and handles default initializers
    2937                 :            :    for components without explicit value given.  */
    2938                 :            : static bool
    2939                 :       4345 : build_actual_constructor (gfc_structure_ctor_component **comp_head,
    2940                 :            :                           gfc_constructor_base *ctor_head, gfc_symbol *sym)
    2941                 :            : {
    2942                 :       4345 :   gfc_structure_ctor_component *comp_iter;
    2943                 :       4345 :   gfc_component *comp;
    2944                 :            : 
    2945                 :      10708 :   for (comp = sym->components; comp; comp = comp->next)
    2946                 :            :     {
    2947                 :       6368 :       gfc_structure_ctor_component **next_ptr;
    2948                 :       6368 :       gfc_expr *value = NULL;
    2949                 :            : 
    2950                 :            :       /* Try to find the initializer for the current component by name.  */
    2951                 :       6368 :       next_ptr = comp_head;
    2952                 :       6635 :       for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
    2953                 :            :         {
    2954                 :       6360 :           if (!strcmp (comp_iter->name, comp->name))
    2955                 :            :             break;
    2956                 :        267 :           next_ptr = &comp_iter->next;
    2957                 :            :         }
    2958                 :            : 
    2959                 :            :       /* If an extension, try building the parent derived type by building
    2960                 :            :          a value expression for the parent derived type and calling self.  */
    2961                 :       6368 :       if (!comp_iter && comp == sym->components && sym->attr.extension)
    2962                 :            :         {
    2963                 :         55 :           value = gfc_get_structure_constructor_expr (comp->ts.type,
    2964                 :            :                                                       comp->ts.kind,
    2965                 :            :                                                       &gfc_current_locus);
    2966                 :         55 :           value->ts = comp->ts;
    2967                 :            : 
    2968                 :         55 :           if (!build_actual_constructor (comp_head,
    2969                 :            :                                          &value->value.constructor,
    2970                 :            :                                          comp->ts.u.derived))
    2971                 :            :             {
    2972                 :          0 :               gfc_free_expr (value);
    2973                 :          0 :               return false;
    2974                 :            :             }
    2975                 :            : 
    2976                 :         55 :           gfc_constructor_append_expr (ctor_head, value, NULL);
    2977                 :         55 :           continue;
    2978                 :            :         }
    2979                 :            : 
    2980                 :            :       /* If it was not found, try the default initializer if there's any;
    2981                 :            :          otherwise, it's an error unless this is a deferred parameter.  */
    2982                 :       6313 :       if (!comp_iter)
    2983                 :            :         {
    2984                 :        220 :           if (comp->initializer)
    2985                 :            :             {
    2986                 :         87 :               if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
    2987                 :            :                                    "with missing optional arguments at %C"))
    2988                 :            :                 return false;
    2989                 :         85 :               value = gfc_copy_expr (comp->initializer);
    2990                 :            :             }
    2991                 :        133 :           else if (comp->attr.allocatable
    2992                 :         94 :                    || (comp->ts.type == BT_CLASS
    2993                 :        133 :                        && CLASS_DATA (comp)->attr.allocatable))
    2994                 :            :             {
    2995                 :         39 :               if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
    2996                 :            :                                    "allocatable component %qs given in the "
    2997                 :            :                                    "structure constructor at %C", comp->name))
    2998                 :            :                 return false;
    2999                 :            :             }
    3000                 :         94 :           else if (!comp->attr.artificial)
    3001                 :            :             {
    3002                 :          3 :               gfc_error ("No initializer for component %qs given in the"
    3003                 :            :                          " structure constructor at %C", comp->name);
    3004                 :          3 :               return false;
    3005                 :            :             }
    3006                 :            :         }
    3007                 :            :       else
    3008                 :       6093 :         value = comp_iter->val;
    3009                 :            : 
    3010                 :            :       /* Add the value to the constructor chain built.  */
    3011                 :       6308 :       gfc_constructor_append_expr (ctor_head, value, NULL);
    3012                 :            : 
    3013                 :            :       /* Remove the entry from the component list.  We don't want the expression
    3014                 :            :          value to be free'd, so set it to NULL.  */
    3015                 :       6308 :       if (comp_iter)
    3016                 :            :         {
    3017                 :       6093 :           *next_ptr = comp_iter->next;
    3018                 :       6093 :           comp_iter->val = NULL;
    3019                 :       6093 :           gfc_free_structure_ctor_component (comp_iter);
    3020                 :            :         }
    3021                 :            :     }
    3022                 :            :   return true;
    3023                 :            : }
    3024                 :            : 
    3025                 :            : 
    3026                 :            : bool
    3027                 :       4305 : gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
    3028                 :            :                                       gfc_actual_arglist **arglist,
    3029                 :            :                                       bool parent)
    3030                 :            : {
    3031                 :       4305 :   gfc_actual_arglist *actual;
    3032                 :       4305 :   gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
    3033                 :       4305 :   gfc_constructor_base ctor_head = NULL;
    3034                 :       4305 :   gfc_component *comp; /* Is set NULL when named component is first seen */
    3035                 :       4305 :   const char* last_name = NULL;
    3036                 :       4305 :   locus old_locus;
    3037                 :       4305 :   gfc_expr *expr;
    3038                 :            : 
    3039                 :       4305 :   expr = parent ? *cexpr : e;
    3040                 :       4305 :   old_locus = gfc_current_locus;
    3041                 :       4305 :   if (parent)
    3042                 :            :     ; /* gfc_current_locus = *arglist->expr ? ->where;*/
    3043                 :            :   else
    3044                 :       3825 :     gfc_current_locus = expr->where;
    3045                 :            : 
    3046                 :       4305 :   comp_tail = comp_head = NULL;
    3047                 :            : 
    3048                 :       4305 :   if (!parent && sym->attr.abstract)
    3049                 :            :     {
    3050                 :          1 :       gfc_error ("Cannot construct ABSTRACT type %qs at %L",
    3051                 :            :                  sym->name, &expr->where);
    3052                 :          1 :       goto cleanup;
    3053                 :            :     }
    3054                 :            : 
    3055                 :       4304 :   comp = sym->components;
    3056                 :       4304 :   actual = parent ? *arglist : expr->value.function.actual;
    3057                 :      10030 :   for ( ; actual; )
    3058                 :            :     {
    3059                 :       6117 :       gfc_component *this_comp = NULL;
    3060                 :            : 
    3061                 :       6117 :       if (!comp_head)
    3062                 :       4110 :         comp_tail = comp_head = gfc_get_structure_ctor_component ();
    3063                 :            :       else
    3064                 :            :         {
    3065                 :       2007 :           comp_tail->next = gfc_get_structure_ctor_component ();
    3066                 :       2007 :           comp_tail = comp_tail->next;
    3067                 :            :         }
    3068                 :       6117 :       if (actual->name)
    3069                 :            :         {
    3070                 :        224 :           if (!gfc_notify_std (GFC_STD_F2003, "Structure"
    3071                 :            :                                " constructor with named arguments at %C"))
    3072                 :          1 :             goto cleanup;
    3073                 :            : 
    3074                 :        223 :           comp_tail->name = xstrdup (actual->name);
    3075                 :        223 :           last_name = comp_tail->name;
    3076                 :        223 :           comp = NULL;
    3077                 :            :         }
    3078                 :            :       else
    3079                 :            :         {
    3080                 :            :           /* Components without name are not allowed after the first named
    3081                 :            :              component initializer!  */
    3082                 :       5893 :           if (!comp || comp->attr.artificial)
    3083                 :            :             {
    3084                 :          2 :               if (last_name)
    3085                 :          0 :                 gfc_error ("Component initializer without name after component"
    3086                 :            :                            " named %s at %L", last_name,
    3087                 :          0 :                            actual->expr ? &actual->expr->where
    3088                 :            :                                         : &gfc_current_locus);
    3089                 :            :               else
    3090                 :          2 :                 gfc_error ("Too many components in structure constructor at "
    3091                 :          2 :                            "%L", actual->expr ? &actual->expr->where
    3092                 :            :                                               : &gfc_current_locus);
    3093                 :          2 :               goto cleanup;
    3094                 :            :             }
    3095                 :            : 
    3096                 :       5891 :           comp_tail->name = xstrdup (comp->name);
    3097                 :            :         }
    3098                 :            : 
    3099                 :            :       /* Find the current component in the structure definition and check
    3100                 :            :              its access is not private.  */
    3101                 :       6114 :       if (comp)
    3102                 :       5891 :         this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
    3103                 :            :       else
    3104                 :            :         {
    3105                 :        223 :           this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
    3106                 :            :                                           false, false, NULL);
    3107                 :        223 :           comp = NULL; /* Reset needed!  */
    3108                 :            :         }
    3109                 :            : 
    3110                 :            :       /* Here we can check if a component name is given which does not
    3111                 :            :          correspond to any component of the defined structure.  */
    3112                 :       6114 :       if (!this_comp)
    3113                 :          8 :         goto cleanup;
    3114                 :            : 
    3115                 :            :       /* For a constant string constructor, make sure the length is
    3116                 :            :          correct; truncate of fill with blanks if needed.  */
    3117                 :       6106 :       if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
    3118                 :        547 :           && this_comp->ts.u.cl && this_comp->ts.u.cl->length
    3119                 :        547 :           && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
    3120                 :        535 :           && actual->expr->ts.type == BT_CHARACTER
    3121                 :        534 :           && actual->expr->expr_type == EXPR_CONSTANT)
    3122                 :            :         {
    3123                 :        461 :           ptrdiff_t c, e1;
    3124                 :        461 :           c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
    3125                 :        461 :           e1 = actual->expr->value.character.length;
    3126                 :            : 
    3127                 :        461 :           if (c != e1)
    3128                 :            :             {
    3129                 :        165 :               ptrdiff_t i, to;
    3130                 :        165 :               gfc_char_t *dest;
    3131                 :        165 :               dest = gfc_get_wide_string (c + 1);
    3132                 :            : 
    3133                 :        165 :               to = e1 < c ? e1 : c;
    3134                 :        968 :               for (i = 0; i < to; i++)
    3135                 :        803 :                 dest[i] = actual->expr->value.character.string[i];
    3136                 :            : 
    3137                 :       1792 :               for (i = e1; i < c; i++)
    3138                 :       1627 :                 dest[i] = ' ';
    3139                 :            : 
    3140                 :        165 :               dest[c] = '\0';
    3141                 :        165 :               free (actual->expr->value.character.string);
    3142                 :            : 
    3143                 :        165 :               actual->expr->value.character.length = c;
    3144                 :        165 :               actual->expr->value.character.string = dest;
    3145                 :            : 
    3146                 :        165 :               if (warn_line_truncation && c < e1)
    3147                 :         14 :                 gfc_warning_now (OPT_Wcharacter_truncation,
    3148                 :            :                                  "CHARACTER expression will be truncated "
    3149                 :            :                                  "in constructor (%ld/%ld) at %L", (long int) c,
    3150                 :            :                                  (long int) e1, &actual->expr->where);
    3151                 :            :             }
    3152                 :            :         }
    3153                 :            : 
    3154                 :       6106 :       comp_tail->val = actual->expr;
    3155                 :       6106 :       if (actual->expr != NULL)
    3156                 :       6106 :         comp_tail->where = actual->expr->where;
    3157                 :       6106 :       actual->expr = NULL;
    3158                 :            : 
    3159                 :            :       /* Check if this component is already given a value.  */
    3160                 :       8892 :       for (comp_iter = comp_head; comp_iter != comp_tail;
    3161                 :       2786 :            comp_iter = comp_iter->next)
    3162                 :            :         {
    3163                 :       2787 :           gcc_assert (comp_iter);
    3164                 :       2787 :           if (!strcmp (comp_iter->name, comp_tail->name))
    3165                 :            :             {
    3166                 :          1 :               gfc_error ("Component %qs is initialized twice in the structure"
    3167                 :            :                          " constructor at %L", comp_tail->name,
    3168                 :            :                          comp_tail->val ? &comp_tail->where
    3169                 :            :                                         : &gfc_current_locus);
    3170                 :          1 :               goto cleanup;
    3171                 :            :             }
    3172                 :            :         }
    3173                 :            : 
    3174                 :            :       /* F2008, R457/C725, for PURE C1283.  */
    3175                 :         57 :       if (this_comp->attr.pointer && comp_tail->val
    3176                 :       6162 :           && gfc_is_coindexed (comp_tail->val))
    3177                 :            :         {
    3178                 :          2 :           gfc_error ("Coindexed expression to pointer component %qs in "
    3179                 :            :                      "structure constructor at %L", comp_tail->name,
    3180                 :            :                      &comp_tail->where);
    3181                 :          2 :           goto cleanup;
    3182                 :            :         }
    3183                 :            : 
    3184                 :            :           /* If not explicitly a parent constructor, gather up the components
    3185                 :            :              and build one.  */
    3186                 :       6103 :           if (comp && comp == sym->components
    3187                 :       4020 :                 && sym->attr.extension
    3188                 :        504 :                 && comp_tail->val
    3189                 :        504 :                 && (!gfc_bt_struct (comp_tail->val->ts.type)
    3190                 :         54 :                       ||
    3191                 :         54 :                     comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
    3192                 :            :             {
    3193                 :        480 :               bool m;
    3194                 :        480 :               gfc_actual_arglist *arg_null = NULL;
    3195                 :            : 
    3196                 :        480 :               actual->expr = comp_tail->val;
    3197                 :        480 :               comp_tail->val = NULL;
    3198                 :            : 
    3199                 :        480 :               m = gfc_convert_to_structure_constructor (NULL,
    3200                 :            :                                         comp->ts.u.derived, &comp_tail->val,
    3201                 :        480 :                                         comp->ts.u.derived->attr.zero_comp
    3202                 :        480 :                                           ? &arg_null : &actual, true);
    3203                 :        480 :               if (!m)
    3204                 :          0 :                 goto cleanup;
    3205                 :            : 
    3206                 :        480 :               if (comp->ts.u.derived->attr.zero_comp)
    3207                 :            :                 {
    3208                 :        102 :                   comp = comp->next;
    3209                 :        102 :                   continue;
    3210                 :            :                 }
    3211                 :            :             }
    3212                 :            : 
    3213                 :       6001 :       if (comp)
    3214                 :       5781 :         comp = comp->next;
    3215                 :       6001 :       if (parent && !comp)
    3216                 :            :         break;
    3217                 :            : 
    3218                 :       5624 :       if (actual)
    3219                 :       5623 :         actual = actual->next;
    3220                 :            :     }
    3221                 :            : 
    3222                 :       4290 :   if (!build_actual_constructor (&comp_head, &ctor_head, sym))
    3223                 :          5 :     goto cleanup;
    3224                 :            : 
    3225                 :            :   /* No component should be left, as this should have caused an error in the
    3226                 :            :      loop constructing the component-list (name that does not correspond to any
    3227                 :            :      component in the structure definition).  */
    3228                 :       4285 :   if (comp_head && sym->attr.extension)
    3229                 :            :     {
    3230                 :          2 :       for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
    3231                 :            :         {
    3232                 :          1 :           gfc_error ("component %qs at %L has already been set by a "
    3233                 :            :                      "parent derived type constructor", comp_iter->name,
    3234                 :            :                      &comp_iter->where);
    3235                 :            :         }
    3236                 :          1 :       goto cleanup;
    3237                 :            :     }
    3238                 :            :   else
    3239                 :       4284 :     gcc_assert (!comp_head);
    3240                 :            : 
    3241                 :       4284 :   if (parent)
    3242                 :            :     {
    3243                 :        480 :       expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
    3244                 :        480 :       expr->ts.u.derived = sym;
    3245                 :        480 :       expr->value.constructor = ctor_head;
    3246                 :        480 :       *cexpr = expr;
    3247                 :            :     }
    3248                 :            :   else
    3249                 :            :     {
    3250                 :       3804 :       expr->ts.u.derived = sym;
    3251                 :       3804 :       expr->ts.kind = 0;
    3252                 :       3804 :       expr->ts.type = BT_DERIVED;
    3253                 :       3804 :       expr->value.constructor = ctor_head;
    3254                 :       3804 :       expr->expr_type = EXPR_STRUCTURE;
    3255                 :            :     }
    3256                 :            : 
    3257                 :       4284 :   gfc_current_locus = old_locus;
    3258                 :       4284 :   if (parent)
    3259                 :        480 :     *arglist = actual;
    3260                 :            :   return true;
    3261                 :            : 
    3262                 :         21 :   cleanup:
    3263                 :         21 :   gfc_current_locus = old_locus;
    3264                 :            : 
    3265                 :         45 :   for (comp_iter = comp_head; comp_iter; )
    3266                 :            :     {
    3267                 :         24 :       gfc_structure_ctor_component *next = comp_iter->next;
    3268                 :         24 :       gfc_free_structure_ctor_component (comp_iter);
    3269                 :         24 :       comp_iter = next;
    3270                 :            :     }
    3271                 :         21 :   gfc_constructor_free (ctor_head);
    3272                 :            : 
    3273                 :         21 :   return false;
    3274                 :            : }
    3275                 :            : 
    3276                 :            : 
    3277                 :            : match
    3278                 :         37 : gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
    3279                 :            : {
    3280                 :         37 :   match m;
    3281                 :         37 :   gfc_expr *e;
    3282                 :         37 :   gfc_symtree *symtree;
    3283                 :            : 
    3284                 :         37 :   gfc_get_ha_sym_tree (sym->name, &symtree);
    3285                 :            : 
    3286                 :         37 :   e = gfc_get_expr ();
    3287                 :         37 :   e->symtree = symtree;
    3288                 :         37 :   e->expr_type = EXPR_FUNCTION;
    3289                 :         37 :   e->where = gfc_current_locus;
    3290                 :            : 
    3291                 :         37 :   gcc_assert (gfc_fl_struct (sym->attr.flavor)
    3292                 :            :               && symtree->n.sym->attr.flavor == FL_PROCEDURE);
    3293                 :         37 :   e->value.function.esym = sym;
    3294                 :         37 :   e->symtree->n.sym->attr.generic = 1;
    3295                 :            : 
    3296                 :         37 :   m = gfc_match_actual_arglist (0, &e->value.function.actual);
    3297                 :         37 :   if (m != MATCH_YES)
    3298                 :            :     {
    3299                 :          0 :       gfc_free_expr (e);
    3300                 :          0 :       return m;
    3301                 :            :     }
    3302                 :            : 
    3303                 :         37 :   if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
    3304                 :            :     {
    3305                 :          1 :       gfc_free_expr (e);
    3306                 :          1 :       return MATCH_ERROR;
    3307                 :            :     }
    3308                 :            : 
    3309                 :            :   /* If a structure constructor is in a DATA statement, then each entity
    3310                 :            :      in the structure constructor must be a constant.  Try to reduce the
    3311                 :            :      expression here.  */
    3312                 :         36 :   if (gfc_in_match_data ())
    3313                 :         36 :     gfc_reduce_init_expr (e);
    3314                 :            : 
    3315                 :         36 :   *result = e;
    3316                 :         36 :   return MATCH_YES;
    3317                 :            : }
    3318                 :            : 
    3319                 :            : 
    3320                 :            : /* If the symbol is an implicit do loop index and implicitly typed,
    3321                 :            :    it should not be host associated.  Provide a symtree from the
    3322                 :            :    current namespace.  */
    3323                 :            : static match
    3324                 :    4119860 : check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
    3325                 :            : {
    3326                 :    4119860 :   if ((*sym)->attr.flavor == FL_VARIABLE
    3327                 :     971568 :       && (*sym)->ns != gfc_current_ns
    3328                 :            :       && (*sym)->attr.implied_index
    3329                 :            :       && (*sym)->attr.implicit_type
    3330                 :      27609 :       && !(*sym)->attr.use_assoc)
    3331                 :            :     {
    3332                 :         32 :       int i;
    3333                 :         32 :       i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
    3334                 :         32 :       if (i)
    3335                 :            :         return MATCH_ERROR;
    3336                 :         32 :       *sym = (*st)->n.sym;
    3337                 :            :     }
    3338                 :            :   return MATCH_YES;
    3339                 :            : }
    3340                 :            : 
    3341                 :            : 
    3342                 :            : /* Procedure pointer as function result: Replace the function symbol by the
    3343                 :            :    auto-generated hidden result variable named "ppr@".  */
    3344                 :            : 
    3345                 :            : static bool
    3346                 :    3066440 : replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
    3347                 :            : {
    3348                 :            :   /* Check for procedure pointer result variable.  */
    3349                 :    3066440 :   if ((*sym)->attr.function && !(*sym)->attr.external
    3350                 :     959304 :       && (*sym)->result && (*sym)->result != *sym
    3351                 :       5600 :       && (*sym)->result->attr.proc_pointer
    3352                 :        307 :       && (*sym) == gfc_current_ns->proc_name
    3353                 :        281 :       && (*sym) == (*sym)->result->ns->proc_name
    3354                 :        281 :       && strcmp ("ppr@", (*sym)->result->name) == 0)
    3355                 :            :     {
    3356                 :            :       /* Automatic replacement with "hidden" result variable.  */
    3357                 :        281 :       (*sym)->result->attr.referenced = (*sym)->attr.referenced;
    3358                 :        281 :       *sym = (*sym)->result;
    3359                 :        281 :       *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
    3360                 :        281 :       return true;
    3361                 :            :     }
    3362                 :            :   return false;
    3363                 :            : }
    3364                 :            : 
    3365                 :            : 
    3366                 :            : /* Matches a variable name followed by anything that might follow it--
    3367                 :            :    array reference, argument list of a function, etc.  */
    3368                 :            : 
    3369                 :            : match
    3370                 :    2478320 : gfc_match_rvalue (gfc_expr **result)
    3371                 :            : {
    3372                 :    2478320 :   gfc_actual_arglist *actual_arglist;
    3373                 :    2478320 :   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
    3374                 :    2478320 :   gfc_state_data *st;
    3375                 :    2478320 :   gfc_symbol *sym;
    3376                 :    2478320 :   gfc_symtree *symtree;
    3377                 :    2478320 :   locus where, old_loc;
    3378                 :    2478320 :   gfc_expr *e;
    3379                 :    2478320 :   match m, m2;
    3380                 :    2478320 :   int i;
    3381                 :    2478320 :   gfc_typespec *ts;
    3382                 :    2478320 :   bool implicit_char;
    3383                 :    2478320 :   gfc_ref *ref;
    3384                 :            : 
    3385                 :    2478320 :   m = gfc_match ("%%loc");
    3386                 :    2478320 :   if (m == MATCH_YES)
    3387                 :            :     {
    3388                 :         12 :       if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
    3389                 :            :         return MATCH_ERROR;
    3390                 :         11 :       strncpy (name, "loc", 4);
    3391                 :            :     }
    3392                 :            : 
    3393                 :            :   else
    3394                 :            :     {
    3395                 :    2478310 :       m = gfc_match_name (name);
    3396                 :    2478310 :       if (m != MATCH_YES)
    3397                 :            :         return m;
    3398                 :            :     }
    3399                 :            : 
    3400                 :            :   /* Check if the symbol exists.  */
    3401                 :    2336740 :   if (gfc_find_sym_tree (name, NULL, 1, &symtree))
    3402                 :            :     return MATCH_ERROR;
    3403                 :            : 
    3404                 :            :   /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
    3405                 :            :      type. For derived types we create a generic symbol which links to the
    3406                 :            :      derived type symbol; STRUCTUREs are simpler and must not conflict with
    3407                 :            :      variables.  */
    3408                 :    2336740 :   if (!symtree)
    3409                 :     109700 :     if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
    3410                 :            :       return MATCH_ERROR;
    3411                 :    2336740 :   if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
    3412                 :            :     {
    3413                 :    2336740 :       if (gfc_find_state (COMP_INTERFACE)
    3414                 :    2336740 :           && !gfc_current_ns->has_import_set)
    3415                 :      47259 :         i = gfc_get_sym_tree (name, NULL, &symtree, false);
    3416                 :            :       else
    3417                 :    2289480 :         i = gfc_get_ha_sym_tree (name, &symtree);
    3418                 :    2336740 :       if (i)
    3419                 :            :         return MATCH_ERROR;
    3420                 :            :     }
    3421                 :            : 
    3422                 :            : 
    3423                 :    2336740 :   sym = symtree->n.sym;
    3424                 :    2336740 :   e = NULL;
    3425                 :    2336740 :   where = gfc_current_locus;
    3426                 :            : 
    3427                 :    2336740 :   replace_hidden_procptr_result (&sym, &symtree);
    3428                 :            : 
    3429                 :            :   /* If this is an implicit do loop index and implicitly typed,
    3430                 :            :      it should not be host associated.  */
    3431                 :    2336740 :   m = check_for_implicit_index (&symtree, &sym);
    3432                 :    2336740 :   if (m != MATCH_YES)
    3433                 :            :     return m;
    3434                 :            : 
    3435                 :    2336740 :   gfc_set_sym_referenced (sym);
    3436                 :    2336740 :   sym->attr.implied_index = 0;
    3437                 :            : 
    3438                 :    2336740 :   if (sym->attr.function && sym->result == sym)
    3439                 :            :     {
    3440                 :            :       /* See if this is a directly recursive function call.  */
    3441                 :     482301 :       gfc_gobble_whitespace ();
    3442                 :     482301 :       if (sym->attr.recursive
    3443                 :        100 :           && gfc_peek_ascii_char () == '('
    3444                 :         93 :           && gfc_current_ns->proc_name == sym
    3445                 :     482308 :           && !sym->attr.dimension)
    3446                 :            :         {
    3447                 :          4 :           gfc_error ("%qs at %C is the name of a recursive function "
    3448                 :            :                      "and so refers to the result variable. Use an "
    3449                 :            :                      "explicit RESULT variable for direct recursion "
    3450                 :            :                      "(12.5.2.1)", sym->name);
    3451                 :          4 :           return MATCH_ERROR;
    3452                 :            :         }
    3453                 :            : 
    3454                 :     482297 :       if (gfc_is_function_return_value (sym, gfc_current_ns))
    3455                 :       1538 :         goto variable;
    3456                 :            : 
    3457                 :     480759 :       if (sym->attr.entry
    3458                 :        159 :           && (sym->ns == gfc_current_ns
    3459                 :     480784 :               || sym->ns == gfc_current_ns->parent))
    3460                 :            :         {
    3461                 :        153 :           gfc_entry_list *el = NULL;
    3462                 :            : 
    3463                 :        153 :           for (el = sym->ns->entries; el; el = el->next)
    3464                 :        153 :             if (sym == el->sym)
    3465                 :        153 :               goto variable;
    3466                 :            :         }
    3467                 :            :     }
    3468                 :            : 
    3469                 :    2335050 :   if (gfc_matching_procptr_assignment)
    3470                 :            :     {
    3471                 :            :       /* It can be a procedure or a derived-type procedure or a not-yet-known
    3472                 :            :          type.  */
    3473                 :       1129 :       if (sym->attr.flavor != FL_UNKNOWN
    3474                 :       1129 :           && sym->attr.flavor != FL_PROCEDURE
    3475                 :         61 :           && sym->attr.flavor != FL_PARAMETER
    3476                 :         61 :           && sym->attr.flavor != FL_VARIABLE)
    3477                 :            :         {
    3478                 :          2 :           gfc_error ("Symbol at %C is not appropriate for an expression");
    3479                 :          2 :           return MATCH_ERROR;
    3480                 :            :         }
    3481                 :       1127 :       goto procptr0;
    3482                 :            :     }
    3483                 :            : 
    3484                 :    2333920 :   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
    3485                 :     490165 :     goto function0;
    3486                 :            : 
    3487                 :    1843750 :   if (sym->attr.generic)
    3488                 :      32345 :     goto generic_function;
    3489                 :            : 
    3490                 :    1811410 :   switch (sym->attr.flavor)
    3491                 :            :     {
    3492                 :     849530 :     case FL_VARIABLE:
    3493                 :     849530 :     variable:
    3494                 :     849530 :       e = gfc_get_expr ();
    3495                 :            : 
    3496                 :     849530 :       e->expr_type = EXPR_VARIABLE;
    3497                 :     849530 :       e->symtree = symtree;
    3498                 :            : 
    3499                 :     849530 :       m = gfc_match_varspec (e, 0, false, true);
    3500                 :     849530 :       break;
    3501                 :            : 
    3502                 :     114130 :     case FL_PARAMETER:
    3503                 :            :       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
    3504                 :            :          end up here.  Unfortunately, sym->value->expr_type is set to
    3505                 :            :          EXPR_CONSTANT, and so the if () branch would be followed without
    3506                 :            :          the !sym->as check.  */
    3507                 :     114130 :       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
    3508                 :      99969 :         e = gfc_copy_expr (sym->value);
    3509                 :            :       else
    3510                 :            :         {
    3511                 :      14161 :           e = gfc_get_expr ();
    3512                 :      14161 :           e->expr_type = EXPR_VARIABLE;
    3513                 :            :         }
    3514                 :            : 
    3515                 :     114130 :       e->symtree = symtree;
    3516                 :     114130 :       m = gfc_match_varspec (e, 0, false, true);
    3517                 :            : 
    3518                 :     114130 :       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
    3519                 :            :         break;
    3520                 :            : 
    3521                 :            :       /* Variable array references to derived type parameters cause
    3522                 :            :          all sorts of headaches in simplification. Treating such
    3523                 :            :          expressions as variable works just fine for all array
    3524                 :            :          references.  */
    3525                 :      99444 :       if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
    3526                 :            :         {
    3527                 :        960 :           for (ref = e->ref; ref; ref = ref->next)
    3528                 :        870 :             if (ref->type == REF_ARRAY)
    3529                 :            :               break;
    3530                 :            : 
    3531                 :        844 :           if (ref == NULL || ref->u.ar.type == AR_FULL)
    3532                 :            :             break;
    3533                 :            : 
    3534                 :        221 :           ref = e->ref;
    3535                 :        221 :           e->ref = NULL;
    3536                 :        221 :           gfc_free_expr (e);
    3537                 :        221 :           e = gfc_get_expr ();
    3538                 :        221 :           e->expr_type = EXPR_VARIABLE;
    3539                 :        221 :           e->symtree = symtree;
    3540                 :        221 :           e->ref = ref;
    3541                 :            :         }
    3542                 :            : 
    3543                 :            :       break;
    3544                 :            : 
    3545                 :          0 :     case FL_STRUCT:
    3546                 :          0 :     case FL_DERIVED:
    3547                 :          0 :       sym = gfc_use_derived (sym);
    3548                 :          0 :       if (sym == NULL)
    3549                 :            :         m = MATCH_ERROR;
    3550                 :            :       else
    3551                 :          0 :         goto generic_function;
    3552                 :            :       break;
    3553                 :            : 
    3554                 :            :     /* If we're here, then the name is known to be the name of a
    3555                 :            :        procedure, yet it is not sure to be the name of a function.  */
    3556                 :     661973 :     case FL_PROCEDURE:
    3557                 :            : 
    3558                 :            :     /* Procedure Pointer Assignments.  */
    3559                 :     661973 :     procptr0:
    3560                 :     661973 :       if (gfc_matching_procptr_assignment)
    3561                 :            :         {
    3562                 :       1127 :           gfc_gobble_whitespace ();
    3563                 :       1127 :           if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
    3564                 :            :             /* Parse functions returning a procptr.  */
    3565                 :        130 :             goto function0;
    3566                 :            : 
    3567                 :        997 :           e = gfc_get_expr ();
    3568                 :        997 :           e->expr_type = EXPR_VARIABLE;
    3569                 :        997 :           e->symtree = symtree;
    3570                 :        997 :           m = gfc_match_varspec (e, 0, false, true);
    3571                 :        930 :           if (!e->ref && sym->attr.flavor == FL_UNKNOWN
    3572                 :        168 :               && sym->ts.type == BT_UNKNOWN
    3573                 :       1155 :               && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
    3574                 :            :             {
    3575                 :            :               m = MATCH_ERROR;
    3576                 :            :               break;
    3577                 :            :             }
    3578                 :            :           break;
    3579                 :            :         }
    3580                 :            : 
    3581                 :     660846 :       if (sym->attr.subroutine)
    3582                 :            :         {
    3583                 :          5 :           gfc_error ("Unexpected use of subroutine name %qs at %C",
    3584                 :            :                      sym->name);
    3585                 :          5 :           m = MATCH_ERROR;
    3586                 :          5 :           break;
    3587                 :            :         }
    3588                 :            : 
    3589                 :            :       /* At this point, the name has to be a non-statement function.
    3590                 :            :          If the name is the same as the current function being
    3591                 :            :          compiled, then we have a variable reference (to the function
    3592                 :            :          result) if the name is non-recursive.  */
    3593                 :            : 
    3594                 :     660841 :       st = gfc_enclosing_unit (NULL);
    3595                 :            : 
    3596                 :     660841 :       if (st != NULL
    3597                 :     626004 :           && st->state == COMP_FUNCTION
    3598                 :      48153 :           && st->sym == sym
    3599                 :          0 :           && !sym->attr.recursive)
    3600                 :            :         {
    3601                 :          0 :           e = gfc_get_expr ();
    3602                 :          0 :           e->symtree = symtree;
    3603                 :          0 :           e->expr_type = EXPR_VARIABLE;
    3604                 :            : 
    3605                 :          0 :           m = gfc_match_varspec (e, 0, false, true);
    3606                 :          0 :           break;
    3607                 :            :         }
    3608                 :            : 
    3609                 :            :     /* Match a function reference.  */
    3610                 :     660841 :     function0:
    3611                 :    1151140 :       m = gfc_match_actual_arglist (0, &actual_arglist);
    3612                 :    1151140 :       if (m == MATCH_NO)
    3613                 :            :         {
    3614                 :     399994 :           if (sym->attr.proc == PROC_ST_FUNCTION)
    3615                 :          1 :             gfc_error ("Statement function %qs requires argument list at %C",
    3616                 :            :                        sym->name);
    3617                 :            :           else
    3618                 :     399993 :             gfc_error ("Function %qs requires an argument list at %C",
    3619                 :            :                        sym->name);
    3620                 :            : 
    3621                 :            :           m = MATCH_ERROR;
    3622                 :            :           break;
    3623                 :            :         }
    3624                 :            : 
    3625                 :     751142 :       if (m != MATCH_YES)
    3626                 :            :         {
    3627                 :            :           m = MATCH_ERROR;
    3628                 :            :           break;
    3629                 :            :         }
    3630                 :            : 
    3631                 :     728664 :       gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
    3632                 :     728664 :       sym = symtree->n.sym;
    3633                 :            : 
    3634                 :     728664 :       replace_hidden_procptr_result (&sym, &symtree);
    3635                 :            : 
    3636                 :     728664 :       e = gfc_get_expr ();
    3637                 :     728664 :       e->symtree = symtree;
    3638                 :     728664 :       e->expr_type = EXPR_FUNCTION;
    3639                 :     728664 :       e->value.function.actual = actual_arglist;
    3640                 :     728664 :       e->where = gfc_current_locus;
    3641                 :            : 
    3642                 :     728664 :       if (sym->ts.type == BT_CLASS && sym->attr.class_ok
    3643                 :        162 :           && CLASS_DATA (sym)->as)
    3644                 :         65 :         e->rank = CLASS_DATA (sym)->as->rank;
    3645                 :     728599 :       else if (sym->as != NULL)
    3646                 :       1010 :         e->rank = sym->as->rank;
    3647                 :            : 
    3648                 :     728664 :       if (!sym->attr.function
    3649                 :     728664 :           && !gfc_add_function (&sym->attr, sym->name, NULL))
    3650                 :            :         {
    3651                 :            :           m = MATCH_ERROR;
    3652                 :            :           break;
    3653                 :            :         }
    3654                 :            : 
    3655                 :            :       /* Check here for the existence of at least one argument for the
    3656                 :            :          iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
    3657                 :            :          argument(s) given will be checked in gfc_iso_c_func_interface,
    3658                 :            :          during resolution of the function call.  */
    3659                 :     728664 :       if (sym->attr.is_iso_c == 1
    3660                 :          2 :           && (sym->from_intmod == INTMOD_ISO_C_BINDING
    3661                 :          2 :               && (sym->intmod_sym_id == ISOCBINDING_LOC
    3662                 :            :                   || sym->intmod_sym_id == ISOCBINDING_FUNLOC
    3663                 :          2 :                   || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
    3664                 :            :         {
    3665                 :            :           /* make sure we were given a param */
    3666                 :          0 :           if (actual_arglist == NULL)
    3667                 :            :             {
    3668                 :          0 :               gfc_error ("Missing argument to %qs at %C", sym->name);
    3669                 :          0 :               m = MATCH_ERROR;
    3670                 :          0 :               break;
    3671                 :            :             }
    3672                 :            :         }
    3673                 :            : 
    3674                 :     728664 :       if (sym->result == NULL)
    3675                 :     244242 :         sym->result = sym;
    3676                 :            : 
    3677                 :     728664 :       gfc_gobble_whitespace ();
    3678                 :            :       /* F08:C612.  */
    3679                 :     728664 :       if (gfc_peek_ascii_char() == '%')
    3680                 :            :         {
    3681                 :         12 :           gfc_error ("The leftmost part-ref in a data-ref cannot be a "
    3682                 :            :                      "function reference at %C");
    3683                 :         12 :           m = MATCH_ERROR;
    3684                 :         12 :           break;
    3685                 :            :         }
    3686                 :            : 
    3687                 :            :       m = MATCH_YES;
    3688                 :            :       break;
    3689                 :            : 
    3690                 :     187227 :     case FL_UNKNOWN:
    3691                 :            : 
    3692                 :            :       /* Special case for derived type variables that get their types
    3693                 :            :          via an IMPLICIT statement.  This can't wait for the
    3694                 :            :          resolution phase.  */
    3695                 :            : 
    3696                 :     187227 :       old_loc = gfc_current_locus;
    3697                 :     187227 :       if (gfc_match_member_sep (sym) == MATCH_YES
    3698                 :       7709 :           && sym->ts.type == BT_UNKNOWN
    3699                 :     187230 :           && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
    3700                 :          0 :         gfc_set_default_type (sym, 0, sym->ns);
    3701                 :     187227 :       gfc_current_locus = old_loc;
    3702                 :            : 
    3703                 :            :       /* If the symbol has a (co)dimension attribute, the expression is a
    3704                 :            :          variable.  */
    3705                 :            : 
    3706                 :     187227 :       if (sym->attr.dimension || sym->attr.codimension)
    3707                 :            :         {
    3708                 :      23680 :           if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
    3709                 :            :             {
    3710                 :            :               m = MATCH_ERROR;
    3711                 :            :               break;
    3712                 :            :             }
    3713                 :            : 
    3714                 :      23680 :           e = gfc_get_expr ();
    3715                 :      23680 :           e->symtree = symtree;
    3716                 :      23680 :           e->expr_type = EXPR_VARIABLE;
    3717                 :      23680 :           m = gfc_match_varspec (e, 0, false, true);
    3718                 :      23680 :           break;
    3719                 :            :         }
    3720                 :            : 
    3721                 :     163547 :       if (sym->ts.type == BT_CLASS && sym->attr.class_ok
    3722                 :       3505 :           && (CLASS_DATA (sym)->attr.dimension
    3723                 :       3505 :               || CLASS_DATA (sym)->attr.codimension))
    3724                 :            :         {
    3725                 :        951 :           if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
    3726                 :            :             {
    3727                 :            :               m = MATCH_ERROR;
    3728                 :            :               break;
    3729                 :            :             }
    3730                 :            : 
    3731                 :        951 :           e = gfc_get_expr ();
    3732                 :        951 :           e->symtree = symtree;
    3733                 :        951 :           e->expr_type = EXPR_VARIABLE;
    3734                 :        951 :           m = gfc_match_varspec (e, 0, false, true);
    3735                 :        951 :           break;
    3736                 :            :         }
    3737                 :            : 
    3738                 :            :       /* Name is not an array, so we peek to see if a '(' implies a
    3739                 :            :          function call or a substring reference.  Otherwise the
    3740                 :            :          variable is just a scalar.  */
    3741                 :            : 
    3742                 :     162596 :       gfc_gobble_whitespace ();
    3743                 :     162596 :       if (gfc_peek_ascii_char () != '(')
    3744                 :            :         {
    3745                 :            :           /* Assume a scalar variable */
    3746                 :      55314 :           e = gfc_get_expr ();
    3747                 :      55314 :           e->symtree = symtree;
    3748                 :      55314 :           e->expr_type = EXPR_VARIABLE;
    3749                 :            : 
    3750                 :      55314 :           if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
    3751                 :            :             {
    3752                 :            :               m = MATCH_ERROR;
    3753                 :            :               break;
    3754                 :            :             }
    3755                 :            : 
    3756                 :            :           /*FIXME:??? gfc_match_varspec does set this for us: */
    3757                 :      55314 :           e->ts = sym->ts;
    3758                 :      55314 :           m = gfc_match_varspec (e, 0, false, true);
    3759                 :      55314 :           break;
    3760                 :            :         }
    3761                 :            : 
    3762                 :            :       /* See if this is a function reference with a keyword argument
    3763                 :            :          as first argument. We do this because otherwise a spurious
    3764                 :            :          symbol would end up in the symbol table.  */
    3765                 :            : 
    3766                 :     107282 :       old_loc = gfc_current_locus;
    3767                 :     107282 :       m2 = gfc_match (" ( %n =", argname);
    3768                 :     107282 :       gfc_current_locus = old_loc;
    3769                 :            : 
    3770                 :     107282 :       e = gfc_get_expr ();
    3771                 :     107282 :       e->symtree = symtree;
    3772                 :            : 
    3773                 :     107282 :       if (m2 != MATCH_YES)
    3774                 :            :         {
    3775                 :            :           /* Try to figure out whether we're dealing with a character type.
    3776                 :            :              We're peeking ahead here, because we don't want to call
    3777                 :            :              match_substring if we're dealing with an implicitly typed
    3778                 :            :              non-character variable.  */
    3779                 :     106625 :           implicit_char = false;
    3780                 :     106625 :           if (sym->ts.type == BT_UNKNOWN)
    3781                 :            :             {
    3782                 :     102207 :               ts = gfc_get_default_type (sym->name, NULL);
    3783                 :     102207 :               if (ts->type == BT_CHARACTER)
    3784                 :            :                 implicit_char = true;
    3785                 :            :             }
    3786                 :            : 
    3787                 :            :           /* See if this could possibly be a substring reference of a name
    3788                 :            :              that we're not sure is a variable yet.  */
    3789                 :            : 
    3790                 :     106608 :           if ((implicit_char || sym->ts.type == BT_CHARACTER)
    3791                 :       1107 :               && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
    3792                 :            :             {
    3793                 :            : 
    3794                 :        643 :               e->expr_type = EXPR_VARIABLE;
    3795                 :            : 
    3796                 :        643 :               if (sym->attr.flavor != FL_VARIABLE
    3797                 :        643 :                   && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
    3798                 :            :                                       sym->name, NULL))
    3799                 :            :                 {
    3800                 :            :                   m = MATCH_ERROR;
    3801                 :            :                   break;
    3802                 :            :                 }
    3803                 :            : 
    3804                 :        643 :               if (sym->ts.type == BT_UNKNOWN
    3805                 :        643 :                   && !gfc_set_default_type (sym, 1, NULL))
    3806                 :            :                 {
    3807                 :            :                   m = MATCH_ERROR;
    3808                 :            :                   break;
    3809                 :            :                 }
    3810                 :            : 
    3811                 :        643 :               e->ts = sym->ts;
    3812                 :        643 :               if (e->ref)
    3813                 :        619 :                 e->ts.u.cl = NULL;
    3814                 :            :               m = MATCH_YES;
    3815                 :            :               break;
    3816                 :            :             }
    3817                 :            :         }
    3818                 :            : 
    3819                 :            :       /* Give up, assume we have a function.  */
    3820                 :            : 
    3821                 :     106639 :       gfc_get_sym_tree (name, NULL, &symtree, false);       /* Can't fail */
    3822                 :     106639 :       sym = symtree->n.sym;
    3823                 :     106639 :       e->expr_type = EXPR_FUNCTION;
    3824                 :            : 
    3825                 :     106639 :       if (!sym->attr.function
    3826                 :     106639 :           && !gfc_add_function (&sym->attr, sym->name, NULL))
    3827                 :            :         {
    3828                 :            :           m = MATCH_ERROR;
    3829                 :            :           break;
    3830                 :            :         }
    3831                 :            : 
    3832                 :     106639 :       sym->result = sym;
    3833                 :            : 
    3834                 :     106639 :       m = gfc_match_actual_arglist (0, &e->value.function.actual);
    3835                 :     106639 :       if (m == MATCH_NO)
    3836                 :          0 :         gfc_error ("Missing argument list in function %qs at %C", sym->name);
    3837                 :            : 
    3838                 :     106639 :       if (m != MATCH_YES)
    3839                 :            :         {
    3840                 :            :           m = MATCH_ERROR;
    3841                 :            :           break;
    3842                 :            :         }
    3843                 :            : 
    3844                 :            :       /* If our new function returns a character, array or structure
    3845                 :            :          type, it might have subsequent references.  */
    3846                 :            : 
    3847                 :     106541 :       m = gfc_match_varspec (e, 0, false, true);
    3848                 :     106541 :       if (m == MATCH_NO)
    3849                 :            :         m = MATCH_YES;
    3850                 :            : 
    3851                 :            :       break;
    3852                 :            : 
    3853                 :      32345 :     generic_function:
    3854                 :            :       /* Look for symbol first; if not found, look for STRUCTURE type symbol
    3855                 :            :          specially. Creates a generic symbol for derived types.  */
    3856                 :      32345 :       gfc_find_sym_tree (name, NULL, 1, &symtree);
    3857                 :      32345 :       if (!symtree)
    3858                 :          0 :         gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
    3859                 :      32345 :       if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
    3860                 :      32345 :         gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
    3861                 :            : 
    3862                 :      32345 :       e = gfc_get_expr ();
    3863                 :      32345 :       e->symtree = symtree;
    3864                 :      32345 :       e->expr_type = EXPR_FUNCTION;
    3865                 :            : 
    3866                 :      32345 :       if (gfc_fl_struct (sym->attr.flavor))
    3867                 :            :         {
    3868                 :          0 :           e->value.function.esym = sym;
    3869                 :          0 :           e->symtree->n.sym->attr.generic = 1;
    3870                 :            :         }
    3871                 :            : 
    3872                 :      32345 :       m = gfc_match_actual_arglist (0, &e->value.function.actual);
    3873                 :      32345 :       break;
    3874                 :            : 
    3875                 :            :     case FL_NAMELIST:
    3876                 :            :       m = MATCH_ERROR;
    3877                 :            :       break;
    3878                 :            : 
    3879                 :          5 :     default:
    3880                 :          5 :       gfc_error ("Symbol at %C is not appropriate for an expression");
    3881                 :          5 :       return MATCH_ERROR;
    3882                 :            :     }
    3883                 :            : 
    3884                 :    1183500 :   if (m == MATCH_YES)
    3885                 :            :     {
    3886                 :    1912690 :       e->where = where;
    3887                 :    1912690 :       *result = e;
    3888                 :            :     }
    3889                 :            :   else
    3890                 :     424041 :     gfc_free_expr (e);
    3891                 :            : 
    3892                 :            :   return m;
    3893                 :            : }
    3894                 :            : 
    3895                 :            : 
    3896                 :            : /* Match a variable, i.e. something that can be assigned to.  This
    3897                 :            :    starts as a symbol, can be a structure component or an array
    3898                 :            :    reference.  It can be a function if the function doesn't have a
    3899                 :            :    separate RESULT variable.  If the symbol has not been previously
    3900                 :            :    seen, we assume it is a variable.
    3901                 :            : 
    3902                 :            :    This function is called by two interface functions:
    3903                 :            :    gfc_match_variable, which has host_flag = 1, and
    3904                 :            :    gfc_match_equiv_variable, with host_flag = 0, to restrict the
    3905                 :            :    match of the symbol to the local scope.  */
    3906                 :            : 
    3907                 :            : static match
    3908                 :    1783140 : match_variable (gfc_expr **result, int equiv_flag, int host_flag)
    3909                 :            : {
    3910                 :    1783140 :   gfc_symbol *sym, *dt_sym;
    3911                 :    1783140 :   gfc_symtree *st;
    3912                 :    1783140 :   gfc_expr *expr;
    3913                 :    1783140 :   locus where, old_loc;
    3914                 :    1783140 :   match m;
    3915                 :            : 
    3916                 :            :   /* Since nothing has any business being an lvalue in a module
    3917                 :            :      specification block, an interface block or a contains section,
    3918                 :            :      we force the changed_symbols mechanism to work by setting
    3919                 :            :      host_flag to 0. This prevents valid symbols that have the name
    3920                 :            :      of keywords, such as 'end', being turned into variables by
    3921                 :            :      failed matching to assignments for, e.g., END INTERFACE.  */
    3922                 :    1783140 :   if (gfc_current_state () == COMP_MODULE
    3923                 :    1783140 :       || gfc_current_state () == COMP_SUBMODULE
    3924                 :    1736070 :       || gfc_current_state () == COMP_INTERFACE
    3925                 :    1708440 :       || gfc_current_state () == COMP_CONTAINS)
    3926                 :     126106 :     host_flag = 0;
    3927                 :            : 
    3928                 :    1783140 :   where = gfc_current_locus;
    3929                 :    1783140 :   m = gfc_match_sym_tree (&st, host_flag);
    3930                 :    1783140 :   if (m != MATCH_YES)
    3931                 :            :     return m;
    3932                 :            : 
    3933                 :    1783120 :   sym = st->n.sym;
    3934                 :            : 
    3935                 :            :   /* If this is an implicit do loop index and implicitly typed,
    3936                 :            :      it should not be host associated.  */
    3937                 :    1783120 :   m = check_for_implicit_index (&st, &sym);
    3938                 :    1783120 :   if (m != MATCH_YES)
    3939                 :            :     return m;
    3940                 :            : 
    3941                 :    1783120 :   sym->attr.implied_index = 0;
    3942                 :            : 
    3943                 :    1783120 :   gfc_set_sym_referenced (sym);
    3944                 :            : 
    3945                 :            :   /* STRUCTUREs may share names with variables, but derived types may not.  */
    3946                 :      10324 :   if (sym->attr.flavor == FL_PROCEDURE && sym->generic
    3947                 :    1783150 :       && (dt_sym = gfc_find_dt_in_generic (sym)))
    3948                 :            :     {
    3949                 :          4 :       if (dt_sym->attr.flavor == FL_DERIVED)
    3950                 :          4 :         gfc_error ("Derived type %qs cannot be used as a variable at %C",
    3951                 :            :                    sym->name);
    3952                 :          4 :       return MATCH_ERROR;
    3953                 :            :     }
    3954                 :            : 
    3955                 :    1783110 :   switch (sym->attr.flavor)
    3956                 :            :     {
    3957                 :            :     case FL_VARIABLE:
    3958                 :            :       /* Everything is alright.  */
    3959                 :            :       break;
    3960                 :            : 
    3961                 :    1648950 :     case FL_UNKNOWN:
    3962                 :    1648950 :       {
    3963                 :    1648950 :         sym_flavor flavor = FL_UNKNOWN;
    3964                 :            : 
    3965                 :    1648950 :         gfc_gobble_whitespace ();
    3966                 :            : 
    3967                 :    1648950 :         if (sym->attr.external || sym->attr.procedure
    3968                 :    1648950 :             || sym->attr.function || sym->attr.subroutine)
    3969                 :            :           flavor = FL_PROCEDURE;
    3970                 :            : 
    3971                 :            :         /* If it is not a procedure, is not typed and is host associated,
    3972                 :            :            we cannot give it a flavor yet.  */
    3973                 :    1648920 :         else if (sym->ns == gfc_current_ns->parent
    3974                 :       1335 :                    && sym->ts.type == BT_UNKNOWN)
    3975                 :            :           break;
    3976                 :            : 
    3977                 :            :         /* These are definitive indicators that this is a variable.  */
    3978                 :    2188190 :         else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
    3979                 :    2174580 :                  || sym->attr.pointer || sym->as != NULL)
    3980                 :            :           flavor = FL_VARIABLE;
    3981                 :            : 
    3982                 :            :         if (flavor != FL_UNKNOWN
    3983                 :    1123840 :             && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
    3984                 :            :           return MATCH_ERROR;
    3985                 :            :       }
    3986                 :            :       break;
    3987                 :            : 
    3988                 :         10 :     case FL_PARAMETER:
    3989                 :         10 :       if (equiv_flag)
    3990                 :            :         {
    3991                 :          0 :           gfc_error ("Named constant at %C in an EQUIVALENCE");
    3992                 :          0 :           return MATCH_ERROR;
    3993                 :            :         }
    3994                 :            :       /* Otherwise this is checked for and an error given in the
    3995                 :            :          variable definition context checks.  */
    3996                 :            :       break;
    3997                 :            : 
    3998                 :      10320 :     case FL_PROCEDURE:
    3999                 :            :       /* Check for a nonrecursive function result variable.  */
    4000                 :      10320 :       if (sym->attr.function
    4001                 :      10320 :           && !sym->attr.external
    4002                 :       8695 :           && sym->result == sym
    4003                 :      18729 :           && (gfc_is_function_return_value (sym, gfc_current_ns)
    4004                 :        833 :               || (sym->attr.entry
    4005                 :        833 :                   && sym->ns == gfc_current_ns)
    4006                 :        446 :               || (sym->attr.entry
    4007                 :          9 :                   && sym->ns == gfc_current_ns->parent)))
    4008                 :            :         {
    4009                 :            :           /* If a function result is a derived type, then the derived
    4010                 :            :              type may still have to be resolved.  */
    4011                 :            : 
    4012                 :       7971 :           if (sym->ts.type == BT_DERIVED
    4013                 :       7971 :               && gfc_use_derived (sym->ts.u.derived) == NULL)
    4014                 :            :             return MATCH_ERROR;
    4015                 :            :           break;
    4016                 :            :         }
    4017                 :            : 
    4018                 :       2349 :       if (sym->attr.proc_pointer
    4019                 :       2349 :           || replace_hidden_procptr_result (&sym, &st))
    4020                 :            :         break;
    4021                 :            : 
    4022                 :            :       /* Fall through to error */
    4023                 :       1004 :       gcc_fallthrough ();
    4024                 :            : 
    4025                 :       1004 :     default:
    4026                 :       1004 :       gfc_error ("%qs at %C is not a variable", sym->name);
    4027                 :       1004 :       return MATCH_ERROR;
    4028                 :            :     }
    4029                 :            : 
    4030                 :            :   /* Special case for derived type variables that get their types
    4031                 :            :      via an IMPLICIT statement.  This can't wait for the
    4032                 :            :      resolution phase.  */
    4033                 :            : 
    4034                 :    1782100 :     {
    4035                 :    1782100 :       gfc_namespace * implicit_ns;
    4036                 :            : 
    4037                 :    1782100 :       if (gfc_current_ns->proc_name == sym)
    4038                 :            :         implicit_ns = gfc_current_ns;
    4039                 :            :       else
    4040                 :    1774670 :         implicit_ns = sym->ns;
    4041                 :            : 
    4042                 :    1782100 :       old_loc = gfc_current_locus;
    4043                 :    1782100 :       if (gfc_match_member_sep (sym) == MATCH_YES
    4044                 :      12220 :           && sym->ts.type == BT_UNKNOWN
    4045                 :    1782110 :           && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
    4046                 :          3 :         gfc_set_default_type (sym, 0, implicit_ns);
    4047                 :    1782100 :       gfc_current_locus = old_loc;
    4048                 :            :     }
    4049                 :            : 
    4050                 :    1782100 :   expr = gfc_get_expr ();
    4051                 :            : 
    4052                 :    1782100 :   expr->expr_type = EXPR_VARIABLE;
    4053                 :    1782100 :   expr->symtree = st;
    4054                 :    1782100 :   expr->ts = sym->ts;
    4055                 :    1782100 :   expr->where = where;
    4056                 :            : 
    4057                 :            :   /* Now see if we have to do more.  */
    4058                 :    1782100 :   m = gfc_match_varspec (expr, equiv_flag, false, false);
    4059                 :    1782100 :   if (m != MATCH_YES)
    4060                 :            :     {
    4061                 :         71 :       gfc_free_expr (expr);
    4062                 :         71 :       return m;
    4063                 :            :     }
    4064                 :            : 
    4065                 :    1782030 :   *result = expr;
    4066                 :    1782030 :   return MATCH_YES;
    4067                 :            : }
    4068                 :            : 
    4069                 :            : 
    4070                 :            : match
    4071                 :    1780190 : gfc_match_variable (gfc_expr **result, int equiv_flag)
    4072                 :            : {
    4073                 :    1780190 :   return match_variable (result, equiv_flag, 1);
    4074                 :            : }
    4075                 :            : 
    4076                 :            : 
    4077                 :            : match
    4078                 :       2950 : gfc_match_equiv_variable (gfc_expr **result)
    4079                 :            : {
    4080                 :       2950 :   return match_variable (result, 1, 0);
    4081                 :            : }
    4082                 :            : 

Generated by: LCOV version 1.0

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