LCOV - code coverage report
Current view: top level - gcc/fortran - decl.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 4918 5491 89.6 %
Date: 2020-03-28 11:57:23 Functions: 127 131 96.9 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Declaration statement matcher
       2                 :            :    Copyright (C) 2002-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 "tree.h"
      26                 :            : #include "gfortran.h"
      27                 :            : #include "stringpool.h"
      28                 :            : #include "match.h"
      29                 :            : #include "parse.h"
      30                 :            : #include "constructor.h"
      31                 :            : #include "target.h"
      32                 :            : 
      33                 :            : /* Macros to access allocate memory for gfc_data_variable,
      34                 :            :    gfc_data_value and gfc_data.  */
      35                 :            : #define gfc_get_data_variable() XCNEW (gfc_data_variable)
      36                 :            : #define gfc_get_data_value() XCNEW (gfc_data_value)
      37                 :            : #define gfc_get_data() XCNEW (gfc_data)
      38                 :            : 
      39                 :            : 
      40                 :            : static bool set_binding_label (const char **, const char *, int);
      41                 :            : 
      42                 :            : 
      43                 :            : /* This flag is set if an old-style length selector is matched
      44                 :            :    during a type-declaration statement.  */
      45                 :            : 
      46                 :            : static int old_char_selector;
      47                 :            : 
      48                 :            : /* When variables acquire types and attributes from a declaration
      49                 :            :    statement, they get them from the following static variables.  The
      50                 :            :    first part of a declaration sets these variables and the second
      51                 :            :    part copies these into symbol structures.  */
      52                 :            : 
      53                 :            : static gfc_typespec current_ts;
      54                 :            : 
      55                 :            : static symbol_attribute current_attr;
      56                 :            : static gfc_array_spec *current_as;
      57                 :            : static int colon_seen;
      58                 :            : static int attr_seen;
      59                 :            : 
      60                 :            : /* The current binding label (if any).  */
      61                 :            : static const char* curr_binding_label;
      62                 :            : /* Need to know how many identifiers are on the current data declaration
      63                 :            :    line in case we're given the BIND(C) attribute with a NAME= specifier.  */
      64                 :            : static int num_idents_on_line;
      65                 :            : /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
      66                 :            :    can supply a name if the curr_binding_label is nil and NAME= was not.  */
      67                 :            : static int has_name_equals = 0;
      68                 :            : 
      69                 :            : /* Initializer of the previous enumerator.  */
      70                 :            : 
      71                 :            : static gfc_expr *last_initializer;
      72                 :            : 
      73                 :            : /* History of all the enumerators is maintained, so that
      74                 :            :    kind values of all the enumerators could be updated depending
      75                 :            :    upon the maximum initialized value.  */
      76                 :            : 
      77                 :            : typedef struct enumerator_history
      78                 :            : {
      79                 :            :   gfc_symbol *sym;
      80                 :            :   gfc_expr *initializer;
      81                 :            :   struct enumerator_history *next;
      82                 :            : }
      83                 :            : enumerator_history;
      84                 :            : 
      85                 :            : /* Header of enum history chain.  */
      86                 :            : 
      87                 :            : static enumerator_history *enum_history = NULL;
      88                 :            : 
      89                 :            : /* Pointer of enum history node containing largest initializer.  */
      90                 :            : 
      91                 :            : static enumerator_history *max_enum = NULL;
      92                 :            : 
      93                 :            : /* gfc_new_block points to the symbol of a newly matched block.  */
      94                 :            : 
      95                 :            : gfc_symbol *gfc_new_block;
      96                 :            : 
      97                 :            : bool gfc_matching_function;
      98                 :            : 
      99                 :            : /* Set upon parsing a !GCC$ unroll n directive for use in the next loop.  */
     100                 :            : int directive_unroll = -1;
     101                 :            : 
     102                 :            : /* Set upon parsing supported !GCC$ pragmas for use in the next loop.  */
     103                 :            : bool directive_ivdep = false;
     104                 :            : bool directive_vector = false;
     105                 :            : bool directive_novector = false;
     106                 :            : 
     107                 :            : /* Map of middle-end built-ins that should be vectorized.  */
     108                 :            : hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;
     109                 :            : 
     110                 :            : /* If a kind expression of a component of a parameterized derived type is
     111                 :            :    parameterized, temporarily store the expression here.  */
     112                 :            : static gfc_expr *saved_kind_expr = NULL;
     113                 :            : 
     114                 :            : /* Used to store the parameter list arising in a PDT declaration and
     115                 :            :    in the typespec of a PDT variable or component.  */
     116                 :            : static gfc_actual_arglist *decl_type_param_list;
     117                 :            : static gfc_actual_arglist *type_param_spec_list;
     118                 :            : 
     119                 :            : /********************* DATA statement subroutines *********************/
     120                 :            : 
     121                 :            : static bool in_match_data = false;
     122                 :            : 
     123                 :            : bool
     124                 :       5203 : gfc_in_match_data (void)
     125                 :            : {
     126                 :       5203 :   return in_match_data;
     127                 :            : }
     128                 :            : 
     129                 :            : static void
     130                 :       4593 : set_in_match_data (bool set_value)
     131                 :            : {
     132                 :       4593 :   in_match_data = set_value;
     133                 :       2297 : }
     134                 :            : 
     135                 :            : /* Free a gfc_data_variable structure and everything beneath it.  */
     136                 :            : 
     137                 :            : static void
     138                 :       5366 : free_variable (gfc_data_variable *p)
     139                 :            : {
     140                 :       8303 :   gfc_data_variable *q;
     141                 :            : 
     142                 :       8303 :   for (; p; p = q)
     143                 :            :     {
     144                 :       2937 :       q = p->next;
     145                 :       2937 :       gfc_free_expr (p->expr);
     146                 :       2937 :       gfc_free_iterator (&p->iter, 0);
     147                 :       2937 :       free_variable (p->list);
     148                 :       2937 :       free (p);
     149                 :            :     }
     150                 :       5366 : }
     151                 :            : 
     152                 :            : 
     153                 :            : /* Free a gfc_data_value structure and everything beneath it.  */
     154                 :            : 
     155                 :            : static void
     156                 :       2429 : free_value (gfc_data_value *p)
     157                 :            : {
     158                 :      10969 :   gfc_data_value *q;
     159                 :            : 
     160                 :      10969 :   for (; p; p = q)
     161                 :            :     {
     162                 :       8540 :       q = p->next;
     163                 :       8540 :       mpz_clear (p->repeat);
     164                 :       8540 :       gfc_free_expr (p->expr);
     165                 :       8540 :       free (p);
     166                 :            :     }
     167                 :       2429 : }
     168                 :            : 
     169                 :            : 
     170                 :            : /* Free a list of gfc_data structures.  */
     171                 :            : 
     172                 :            : void
     173                 :     275350 : gfc_free_data (gfc_data *p)
     174                 :            : {
     175                 :     277779 :   gfc_data *q;
     176                 :            : 
     177                 :     277779 :   for (; p; p = q)
     178                 :            :     {
     179                 :       2429 :       q = p->next;
     180                 :       2429 :       free_variable (p->var);
     181                 :       2429 :       free_value (p->value);
     182                 :       2429 :       free (p);
     183                 :            :     }
     184                 :     275350 : }
     185                 :            : 
     186                 :            : 
     187                 :            : /* Free all data in a namespace.  */
     188                 :            : 
     189                 :            : static void
     190                 :          0 : gfc_free_data_all (gfc_namespace *ns)
     191                 :            : {
     192                 :         44 :   gfc_data *d;
     193                 :            : 
     194                 :         44 :   for (;ns->data;)
     195                 :            :     {
     196                 :          6 :       d = ns->data->next;
     197                 :          6 :       free (ns->data);
     198                 :          6 :       ns->data = d;
     199                 :            :     }
     200                 :          0 : }
     201                 :            : 
     202                 :            : /* Reject data parsed since the last restore point was marked.  */
     203                 :            : 
     204                 :            : void
     205                 :    5683650 : gfc_reject_data (gfc_namespace *ns)
     206                 :            : {
     207                 :    5683650 :   gfc_data *d;
     208                 :            : 
     209                 :    5683650 :   while (ns->data && ns->data != ns->old_data)
     210                 :            :     {
     211                 :          2 :       d = ns->data->next;
     212                 :          2 :       free (ns->data);
     213                 :          2 :       ns->data = d;
     214                 :            :     }
     215                 :    5683650 : }
     216                 :            : 
     217                 :            : static match var_element (gfc_data_variable *);
     218                 :            : 
     219                 :            : /* Match a list of variables terminated by an iterator and a right
     220                 :            :    parenthesis.  */
     221                 :            : 
     222                 :            : static match
     223                 :        133 : var_list (gfc_data_variable *parent)
     224                 :            : {
     225                 :        133 :   gfc_data_variable *tail, var;
     226                 :        133 :   match m;
     227                 :            : 
     228                 :        133 :   m = var_element (&var);
     229                 :        133 :   if (m == MATCH_ERROR)
     230                 :            :     return MATCH_ERROR;
     231                 :        133 :   if (m == MATCH_NO)
     232                 :          0 :     goto syntax;
     233                 :            : 
     234                 :        133 :   tail = gfc_get_data_variable ();
     235                 :        133 :   *tail = var;
     236                 :            : 
     237                 :        133 :   parent->list = tail;
     238                 :            : 
     239                 :        135 :   for (;;)
     240                 :            :     {
     241                 :        134 :       if (gfc_match_char (',') != MATCH_YES)
     242                 :          0 :         goto syntax;
     243                 :            : 
     244                 :        134 :       m = gfc_match_iterator (&parent->iter, 1);
     245                 :        134 :       if (m == MATCH_YES)
     246                 :            :         break;
     247                 :          1 :       if (m == MATCH_ERROR)
     248                 :            :         return MATCH_ERROR;
     249                 :            : 
     250                 :          1 :       m = var_element (&var);
     251                 :          1 :       if (m == MATCH_ERROR)
     252                 :            :         return MATCH_ERROR;
     253                 :          1 :       if (m == MATCH_NO)
     254                 :          0 :         goto syntax;
     255                 :            : 
     256                 :          1 :       tail->next = gfc_get_data_variable ();
     257                 :          1 :       tail = tail->next;
     258                 :            : 
     259                 :          1 :       *tail = var;
     260                 :            :     }
     261                 :            : 
     262                 :        133 :   if (gfc_match_char (')') != MATCH_YES)
     263                 :          0 :     goto syntax;
     264                 :            :   return MATCH_YES;
     265                 :            : 
     266                 :          0 : syntax:
     267                 :          0 :   gfc_syntax_error (ST_DATA);
     268                 :          0 :   return MATCH_ERROR;
     269                 :            : }
     270                 :            : 
     271                 :            : 
     272                 :            : /* Match a single element in a data variable list, which can be a
     273                 :            :    variable-iterator list.  */
     274                 :            : 
     275                 :            : static match
     276                 :       2909 : var_element (gfc_data_variable *new_var)
     277                 :            : {
     278                 :       2909 :   match m;
     279                 :       2909 :   gfc_symbol *sym;
     280                 :            : 
     281                 :       2909 :   memset (new_var, 0, sizeof (gfc_data_variable));
     282                 :            : 
     283                 :       2909 :   if (gfc_match_char ('(') == MATCH_YES)
     284                 :        133 :     return var_list (new_var);
     285                 :            : 
     286                 :       2776 :   m = gfc_match_variable (&new_var->expr, 0);
     287                 :       2776 :   if (m != MATCH_YES)
     288                 :            :     return m;
     289                 :            : 
     290                 :       2776 :   if (new_var->expr->expr_type == EXPR_CONSTANT
     291                 :          2 :       && new_var->expr->symtree == NULL)
     292                 :            :     {
     293                 :          2 :       gfc_error ("Inquiry parameter cannot appear in a "
     294                 :            :                  "data-stmt-object-list at %C");
     295                 :          2 :       return MATCH_ERROR;
     296                 :            :     }
     297                 :            : 
     298                 :       2774 :   sym = new_var->expr->symtree->n.sym;
     299                 :            : 
     300                 :            :   /* Symbol should already have an associated type.  */
     301                 :       2774 :   if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
     302                 :            :     return MATCH_ERROR;
     303                 :            : 
     304                 :       2773 :   if (!sym->attr.function && gfc_current_ns->parent
     305                 :        202 :       && gfc_current_ns->parent == sym->ns)
     306                 :            :     {
     307                 :          1 :       gfc_error ("Host associated variable %qs may not be in the DATA "
     308                 :            :                  "statement at %C", sym->name);
     309                 :          1 :       return MATCH_ERROR;
     310                 :            :     }
     311                 :            : 
     312                 :       2772 :   if (gfc_current_state () != COMP_BLOCK_DATA
     313                 :       2673 :       && sym->attr.in_common
     314                 :       2801 :       && !gfc_notify_std (GFC_STD_GNU, "initialization of "
     315                 :            :                           "common block variable %qs in DATA statement at %C",
     316                 :            :                           sym->name))
     317                 :            :     return MATCH_ERROR;
     318                 :            : 
     319                 :       2770 :   if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
     320                 :          5 :     return MATCH_ERROR;
     321                 :            : 
     322                 :            :   return MATCH_YES;
     323                 :            : }
     324                 :            : 
     325                 :            : 
     326                 :            : /* Match the top-level list of data variables.  */
     327                 :            : 
     328                 :            : static match
     329                 :       2390 : top_var_list (gfc_data *d)
     330                 :            : {
     331                 :       2390 :   gfc_data_variable var, *tail, *new_var;
     332                 :       2390 :   match m;
     333                 :            : 
     334                 :       2390 :   tail = NULL;
     335                 :            : 
     336                 :       2775 :   for (;;)
     337                 :            :     {
     338                 :       2775 :       m = var_element (&var);
     339                 :       2775 :       if (m == MATCH_NO)
     340                 :          0 :         goto syntax;
     341                 :       2775 :       if (m == MATCH_ERROR)
     342                 :            :         return MATCH_ERROR;
     343                 :            : 
     344                 :       2764 :       new_var = gfc_get_data_variable ();
     345                 :       2764 :       *new_var = var;
     346                 :       2764 :       if (new_var->expr)
     347                 :       2663 :         new_var->expr->where = gfc_current_locus;
     348                 :            : 
     349                 :       2764 :       if (tail == NULL)
     350                 :       2379 :         d->var = new_var;
     351                 :            :       else
     352                 :        385 :         tail->next = new_var;
     353                 :            : 
     354                 :       2764 :       tail = new_var;
     355                 :            : 
     356                 :       2764 :       if (gfc_match_char ('/') == MATCH_YES)
     357                 :            :         break;
     358                 :        388 :       if (gfc_match_char (',') != MATCH_YES)
     359                 :          3 :         goto syntax;
     360                 :            :     }
     361                 :            : 
     362                 :            :   return MATCH_YES;
     363                 :            : 
     364                 :          3 : syntax:
     365                 :          3 :   gfc_syntax_error (ST_DATA);
     366                 :          3 :   gfc_free_data_all (gfc_current_ns);
     367                 :            :   return MATCH_ERROR;
     368                 :            : }
     369                 :            : 
     370                 :            : 
     371                 :            : static match
     372                 :       8931 : match_data_constant (gfc_expr **result)
     373                 :            : {
     374                 :       8931 :   char name[GFC_MAX_SYMBOL_LEN + 1];
     375                 :       8931 :   gfc_symbol *sym, *dt_sym = NULL;
     376                 :       8931 :   gfc_expr *expr;
     377                 :       8931 :   match m;
     378                 :       8931 :   locus old_loc;
     379                 :            : 
     380                 :       8931 :   m = gfc_match_literal_constant (&expr, 1);
     381                 :       8931 :   if (m == MATCH_YES)
     382                 :            :     {
     383                 :       8628 :       *result = expr;
     384                 :       8628 :       return MATCH_YES;
     385                 :            :     }
     386                 :            : 
     387                 :        303 :   if (m == MATCH_ERROR)
     388                 :            :     return MATCH_ERROR;
     389                 :            : 
     390                 :        295 :   m = gfc_match_null (result);
     391                 :        295 :   if (m != MATCH_NO)
     392                 :            :     return m;
     393                 :            : 
     394                 :        288 :   old_loc = gfc_current_locus;
     395                 :            : 
     396                 :            :   /* Should this be a structure component, try to match it
     397                 :            :      before matching a name.  */
     398                 :        288 :   m = gfc_match_rvalue (result);
     399                 :        288 :   if (m == MATCH_ERROR)
     400                 :            :     return m;
     401                 :            : 
     402                 :        288 :   if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
     403                 :            :     {
     404                 :          3 :       if (!gfc_simplify_expr (*result, 0))
     405                 :          0 :         m = MATCH_ERROR;
     406                 :          3 :       return m;
     407                 :            :     }
     408                 :        285 :   else if (m == MATCH_YES)
     409                 :            :     {
     410                 :            :       /* If a parameter inquiry ends up here, symtree is NULL but **result
     411                 :            :          contains the right constant expression.  Check here.  */
     412                 :        279 :       if ((*result)->symtree == NULL
     413                 :         36 :           && (*result)->expr_type == EXPR_CONSTANT
     414                 :         36 :           && ((*result)->ts.type == BT_INTEGER
     415                 :          0 :               || (*result)->ts.type == BT_REAL))
     416                 :            :         return m;
     417                 :            : 
     418                 :            :       /* F2018:R845 data-stmt-constant is initial-data-target.
     419                 :            :          A data-stmt-constant shall be ... initial-data-target if and
     420                 :            :          only if the corresponding data-stmt-object has the POINTER
     421                 :            :          attribute. ...  If data-stmt-constant is initial-data-target
     422                 :            :          the corresponding data statement object shall be
     423                 :            :          data-pointer-initialization compatible (7.5.4.6) with the initial
     424                 :            :          data target; the data statement object is initially associated
     425                 :            :          with the target.  */
     426                 :        243 :       if ((*result)->symtree->n.sym->attr.save
     427                 :        243 :           && (*result)->symtree->n.sym->attr.target)
     428                 :            :         return m;
     429                 :        225 :       gfc_free_expr (*result);
     430                 :            :     }
     431                 :            : 
     432                 :        231 :   gfc_current_locus = old_loc;
     433                 :            : 
     434                 :        231 :   m = gfc_match_name (name);
     435                 :        231 :   if (m != MATCH_YES)
     436                 :            :     return m;
     437                 :            : 
     438                 :        225 :   if (gfc_find_symbol (name, NULL, 1, &sym))
     439                 :            :     return MATCH_ERROR;
     440                 :            : 
     441                 :        225 :   if (sym && sym->attr.generic)
     442                 :         37 :     dt_sym = gfc_find_dt_in_generic (sym);
     443                 :            : 
     444                 :        225 :   if (sym == NULL
     445                 :        225 :       || (sym->attr.flavor != FL_PARAMETER
     446                 :         42 :           && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
     447                 :            :     {
     448                 :          5 :       gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
     449                 :            :                  name);
     450                 :          5 :       *result = NULL;
     451                 :          5 :       return MATCH_ERROR;
     452                 :            :     }
     453                 :        220 :   else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
     454                 :         37 :     return gfc_match_structure_constructor (dt_sym, result);
     455                 :            : 
     456                 :            :   /* Check to see if the value is an initialization array expression.  */
     457                 :        183 :   if (sym->value->expr_type == EXPR_ARRAY)
     458                 :            :     {
     459                 :         67 :       gfc_current_locus = old_loc;
     460                 :            : 
     461                 :         67 :       m = gfc_match_init_expr (result);
     462                 :         67 :       if (m == MATCH_ERROR)
     463                 :            :         return m;
     464                 :            : 
     465                 :         67 :       if (m == MATCH_YES)
     466                 :            :         {
     467                 :         67 :           if (!gfc_simplify_expr (*result, 0))
     468                 :          0 :             m = MATCH_ERROR;
     469                 :            : 
     470                 :         67 :           if ((*result)->expr_type == EXPR_CONSTANT)
     471                 :            :             return m;
     472                 :            :           else
     473                 :            :             {
     474                 :          2 :               gfc_error ("Invalid initializer %s in Data statement at %C", name);
     475                 :          2 :               return MATCH_ERROR;
     476                 :            :             }
     477                 :            :         }
     478                 :            :     }
     479                 :            : 
     480                 :        116 :   *result = gfc_copy_expr (sym->value);
     481                 :        116 :   return MATCH_YES;
     482                 :            : }
     483                 :            : 
     484                 :            : 
     485                 :            : /* Match a list of values in a DATA statement.  The leading '/' has
     486                 :            :    already been seen at this point.  */
     487                 :            : 
     488                 :            : static match
     489                 :       2423 : top_val_list (gfc_data *data)
     490                 :            : {
     491                 :       2423 :   gfc_data_value *new_val, *tail;
     492                 :       2423 :   gfc_expr *expr;
     493                 :       2423 :   match m;
     494                 :            : 
     495                 :       2423 :   tail = NULL;
     496                 :            : 
     497                 :       8566 :   for (;;)
     498                 :            :     {
     499                 :       8566 :       m = match_data_constant (&expr);
     500                 :       8566 :       if (m == MATCH_NO)
     501                 :          3 :         goto syntax;
     502                 :       8563 :       if (m == MATCH_ERROR)
     503                 :            :         return MATCH_ERROR;
     504                 :            : 
     505                 :       8552 :       new_val = gfc_get_data_value ();
     506                 :       8552 :       mpz_init (new_val->repeat);
     507                 :            : 
     508                 :       8552 :       if (tail == NULL)
     509                 :       2409 :         data->value = new_val;
     510                 :            :       else
     511                 :       6143 :         tail->next = new_val;
     512                 :            : 
     513                 :       8552 :       tail = new_val;
     514                 :            : 
     515                 :       8552 :       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
     516                 :            :         {
     517                 :       8345 :           tail->expr = expr;
     518                 :       8345 :           mpz_set_ui (tail->repeat, 1);
     519                 :            :         }
     520                 :            :       else
     521                 :            :         {
     522                 :        207 :           mpz_set (tail->repeat, expr->value.integer);
     523                 :        207 :           gfc_free_expr (expr);
     524                 :            : 
     525                 :        207 :           m = match_data_constant (&tail->expr);
     526                 :        207 :           if (m == MATCH_NO)
     527                 :          0 :             goto syntax;
     528                 :        207 :           if (m == MATCH_ERROR)
     529                 :            :             return MATCH_ERROR;
     530                 :            :         }
     531                 :            : 
     532                 :       8548 :       if (gfc_match_char ('/') == MATCH_YES)
     533                 :            :         break;
     534                 :       6143 :       if (gfc_match_char (',') == MATCH_NO)
     535                 :          0 :         goto syntax;
     536                 :            :     }
     537                 :            : 
     538                 :            :   return MATCH_YES;
     539                 :            : 
     540                 :          3 : syntax:
     541                 :          3 :   gfc_syntax_error (ST_DATA);
     542                 :          3 :   gfc_free_data_all (gfc_current_ns);
     543                 :            :   return MATCH_ERROR;
     544                 :            : }
     545                 :            : 
     546                 :            : 
     547                 :            : /* Matches an old style initialization.  */
     548                 :            : 
     549                 :            : static match
     550                 :         52 : match_old_style_init (const char *name)
     551                 :            : {
     552                 :         52 :   match m;
     553                 :         52 :   gfc_symtree *st;
     554                 :         52 :   gfc_symbol *sym;
     555                 :         52 :   gfc_data *newdata, *nd;
     556                 :            : 
     557                 :            :   /* Set up data structure to hold initializers.  */
     558                 :         52 :   gfc_find_sym_tree (name, NULL, 0, &st);
     559                 :         52 :   sym = st->n.sym;
     560                 :            : 
     561                 :         52 :   newdata = gfc_get_data ();
     562                 :         52 :   newdata->var = gfc_get_data_variable ();
     563                 :         52 :   newdata->var->expr = gfc_get_variable_expr (st);
     564                 :         52 :   newdata->var->expr->where = sym->declared_at;
     565                 :         52 :   newdata->where = gfc_current_locus;
     566                 :            : 
     567                 :            :   /* Match initial value list. This also eats the terminal '/'.  */
     568                 :         52 :   m = top_val_list (newdata);
     569                 :         52 :   if (m != MATCH_YES)
     570                 :            :     {
     571                 :          1 :       free (newdata);
     572                 :          1 :       return m;
     573                 :            :     }
     574                 :            : 
     575                 :            :   /* Check that a BOZ did not creep into an old-style initialization.  */
     576                 :        101 :   for (nd = newdata; nd; nd = nd->next)
     577                 :            :     {
     578                 :         51 :       if (nd->value->expr->ts.type == BT_BOZ
     579                 :         51 :           && gfc_invalid_boz ("BOZ at %L cannot appear in an old-style "
     580                 :            :                               "initialization", &nd->value->expr->where))
     581                 :            :         return MATCH_ERROR;
     582                 :            : 
     583                 :         50 :       if (nd->var->expr->ts.type != BT_INTEGER
     584                 :         50 :           && nd->var->expr->ts.type != BT_REAL
     585                 :          3 :           && nd->value->expr->ts.type == BT_BOZ)
     586                 :            :         {
     587                 :          0 :           gfc_error ("BOZ literal constant near %L cannot be assigned to "
     588                 :            :                      "a %qs variable in an old-style initialization",
     589                 :          0 :                      &nd->value->expr->where,
     590                 :            :                      gfc_typename (&nd->value->expr->ts));
     591                 :          0 :           return MATCH_ERROR;
     592                 :            :         }
     593                 :            :     }
     594                 :            : 
     595                 :         50 :   if (gfc_pure (NULL))
     596                 :            :     {
     597                 :          1 :       gfc_error ("Initialization at %C is not allowed in a PURE procedure");
     598                 :          1 :       free (newdata);
     599                 :          1 :       return MATCH_ERROR;
     600                 :            :     }
     601                 :         49 :   gfc_unset_implicit_pure (gfc_current_ns->proc_name);
     602                 :            : 
     603                 :            :   /* Mark the variable as having appeared in a data statement.  */
     604                 :         49 :   if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
     605                 :            :     {
     606                 :          2 :       free (newdata);
     607                 :          2 :       return MATCH_ERROR;
     608                 :            :     }
     609                 :            : 
     610                 :            :   /* Chain in namespace list of DATA initializers.  */
     611                 :         47 :   newdata->next = gfc_current_ns->data;
     612                 :         47 :   gfc_current_ns->data = newdata;
     613                 :            : 
     614                 :         47 :   return m;
     615                 :            : }
     616                 :            : 
     617                 :            : 
     618                 :            : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
     619                 :            :    we are matching a DATA statement and are therefore issuing an error
     620                 :            :    if we encounter something unexpected, if not, we're trying to match
     621                 :            :    an old-style initialization expression of the form INTEGER I /2/.  */
     622                 :            : 
     623                 :            : match
     624                 :       2299 : gfc_match_data (void)
     625                 :            : {
     626                 :       2299 :   gfc_data *new_data;
     627                 :       2299 :   gfc_expr *e;
     628                 :       2299 :   gfc_ref *ref;
     629                 :       2299 :   match m;
     630                 :       2299 :   char c;
     631                 :            : 
     632                 :            :   /* DATA has been matched.  In free form source code, the next character
     633                 :            :      needs to be whitespace or '(' from an implied do-loop.  Check that
     634                 :            :      here.  */
     635                 :       2299 :   c = gfc_peek_ascii_char ();
     636                 :       2299 :   if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
     637                 :            :     return MATCH_NO;
     638                 :            : 
     639                 :            :   /* Before parsing the rest of a DATA statement, check F2008:c1206.  */
     640                 :       2298 :   if ((gfc_current_state () == COMP_FUNCTION
     641                 :       2298 :        || gfc_current_state () == COMP_SUBROUTINE)
     642                 :       1206 :       && gfc_state_stack->previous->state == COMP_INTERFACE)
     643                 :            :     {
     644                 :          1 :       gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
     645                 :          1 :       return MATCH_ERROR;
     646                 :            :     }
     647                 :            : 
     648                 :       2297 :   set_in_match_data (true);
     649                 :            : 
     650                 :       2483 :   for (;;)
     651                 :            :     {
     652                 :       2390 :       new_data = gfc_get_data ();
     653                 :       2390 :       new_data->where = gfc_current_locus;
     654                 :            : 
     655                 :       2390 :       m = top_var_list (new_data);
     656                 :       2390 :       if (m != MATCH_YES)
     657                 :         14 :         goto cleanup;
     658                 :            : 
     659                 :       2376 :       if (new_data->var->iter.var
     660                 :         92 :           && new_data->var->iter.var->ts.type == BT_INTEGER
     661                 :         48 :           && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
     662                 :         48 :           && new_data->var->list
     663                 :         48 :           && new_data->var->list->expr
     664                 :         36 :           && new_data->var->list->expr->ts.type == BT_CHARACTER
     665                 :          3 :           && new_data->var->list->expr->ref
     666                 :          3 :           && new_data->var->list->expr->ref->type == REF_SUBSTRING)
     667                 :            :         {
     668                 :          1 :           gfc_error ("Invalid substring in data-implied-do at %L in DATA "
     669                 :            :                      "statement", &new_data->var->list->expr->where);
     670                 :          1 :           goto cleanup;
     671                 :            :         }
     672                 :            : 
     673                 :            :       /* Check for an entity with an allocatable component, which is not
     674                 :            :          allowed.  */
     675                 :       2375 :       e = new_data->var->expr;
     676                 :       2375 :       if (e)
     677                 :            :         {
     678                 :       2284 :           bool invalid;
     679                 :            : 
     680                 :       2284 :           invalid = false;
     681                 :       3467 :           for (ref = e->ref; ref; ref = ref->next)
     682                 :       1183 :             if ((ref->type == REF_COMPONENT
     683                 :        121 :                  && ref->u.c.component->attr.allocatable)
     684                 :       1181 :                 || (ref->type == REF_ARRAY
     685                 :       1017 :                     && e->symtree->n.sym->attr.pointer != 1
     686                 :       1014 :                     && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
     687                 :          4 :               invalid = true;
     688                 :            : 
     689                 :       2284 :           if (invalid)
     690                 :            :             {
     691                 :          2 :               gfc_error ("Allocatable component or deferred-shaped array "
     692                 :            :                          "near %C in DATA statement");
     693                 :          2 :               goto cleanup;
     694                 :            :             }
     695                 :            : 
     696                 :            :           /* F2008:C567 (R536) A data-i-do-object or a variable that appears
     697                 :            :              as a data-stmt-object shall not be an object designator in which
     698                 :            :              a pointer appears other than as the entire rightmost part-ref.  */
     699                 :       2282 :           ref = e->ref;
     700                 :       2282 :           if (e->symtree->n.sym->ts.type == BT_DERIVED
     701                 :         84 :               && e->symtree->n.sym->attr.pointer
     702                 :          1 :               && ref->type == REF_COMPONENT)
     703                 :          1 :             goto partref;
     704                 :            : 
     705                 :       3456 :           for (; ref; ref = ref->next)
     706                 :       1176 :             if (ref->type == REF_COMPONENT
     707                 :        116 :                 && ref->u.c.component->attr.pointer
     708                 :         15 :                 && ref->next)
     709                 :          1 :               goto partref;
     710                 :            :         }
     711                 :            : 
     712                 :       2371 :       m = top_val_list (new_data);
     713                 :       2371 :       if (m != MATCH_YES)
     714                 :         17 :         goto cleanup;
     715                 :            : 
     716                 :       2354 :       new_data->next = gfc_current_ns->data;
     717                 :       2354 :       gfc_current_ns->data = new_data;
     718                 :            : 
     719                 :            :       /* A BOZ literal constant cannot appear in a structure constructor.
     720                 :            :          Check for that here for a data statement value.  */
     721                 :       2354 :       if (new_data->value->expr->ts.type == BT_DERIVED
     722                 :         24 :           && new_data->value->expr->value.constructor)
     723                 :            :         {
     724                 :         22 :           gfc_constructor *c;
     725                 :         22 :           c = gfc_constructor_first (new_data->value->expr->value.constructor);
     726                 :         43 :           for (; c; c = gfc_constructor_next (c))
     727                 :         22 :             if (c->expr->ts.type == BT_BOZ)
     728                 :            :               {
     729                 :          1 :                 gfc_error ("BOZ literal constant at %L cannot appear in a "
     730                 :            :                            "structure constructor", &c->expr->where);
     731                 :          1 :                 return MATCH_ERROR;
     732                 :            :               }
     733                 :            :         }
     734                 :            : 
     735                 :       2353 :       if (gfc_match_eos () == MATCH_YES)
     736                 :            :         break;
     737                 :            : 
     738                 :         93 :       gfc_match_char (',');     /* Optional comma */
     739                 :         93 :     }
     740                 :            : 
     741                 :       2260 :   set_in_match_data (false);
     742                 :            : 
     743                 :       2260 :   if (gfc_pure (NULL))
     744                 :            :     {
     745                 :          0 :       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
     746                 :          0 :       return MATCH_ERROR;
     747                 :            :     }
     748                 :       2260 :   gfc_unset_implicit_pure (gfc_current_ns->proc_name);
     749                 :            : 
     750                 :       2260 :   return MATCH_YES;
     751                 :            : 
     752                 :          2 : partref:
     753                 :            : 
     754                 :          2 :   gfc_error ("part-ref with pointer attribute near %L is not "
     755                 :            :              "rightmost part-ref of data-stmt-object",
     756                 :            :              &e->where);
     757                 :            : 
     758                 :         36 : cleanup:
     759                 :         36 :   set_in_match_data (false);
     760                 :         36 :   gfc_free_data (new_data);
     761                 :         36 :   return MATCH_ERROR;
     762                 :            : }
     763                 :            : 
     764                 :            : 
     765                 :            : /************************ Declaration statements *********************/
     766                 :            : 
     767                 :            : 
     768                 :            : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
     769                 :            :    list). The difference here is the expression is a list of constants
     770                 :            :    and is surrounded by '/'.
     771                 :            :    The typespec ts must match the typespec of the variable which the
     772                 :            :    clist is initializing.
     773                 :            :    The arrayspec tells whether this should match a list of constants
     774                 :            :    corresponding to array elements or a scalar (as == NULL).  */
     775                 :            : 
     776                 :            : static match
     777                 :         73 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
     778                 :            : {
     779                 :         73 :   gfc_constructor_base array_head = NULL;
     780                 :         73 :   gfc_expr *expr = NULL;
     781                 :         73 :   match m = MATCH_ERROR;
     782                 :         73 :   locus where;
     783                 :         73 :   mpz_t repeat, cons_size, as_size;
     784                 :         73 :   bool scalar;
     785                 :         73 :   int cmp;
     786                 :            : 
     787                 :         73 :   gcc_assert (ts);
     788                 :            : 
     789                 :            :   /* We have already matched '/' - now look for a constant list, as with
     790                 :            :      top_val_list from decl.c, but append the result to an array.  */
     791                 :         73 :   if (gfc_match ("/") == MATCH_YES)
     792                 :            :     {
     793                 :          1 :       gfc_error ("Empty old style initializer list at %C");
     794                 :          1 :       return MATCH_ERROR;
     795                 :            :     }
     796                 :            : 
     797                 :         72 :   where = gfc_current_locus;
     798                 :         72 :   scalar = !as || !as->rank;
     799                 :            : 
     800                 :         42 :   if (!scalar && !spec_size (as, &as_size))
     801                 :            :     {
     802                 :          2 :       gfc_error ("Array in initializer list at %L must have an explicit shape",
     803                 :          1 :                  as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
     804                 :            :       /* Nothing to cleanup yet.  */
     805                 :          1 :       return MATCH_ERROR;
     806                 :            :     }
     807                 :            : 
     808                 :         71 :   mpz_init_set_ui (repeat, 0);
     809                 :            : 
     810                 :        142 :   for (;;)
     811                 :            :     {
     812                 :        142 :       m = match_data_constant (&expr);
     813                 :        142 :       if (m != MATCH_YES)
     814                 :          3 :         expr = NULL; /* match_data_constant may set expr to garbage */
     815                 :        142 :       if (m == MATCH_NO)
     816                 :          2 :         goto syntax;
     817                 :        140 :       if (m == MATCH_ERROR)
     818                 :          1 :         goto cleanup;
     819                 :            : 
     820                 :            :       /* Found r in repeat spec r*c; look for the constant to repeat.  */
     821                 :        139 :       if ( gfc_match_char ('*') == MATCH_YES)
     822                 :            :         {
     823                 :         18 :           if (scalar)
     824                 :            :             {
     825                 :          1 :               gfc_error ("Repeat spec invalid in scalar initializer at %C");
     826                 :          1 :               goto cleanup;
     827                 :            :             }
     828                 :         17 :           if (expr->ts.type != BT_INTEGER)
     829                 :            :             {
     830                 :          1 :               gfc_error ("Repeat spec must be an integer at %C");
     831                 :          1 :               goto cleanup;
     832                 :            :             }
     833                 :         16 :           mpz_set (repeat, expr->value.integer);
     834                 :         16 :           gfc_free_expr (expr);
     835                 :         16 :           expr = NULL;
     836                 :            : 
     837                 :         16 :           m = match_data_constant (&expr);
     838                 :         16 :           if (m == MATCH_NO)
     839                 :            :             {
     840                 :          1 :               m = MATCH_ERROR;
     841                 :          1 :               gfc_error ("Expected data constant after repeat spec at %C");
     842                 :            :             }
     843                 :         16 :           if (m != MATCH_YES)
     844                 :          1 :             goto cleanup;
     845                 :            :         }
     846                 :            :       /* No repeat spec, we matched the data constant itself. */
     847                 :            :       else
     848                 :        121 :         mpz_set_ui (repeat, 1);
     849                 :            : 
     850                 :        136 :       if (!scalar)
     851                 :            :         {
     852                 :            :           /* Add the constant initializer as many times as repeated. */
     853                 :        251 :           for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
     854                 :            :             {
     855                 :            :               /* Make sure types of elements match */
     856                 :        144 :               if(ts && !gfc_compare_types (&expr->ts, ts)
     857                 :         12 :                     && !gfc_convert_type (expr, ts, 1))
     858                 :          0 :                 goto cleanup;
     859                 :            : 
     860                 :        144 :               gfc_constructor_append_expr (&array_head,
     861                 :            :                   gfc_copy_expr (expr), &gfc_current_locus);
     862                 :            :             }
     863                 :            : 
     864                 :        107 :           gfc_free_expr (expr);
     865                 :        107 :           expr = NULL;
     866                 :            :         }
     867                 :            : 
     868                 :            :       /* For scalar initializers quit after one element.  */
     869                 :            :       else
     870                 :            :         {
     871                 :         29 :           if(gfc_match_char ('/') != MATCH_YES)
     872                 :            :             {
     873                 :          1 :               gfc_error ("End of scalar initializer expected at %C");
     874                 :          1 :               goto cleanup;
     875                 :            :             }
     876                 :            :           break;
     877                 :            :         }
     878                 :            : 
     879                 :        107 :       if (gfc_match_char ('/') == MATCH_YES)
     880                 :            :         break;
     881                 :         72 :       if (gfc_match_char (',') == MATCH_NO)
     882                 :          1 :         goto syntax;
     883                 :            :     }
     884                 :            : 
     885                 :            :   /* If we break early from here out, we encountered an error.  */
     886                 :         63 :   m = MATCH_ERROR;
     887                 :            : 
     888                 :            :   /* Set up expr as an array constructor. */
     889                 :         63 :   if (!scalar)
     890                 :            :     {
     891                 :         35 :       expr = gfc_get_array_expr (ts->type, ts->kind, &where);
     892                 :         35 :       expr->ts = *ts;
     893                 :         35 :       expr->value.constructor = array_head;
     894                 :            : 
     895                 :         35 :       expr->rank = as->rank;
     896                 :         35 :       expr->shape = gfc_get_shape (expr->rank);
     897                 :            : 
     898                 :            :       /* Validate sizes.  We built expr ourselves, so cons_size will be
     899                 :            :          constant (we fail above for non-constant expressions).
     900                 :            :          We still need to verify that the sizes match.  */
     901                 :         35 :       gcc_assert (gfc_array_size (expr, &cons_size));
     902                 :         35 :       cmp = mpz_cmp (cons_size, as_size);
     903                 :         35 :       if (cmp < 0)
     904                 :          2 :         gfc_error ("Not enough elements in array initializer at %C");
     905                 :         33 :       else if (cmp > 0)
     906                 :          3 :         gfc_error ("Too many elements in array initializer at %C");
     907                 :         35 :       mpz_clear (cons_size);
     908                 :         35 :       if (cmp)
     909                 :          5 :         goto cleanup;
     910                 :            :     }
     911                 :            : 
     912                 :            :   /* Make sure scalar types match. */
     913                 :         28 :   else if (!gfc_compare_types (&expr->ts, ts)
     914                 :         28 :            && !gfc_convert_type (expr, ts, 1))
     915                 :          2 :     goto cleanup;
     916                 :            : 
     917                 :         56 :   if (expr->ts.u.cl)
     918                 :          0 :     expr->ts.u.cl->length_from_typespec = 1;
     919                 :            : 
     920                 :         56 :   *result = expr;
     921                 :         56 :   m = MATCH_YES;
     922                 :         56 :   goto done;
     923                 :            : 
     924                 :          3 : syntax:
     925                 :          3 :   m = MATCH_ERROR;
     926                 :          3 :   gfc_error ("Syntax error in old style initializer list at %C");
     927                 :            : 
     928                 :         15 : cleanup:
     929                 :         15 :   if (expr)
     930                 :         10 :     expr->value.constructor = NULL;
     931                 :         15 :   gfc_free_expr (expr);
     932                 :         15 :   gfc_constructor_free (array_head);
     933                 :            : 
     934                 :         71 : done:
     935                 :         71 :   mpz_clear (repeat);
     936                 :         71 :   if (!scalar)
     937                 :         41 :     mpz_clear (as_size);
     938                 :            :   return m;
     939                 :            : }
     940                 :            : 
     941                 :            : 
     942                 :            : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs.  */
     943                 :            : 
     944                 :            : static bool
     945                 :         68 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
     946                 :            : {
     947                 :         68 :   if ((from->type == AS_ASSUMED_RANK && to->corank)
     948                 :         66 :       || (to->type == AS_ASSUMED_RANK && from->corank))
     949                 :            :     {
     950                 :          4 :       gfc_error ("The assumed-rank array at %C shall not have a codimension");
     951                 :          4 :       return false;
     952                 :            :     }
     953                 :            : 
     954                 :         64 :   if (to->rank == 0 && from->rank > 0)
     955                 :            :     {
     956                 :         28 :       to->rank = from->rank;
     957                 :         28 :       to->type = from->type;
     958                 :         28 :       to->cray_pointee = from->cray_pointee;
     959                 :         28 :       to->cp_was_assumed = from->cp_was_assumed;
     960                 :            : 
     961                 :         92 :       for (int i = to->corank - 1; i >= 0; i--)
     962                 :            :         {
     963                 :            :           /* Do not exceed the limits on lower[] and upper[].  gfortran
     964                 :            :              cleans up elsewhere.  */
     965                 :         64 :           int j = from->rank + i;
     966                 :         64 :           if (j >= GFC_MAX_DIMENSIONS)
     967                 :            :             break;
     968                 :            : 
     969                 :         64 :           to->lower[j] = to->lower[i];
     970                 :         64 :           to->upper[j] = to->upper[i];
     971                 :            :         }
     972                 :         69 :       for (int i = 0; i < from->rank; i++)
     973                 :            :         {
     974                 :         41 :           if (copy)
     975                 :            :             {
     976                 :         25 :               to->lower[i] = gfc_copy_expr (from->lower[i]);
     977                 :         25 :               to->upper[i] = gfc_copy_expr (from->upper[i]);
     978                 :            :             }
     979                 :            :           else
     980                 :            :             {
     981                 :         16 :               to->lower[i] = from->lower[i];
     982                 :         16 :               to->upper[i] = from->upper[i];
     983                 :            :             }
     984                 :            :         }
     985                 :            :     }
     986                 :         36 :   else if (to->corank == 0 && from->corank > 0)
     987                 :            :     {
     988                 :         17 :       to->corank = from->corank;
     989                 :         17 :       to->cotype = from->cotype;
     990                 :            : 
     991                 :         65 :       for (int i = 0; i < from->corank; i++)
     992                 :            :         {
     993                 :            :           /* Do not exceed the limits on lower[] and upper[].  gfortran
     994                 :            :              cleans up elsewhere.  */
     995                 :         49 :           int k = from->rank + i;
     996                 :         49 :           int j = to->rank + i;
     997                 :         49 :           if (j >= GFC_MAX_DIMENSIONS)
     998                 :            :             break;
     999                 :            : 
    1000                 :         48 :           if (copy)
    1001                 :            :             {
    1002                 :         21 :               to->lower[j] = gfc_copy_expr (from->lower[k]);
    1003                 :         21 :               to->upper[j] = gfc_copy_expr (from->upper[k]);
    1004                 :            :             }
    1005                 :            :           else
    1006                 :            :             {
    1007                 :         27 :               to->lower[j] = from->lower[k];
    1008                 :         27 :               to->upper[j] = from->upper[k];
    1009                 :            :             }
    1010                 :            :         }
    1011                 :            :     }
    1012                 :            : 
    1013                 :         64 :   if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
    1014                 :            :     {
    1015                 :          1 :       gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
    1016                 :            :                  "allowed dimensions of %d",
    1017                 :            :                  to->rank, to->corank, GFC_MAX_DIMENSIONS);
    1018                 :          1 :       to->corank = GFC_MAX_DIMENSIONS - to->rank;
    1019                 :          1 :       return false;
    1020                 :            :     }
    1021                 :            :   return true;
    1022                 :            : }
    1023                 :            : 
    1024                 :            : 
    1025                 :            : /* Match an intent specification.  Since this can only happen after an
    1026                 :            :    INTENT word, a legal intent-spec must follow.  */
    1027                 :            : 
    1028                 :            : static sym_intent
    1029                 :      17264 : match_intent_spec (void)
    1030                 :            : {
    1031                 :            : 
    1032                 :      17264 :   if (gfc_match (" ( in out )") == MATCH_YES)
    1033                 :            :     return INTENT_INOUT;
    1034                 :      15047 :   if (gfc_match (" ( in )") == MATCH_YES)
    1035                 :            :     return INTENT_IN;
    1036                 :       2229 :   if (gfc_match (" ( out )") == MATCH_YES)
    1037                 :            :     return INTENT_OUT;
    1038                 :            : 
    1039                 :          2 :   gfc_error ("Bad INTENT specification at %C");
    1040                 :          2 :   return INTENT_UNKNOWN;
    1041                 :            : }
    1042                 :            : 
    1043                 :            : 
    1044                 :            : /* Matches a character length specification, which is either a
    1045                 :            :    specification expression, '*', or ':'.  */
    1046                 :            : 
    1047                 :            : static match
    1048                 :      18557 : char_len_param_value (gfc_expr **expr, bool *deferred)
    1049                 :            : {
    1050                 :      18557 :   match m;
    1051                 :            : 
    1052                 :      18557 :   *expr = NULL;
    1053                 :      18557 :   *deferred = false;
    1054                 :            : 
    1055                 :      18557 :   if (gfc_match_char ('*') == MATCH_YES)
    1056                 :            :     return MATCH_YES;
    1057                 :            : 
    1058                 :      14355 :   if (gfc_match_char (':') == MATCH_YES)
    1059                 :            :     {
    1060                 :       1325 :       if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
    1061                 :            :         return MATCH_ERROR;
    1062                 :            : 
    1063                 :       1323 :       *deferred = true;
    1064                 :            : 
    1065                 :       1323 :       return MATCH_YES;
    1066                 :            :     }
    1067                 :            : 
    1068                 :      13030 :   m = gfc_match_expr (expr);
    1069                 :            : 
    1070                 :      13030 :   if (m == MATCH_NO || m == MATCH_ERROR)
    1071                 :            :     return m;
    1072                 :            : 
    1073                 :      13025 :   if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
    1074                 :            :     return MATCH_ERROR;
    1075                 :            : 
    1076                 :      13019 :   if ((*expr)->expr_type == EXPR_FUNCTION)
    1077                 :            :     {
    1078                 :        834 :       if ((*expr)->ts.type == BT_INTEGER
    1079                 :        833 :           || ((*expr)->ts.type == BT_UNKNOWN
    1080                 :        833 :               && strcmp((*expr)->symtree->name, "null") != 0))
    1081                 :            :         return MATCH_YES;
    1082                 :            : 
    1083                 :          2 :       goto syntax;
    1084                 :            :     }
    1085                 :      12185 :   else if ((*expr)->expr_type == EXPR_CONSTANT)
    1086                 :            :     {
    1087                 :            :       /* F2008, 4.4.3.1:  The length is a type parameter; its kind is
    1088                 :            :          processor dependent and its value is greater than or equal to zero.
    1089                 :            :          F2008, 4.4.3.2:  If the character length parameter value evaluates
    1090                 :            :          to a negative value, the length of character entities declared
    1091                 :            :          is zero.  */
    1092                 :            : 
    1093                 :      11100 :       if ((*expr)->ts.type == BT_INTEGER)
    1094                 :            :         {
    1095                 :      11086 :           if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
    1096                 :          4 :             mpz_set_si ((*expr)->value.integer, 0);
    1097                 :            :         }
    1098                 :            :       else
    1099                 :         14 :         goto syntax;
    1100                 :            :     }
    1101                 :       1085 :   else if ((*expr)->expr_type == EXPR_ARRAY)
    1102                 :          6 :     goto syntax;
    1103                 :       1079 :   else if ((*expr)->expr_type == EXPR_VARIABLE)
    1104                 :            :     {
    1105                 :        743 :       bool t;
    1106                 :        743 :       gfc_expr *e;
    1107                 :            : 
    1108                 :        743 :       e = gfc_copy_expr (*expr);
    1109                 :            : 
    1110                 :            :       /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
    1111                 :            :          which causes an ICE if gfc_reduce_init_expr() is called.  */
    1112                 :        743 :       if (e->ref && e->ref->type == REF_ARRAY
    1113                 :          7 :           && e->ref->u.ar.type == AR_UNKNOWN
    1114                 :          6 :           && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
    1115                 :          2 :         goto syntax;
    1116                 :            : 
    1117                 :        741 :       t = gfc_reduce_init_expr (e);
    1118                 :            : 
    1119                 :        741 :       if (!t && e->ts.type == BT_UNKNOWN
    1120                 :          7 :           && e->symtree->n.sym->attr.untyped == 1
    1121                 :          7 :           && (flag_implicit_none
    1122                 :          5 :               || e->symtree->n.sym->ns->seen_implicit_none == 1
    1123                 :          1 :               || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
    1124                 :            :         {
    1125                 :          7 :           gfc_free_expr (e);
    1126                 :          7 :           goto syntax;
    1127                 :            :         }
    1128                 :            : 
    1129                 :        734 :       if ((e->ref && e->ref->type == REF_ARRAY
    1130                 :          3 :            && e->ref->u.ar.type != AR_ELEMENT)
    1131                 :        734 :           || (!e->ref && e->expr_type == EXPR_ARRAY))
    1132                 :            :         {
    1133                 :          1 :           gfc_free_expr (e);
    1134                 :          1 :           goto syntax;
    1135                 :            :         }
    1136                 :            : 
    1137                 :        733 :       gfc_free_expr (e);
    1138                 :            :     }
    1139                 :            : 
    1140                 :            :   return m;
    1141                 :            : 
    1142                 :         32 : syntax:
    1143                 :         32 :   gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
    1144                 :         32 :   return MATCH_ERROR;
    1145                 :            : }
    1146                 :            : 
    1147                 :            : 
    1148                 :            : /* A character length is a '*' followed by a literal integer or a
    1149                 :            :    char_len_param_value in parenthesis.  */
    1150                 :            : 
    1151                 :            : static match
    1152                 :      43883 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
    1153                 :            : {
    1154                 :      43883 :   int length;
    1155                 :      43883 :   match m;
    1156                 :            : 
    1157                 :      43883 :   *deferred = false;
    1158                 :      43883 :   m = gfc_match_char ('*');
    1159                 :      43883 :   if (m != MATCH_YES)
    1160                 :            :     return m;
    1161                 :            : 
    1162                 :       2678 :   m = gfc_match_small_literal_int (&length, NULL);
    1163                 :       2678 :   if (m == MATCH_ERROR)
    1164                 :            :     return m;
    1165                 :            : 
    1166                 :       2678 :   if (m == MATCH_YES)
    1167                 :            :     {
    1168                 :       2193 :       if (obsolescent_check
    1169                 :       2193 :           && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
    1170                 :            :         return MATCH_ERROR;
    1171                 :       2193 :       *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
    1172                 :       2193 :       return m;
    1173                 :            :     }
    1174                 :            : 
    1175                 :        485 :   if (gfc_match_char ('(') == MATCH_NO)
    1176                 :          0 :     goto syntax;
    1177                 :            : 
    1178                 :        485 :   m = char_len_param_value (expr, deferred);
    1179                 :        485 :   if (m != MATCH_YES && gfc_matching_function)
    1180                 :            :     {
    1181                 :          0 :       gfc_undo_symbols ();
    1182                 :          0 :       m = MATCH_YES;
    1183                 :            :     }
    1184                 :            : 
    1185                 :        485 :   if (m == MATCH_ERROR)
    1186                 :            :     return m;
    1187                 :        484 :   if (m == MATCH_NO)
    1188                 :          0 :     goto syntax;
    1189                 :            : 
    1190                 :        484 :   if (gfc_match_char (')') == MATCH_NO)
    1191                 :            :     {
    1192                 :          0 :       gfc_free_expr (*expr);
    1193                 :          0 :       *expr = NULL;
    1194                 :          0 :       goto syntax;
    1195                 :            :     }
    1196                 :            : 
    1197                 :            :   return MATCH_YES;
    1198                 :            : 
    1199                 :          0 : syntax:
    1200                 :          0 :   gfc_error ("Syntax error in character length specification at %C");
    1201                 :          0 :   return MATCH_ERROR;
    1202                 :            : }
    1203                 :            : 
    1204                 :            : 
    1205                 :            : /* Special subroutine for finding a symbol.  Check if the name is found
    1206                 :            :    in the current name space.  If not, and we're compiling a function or
    1207                 :            :    subroutine and the parent compilation unit is an interface, then check
    1208                 :            :    to see if the name we've been given is the name of the interface
    1209                 :            :    (located in another namespace).  */
    1210                 :            : 
    1211                 :            : static int
    1212                 :     185484 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
    1213                 :            : {
    1214                 :     185484 :   gfc_state_data *s;
    1215                 :     185484 :   gfc_symtree *st;
    1216                 :     185484 :   int i;
    1217                 :            : 
    1218                 :     185484 :   i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
    1219                 :     185484 :   if (i == 0)
    1220                 :            :     {
    1221                 :     185484 :       *result = st ? st->n.sym : NULL;
    1222                 :     185484 :       goto end;
    1223                 :            :     }
    1224                 :            : 
    1225                 :          0 :   if (gfc_current_state () != COMP_SUBROUTINE
    1226                 :          0 :       && gfc_current_state () != COMP_FUNCTION)
    1227                 :          0 :     goto end;
    1228                 :            : 
    1229                 :          0 :   s = gfc_state_stack->previous;
    1230                 :          0 :   if (s == NULL)
    1231                 :          0 :     goto end;
    1232                 :            : 
    1233                 :          0 :   if (s->state != COMP_INTERFACE)
    1234                 :          0 :     goto end;
    1235                 :          0 :   if (s->sym == NULL)
    1236                 :          0 :     goto end;             /* Nameless interface.  */
    1237                 :            : 
    1238                 :          0 :   if (strcmp (name, s->sym->name) == 0)
    1239                 :            :     {
    1240                 :          0 :       *result = s->sym;
    1241                 :          0 :       return 0;
    1242                 :            :     }
    1243                 :            : 
    1244                 :          0 : end:
    1245                 :            :   return i;
    1246                 :            : }
    1247                 :            : 
    1248                 :            : 
    1249                 :            : /* Special subroutine for getting a symbol node associated with a
    1250                 :            :    procedure name, used in SUBROUTINE and FUNCTION statements.  The
    1251                 :            :    symbol is created in the parent using with symtree node in the
    1252                 :            :    child unit pointing to the symbol.  If the current namespace has no
    1253                 :            :    parent, then the symbol is just created in the current unit.  */
    1254                 :            : 
    1255                 :            : static int
    1256                 :      40182 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
    1257                 :            : {
    1258                 :      40182 :   gfc_symtree *st;
    1259                 :      40182 :   gfc_symbol *sym;
    1260                 :      40182 :   int rc = 0;
    1261                 :            : 
    1262                 :            :   /* Module functions have to be left in their own namespace because
    1263                 :            :      they have potentially (almost certainly!) already been referenced.
    1264                 :            :      In this sense, they are rather like external functions.  This is
    1265                 :            :      fixed up in resolve.c(resolve_entries), where the symbol name-
    1266                 :            :      space is set to point to the master function, so that the fake
    1267                 :            :      result mechanism can work.  */
    1268                 :      40182 :   if (module_fcn_entry)
    1269                 :            :     {
    1270                 :            :       /* Present if entry is declared to be a module procedure.  */
    1271                 :        209 :       rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
    1272                 :            : 
    1273                 :        209 :       if (*result == NULL)
    1274                 :        167 :         rc = gfc_get_symbol (name, NULL, result);
    1275                 :         84 :       else if (!gfc_get_symbol (name, NULL, &sym) && sym
    1276                 :         42 :                  && (*result)->ts.type == BT_UNKNOWN
    1277                 :         84 :                  && sym->attr.flavor == FL_UNKNOWN)
    1278                 :            :         /* Pick up the typespec for the entry, if declared in the function
    1279                 :            :            body.  Note that this symbol is FL_UNKNOWN because it will
    1280                 :            :            only have appeared in a type declaration.  The local symtree
    1281                 :            :            is set to point to the module symbol and a unique symtree
    1282                 :            :            to the local version.  This latter ensures a correct clearing
    1283                 :            :            of the symbols.  */
    1284                 :            :         {
    1285                 :            :           /* If the ENTRY proceeds its specification, we need to ensure
    1286                 :            :              that this does not raise a "has no IMPLICIT type" error.  */
    1287                 :         42 :           if (sym->ts.type == BT_UNKNOWN)
    1288                 :         22 :             sym->attr.untyped = 1;
    1289                 :            : 
    1290                 :         42 :           (*result)->ts = sym->ts;
    1291                 :            : 
    1292                 :            :           /* Put the symbol in the procedure namespace so that, should
    1293                 :            :              the ENTRY precede its specification, the specification
    1294                 :            :              can be applied.  */
    1295                 :         42 :           (*result)->ns = gfc_current_ns;
    1296                 :            : 
    1297                 :         42 :           gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
    1298                 :         42 :           st->n.sym = *result;
    1299                 :         42 :           st = gfc_get_unique_symtree (gfc_current_ns);
    1300                 :         42 :           sym->refs++;
    1301                 :         42 :           st->n.sym = sym;
    1302                 :            :         }
    1303                 :            :     }
    1304                 :            :   else
    1305                 :      39973 :     rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
    1306                 :            : 
    1307                 :      40182 :   if (rc)
    1308                 :            :     return rc;
    1309                 :            : 
    1310                 :      40181 :   sym = *result;
    1311                 :      40181 :   if (sym->attr.proc == PROC_ST_FUNCTION)
    1312                 :            :     return rc;
    1313                 :            : 
    1314                 :      40181 :   if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
    1315                 :            :     {
    1316                 :            :       /* Create a partially populated interface symbol to carry the
    1317                 :            :          characteristics of the procedure and the result.  */
    1318                 :        287 :       sym->tlink = gfc_new_symbol (name, sym->ns);
    1319                 :        287 :       gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
    1320                 :        287 :       gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
    1321                 :        287 :       if (sym->attr.dimension)
    1322                 :         15 :         sym->tlink->as = gfc_copy_array_spec (sym->as);
    1323                 :            : 
    1324                 :            :       /* Ideally, at this point, a copy would be made of the formal
    1325                 :            :          arguments and their namespace. However, this does not appear
    1326                 :            :          to be necessary, albeit at the expense of not being able to
    1327                 :            :          use gfc_compare_interfaces directly.  */
    1328                 :            : 
    1329                 :        287 :       if (sym->result && sym->result != sym)
    1330                 :            :         {
    1331                 :         47 :           sym->tlink->result = sym->result;
    1332                 :         47 :           sym->result = NULL;
    1333                 :            :         }
    1334                 :        240 :       else if (sym->result)
    1335                 :            :         {
    1336                 :         58 :           sym->tlink->result = sym->tlink;
    1337                 :            :         }
    1338                 :            :     }
    1339                 :      39894 :   else if (sym && !sym->gfc_new
    1340                 :      15335 :            && gfc_current_state () != COMP_INTERFACE)
    1341                 :            :     {
    1342                 :            :       /* Trap another encompassed procedure with the same name.  All
    1343                 :            :          these conditions are necessary to avoid picking up an entry
    1344                 :            :          whose name clashes with that of the encompassing procedure;
    1345                 :            :          this is handled using gsymbols to register unique, globally
    1346                 :            :          accessible names.  */
    1347                 :      14649 :       if (sym->attr.flavor != 0
    1348                 :      13164 :           && sym->attr.proc != 0
    1349                 :       1690 :           && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
    1350                 :          6 :           && sym->attr.if_source != IFSRC_UNKNOWN)
    1351                 :            :         {
    1352                 :          6 :           gfc_error_now ("Procedure %qs at %C is already defined at %L",
    1353                 :            :                          name, &sym->declared_at);
    1354                 :          6 :           return true;
    1355                 :            :         }
    1356                 :      14643 :       if (sym->attr.flavor != 0
    1357                 :      13158 :           && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
    1358                 :            :         {
    1359                 :          1 :           gfc_error_now ("Procedure %qs at %C is already defined at %L",
    1360                 :            :                          name, &sym->declared_at);
    1361                 :          1 :           return true;
    1362                 :            :         }
    1363                 :            : 
    1364                 :      14642 :       if (sym->attr.external && sym->attr.procedure
    1365                 :          2 :           && gfc_current_state () == COMP_CONTAINS)
    1366                 :            :         {
    1367                 :          1 :           gfc_error_now ("Contained procedure %qs at %C clashes with "
    1368                 :            :                          "procedure defined at %L",
    1369                 :            :                          name, &sym->declared_at);
    1370                 :          1 :           return true;
    1371                 :            :         }
    1372                 :            : 
    1373                 :            :       /* Trap a procedure with a name the same as interface in the
    1374                 :            :          encompassing scope.  */
    1375                 :      14641 :       if (sym->attr.generic != 0
    1376                 :         52 :           && (sym->attr.subroutine || sym->attr.function)
    1377                 :          1 :           && !sym->attr.mod_proc)
    1378                 :            :         {
    1379                 :          1 :           gfc_error_now ("Name %qs at %C is already defined"
    1380                 :            :                          " as a generic interface at %L",
    1381                 :            :                          name, &sym->declared_at);
    1382                 :          1 :           return true;
    1383                 :            :         }
    1384                 :            : 
    1385                 :            :       /* Trap declarations of attributes in encompassing scope.  The
    1386                 :            :          signature for this is that ts.kind is nonzero for no-CLASS
    1387                 :            :          entity.  For a CLASS entity, ts.kind is zero.  */
    1388                 :      14640 :       if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS)
    1389                 :        289 :           && !sym->attr.implicit_type
    1390                 :        288 :           && sym->attr.proc == 0
    1391                 :        282 :           && gfc_current_ns->parent != NULL
    1392                 :         86 :           && sym->attr.access == 0
    1393                 :         84 :           && !module_fcn_entry)
    1394                 :            :         {
    1395                 :          3 :           gfc_error_now ("Procedure %qs at %C has an explicit interface "
    1396                 :            :                        "from a previous declaration",  name);
    1397                 :          3 :           return true;
    1398                 :            :         }
    1399                 :            :     }
    1400                 :            : 
    1401                 :            :   /* C1246 (R1225) MODULE shall appear only in the function-stmt or
    1402                 :            :      subroutine-stmt of a module subprogram or of a nonabstract interface
    1403                 :            :      body that is declared in the scoping unit of a module or submodule.  */
    1404                 :      40169 :   if (sym->attr.external
    1405                 :      40169 :       && (sym->attr.subroutine || sym->attr.function)
    1406                 :         27 :       && sym->attr.if_source == IFSRC_IFBODY
    1407                 :         27 :       && !current_attr.module_procedure
    1408                 :          2 :       && sym->attr.proc == PROC_MODULE
    1409                 :          1 :       && gfc_state_stack->state == COMP_CONTAINS)
    1410                 :            :     {
    1411                 :          1 :       gfc_error_now ("Procedure %qs defined in interface body at %L "
    1412                 :            :                      "clashes with internal procedure defined at %C",
    1413                 :            :                      name, &sym->declared_at);
    1414                 :          1 :       return true;
    1415                 :            :     }
    1416                 :            : 
    1417                 :      40168 :   if (sym && !sym->gfc_new
    1418                 :      15609 :       && sym->attr.flavor != FL_UNKNOWN
    1419                 :      13883 :       && sym->attr.referenced == 0 && sym->attr.subroutine == 1
    1420                 :        181 :       && gfc_state_stack->state == COMP_CONTAINS
    1421                 :        177 :       && gfc_state_stack->previous->state == COMP_SUBROUTINE)
    1422                 :            :     {
    1423                 :          1 :       gfc_error_now ("Procedure %qs at %C is already defined at %L",
    1424                 :            :                      name, &sym->declared_at);
    1425                 :          1 :       return true;
    1426                 :            :     }
    1427                 :            : 
    1428                 :      40167 :   if (gfc_current_ns->parent == NULL || *result == NULL)
    1429                 :            :     return rc;
    1430                 :            : 
    1431                 :            :   /* Module function entries will already have a symtree in
    1432                 :            :      the current namespace but will need one at module level.  */
    1433                 :      30294 :   if (module_fcn_entry)
    1434                 :            :     {
    1435                 :            :       /* Present if entry is declared to be a module procedure.  */
    1436                 :        207 :       rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
    1437                 :        207 :       if (st == NULL)
    1438                 :        167 :         st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
    1439                 :            :     }
    1440                 :            :   else
    1441                 :      30087 :     st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
    1442                 :            : 
    1443                 :      30294 :   st->n.sym = sym;
    1444                 :      30294 :   sym->refs++;
    1445                 :            : 
    1446                 :            :   /* See if the procedure should be a module procedure.  */
    1447                 :            : 
    1448                 :      30294 :   if (((sym->ns->proc_name != NULL
    1449                 :      30294 :         && sym->ns->proc_name->attr.flavor == FL_MODULE
    1450                 :      13275 :         && sym->attr.proc != PROC_MODULE)
    1451                 :      30294 :        || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
    1452                 :      41621 :       && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
    1453                 :            :     rc = 2;
    1454                 :            : 
    1455                 :            :   return rc;
    1456                 :            : }
    1457                 :            : 
    1458                 :            : 
    1459                 :            : /* Verify that the given symbol representing a parameter is C
    1460                 :            :    interoperable, by checking to see if it was marked as such after
    1461                 :            :    its declaration.  If the given symbol is not interoperable, a
    1462                 :            :    warning is reported, thus removing the need to return the status to
    1463                 :            :    the calling function.  The standard does not require the user use
    1464                 :            :    one of the iso_c_binding named constants to declare an
    1465                 :            :    interoperable parameter, but we can't be sure if the param is C
    1466                 :            :    interop or not if the user doesn't.  For example, integer(4) may be
    1467                 :            :    legal Fortran, but doesn't have meaning in C.  It may interop with
    1468                 :            :    a number of the C types, which causes a problem because the
    1469                 :            :    compiler can't know which one.  This code is almost certainly not
    1470                 :            :    portable, and the user will get what they deserve if the C type
    1471                 :            :    across platforms isn't always interoperable with integer(4).  If
    1472                 :            :    the user had used something like integer(c_int) or integer(c_long),
    1473                 :            :    the compiler could have automatically handled the varying sizes
    1474                 :            :    across platforms.  */
    1475                 :            : 
    1476                 :            : bool
    1477                 :       1738 : gfc_verify_c_interop_param (gfc_symbol *sym)
    1478                 :            : {
    1479                 :       1738 :   int is_c_interop = 0;
    1480                 :       1738 :   bool retval = true;
    1481                 :            : 
    1482                 :            :   /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
    1483                 :            :      Don't repeat the checks here.  */
    1484                 :       1738 :   if (sym->attr.implicit_type)
    1485                 :            :     return true;
    1486                 :            : 
    1487                 :            :   /* For subroutines or functions that are passed to a BIND(C) procedure,
    1488                 :            :      they're interoperable if they're BIND(C) and their params are all
    1489                 :            :      interoperable.  */
    1490                 :       1738 :   if (sym->attr.flavor == FL_PROCEDURE)
    1491                 :            :     {
    1492                 :          0 :       if (sym->attr.is_bind_c == 0)
    1493                 :            :         {
    1494                 :          0 :           gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
    1495                 :            :                          "attribute to be C interoperable", sym->name,
    1496                 :            :                          &(sym->declared_at));
    1497                 :          0 :           return false;
    1498                 :            :         }
    1499                 :            :       else
    1500                 :            :         {
    1501                 :          0 :           if (sym->attr.is_c_interop == 1)
    1502                 :            :             /* We've already checked this procedure; don't check it again.  */
    1503                 :            :             return true;
    1504                 :            :           else
    1505                 :          0 :             return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
    1506                 :          0 :                                       sym->common_block);
    1507                 :            :         }
    1508                 :            :     }
    1509                 :            : 
    1510                 :            :   /* See if we've stored a reference to a procedure that owns sym.  */
    1511                 :       1738 :   if (sym->ns != NULL && sym->ns->proc_name != NULL)
    1512                 :            :     {
    1513                 :       1738 :       if (sym->ns->proc_name->attr.is_bind_c == 1)
    1514                 :            :         {
    1515                 :       1700 :           is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
    1516                 :            : 
    1517                 :         91 :           if (is_c_interop != 1)
    1518                 :            :             {
    1519                 :            :               /* Make personalized messages to give better feedback.  */
    1520                 :         91 :               if (sym->ts.type == BT_DERIVED)
    1521                 :          1 :                 gfc_error ("Variable %qs at %L is a dummy argument to the "
    1522                 :            :                            "BIND(C) procedure %qs but is not C interoperable "
    1523                 :            :                            "because derived type %qs is not C interoperable",
    1524                 :            :                            sym->name, &(sym->declared_at),
    1525                 :          1 :                            sym->ns->proc_name->name,
    1526                 :          1 :                            sym->ts.u.derived->name);
    1527                 :         90 :               else if (sym->ts.type == BT_CLASS)
    1528                 :          1 :                 gfc_error ("Variable %qs at %L is a dummy argument to the "
    1529                 :            :                            "BIND(C) procedure %qs but is not C interoperable "
    1530                 :            :                            "because it is polymorphic",
    1531                 :            :                            sym->name, &(sym->declared_at),
    1532                 :          1 :                            sym->ns->proc_name->name);
    1533                 :         89 :               else if (warn_c_binding_type)
    1534                 :         15 :                 gfc_warning (OPT_Wc_binding_type,
    1535                 :            :                              "Variable %qs at %L is a dummy argument of the "
    1536                 :            :                              "BIND(C) procedure %qs but may not be C "
    1537                 :            :                              "interoperable",
    1538                 :            :                              sym->name, &(sym->declared_at),
    1539                 :         15 :                              sym->ns->proc_name->name);
    1540                 :            :             }
    1541                 :            : 
    1542                 :            :           /* Character strings are only C interoperable if they have a
    1543                 :            :              length of 1.  */
    1544                 :       1700 :           if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension)
    1545                 :            :             {
    1546                 :         85 :               gfc_charlen *cl = sym->ts.u.cl;
    1547                 :         85 :               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
    1548                 :         83 :                   || mpz_cmp_si (cl->length->value.integer, 1) != 0)
    1549                 :            :                 {
    1550                 :          4 :                   gfc_error ("Character argument %qs at %L "
    1551                 :            :                              "must be length 1 because "
    1552                 :            :                              "procedure %qs is BIND(C)",
    1553                 :            :                              sym->name, &sym->declared_at,
    1554                 :          4 :                              sym->ns->proc_name->name);
    1555                 :          4 :                   retval = false;
    1556                 :            :                 }
    1557                 :            :             }
    1558                 :            : 
    1559                 :            :           /* We have to make sure that any param to a bind(c) routine does
    1560                 :            :              not have the allocatable, pointer, or optional attributes,
    1561                 :            :              according to J3/04-007, section 5.1.  */
    1562                 :       1700 :           if (sym->attr.allocatable == 1
    1563                 :       1758 :               && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
    1564                 :            :                                   "ALLOCATABLE attribute in procedure %qs "
    1565                 :            :                                   "with BIND(C)", sym->name,
    1566                 :            :                                   &(sym->declared_at),
    1567                 :         58 :                                   sym->ns->proc_name->name))
    1568                 :            :             retval = false;
    1569                 :            : 
    1570                 :       1700 :           if (sym->attr.pointer == 1
    1571                 :       1715 :               && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
    1572                 :            :                                   "POINTER attribute in procedure %qs "
    1573                 :            :                                   "with BIND(C)", sym->name,
    1574                 :            :                                   &(sym->declared_at),
    1575                 :         15 :                                   sym->ns->proc_name->name))
    1576                 :            :             retval = false;
    1577                 :            : 
    1578                 :       1700 :           if (sym->attr.optional == 1 && sym->attr.value)
    1579                 :            :             {
    1580                 :          8 :               gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
    1581                 :            :                          "and the VALUE attribute because procedure %qs "
    1582                 :            :                          "is BIND(C)", sym->name, &(sym->declared_at),
    1583                 :          8 :                          sym->ns->proc_name->name);
    1584                 :          8 :               retval = false;
    1585                 :            :             }
    1586                 :       1692 :           else if (sym->attr.optional == 1
    1587                 :       1741 :                    && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
    1588                 :            :                                        "at %L with OPTIONAL attribute in "
    1589                 :            :                                        "procedure %qs which is BIND(C)",
    1590                 :            :                                        sym->name, &(sym->declared_at),
    1591                 :         49 :                                        sym->ns->proc_name->name))
    1592                 :            :             retval = false;
    1593                 :            : 
    1594                 :            :           /* Make sure that if it has the dimension attribute, that it is
    1595                 :            :              either assumed size or explicit shape. Deferred shape is already
    1596                 :            :              covered by the pointer/allocatable attribute.  */
    1597                 :        365 :           if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
    1598                 :       1760 :               && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
    1599                 :            :                                   "at %L as dummy argument to the BIND(C) "
    1600                 :            :                                   "procedure %qs at %L", sym->name,
    1601                 :            :                                   &(sym->declared_at),
    1602                 :            :                                   sym->ns->proc_name->name,
    1603                 :         60 :                                   &(sym->ns->proc_name->declared_at)))
    1604                 :            :             retval = false;
    1605                 :            :         }
    1606                 :            :     }
    1607                 :            : 
    1608                 :            :   return retval;
    1609                 :            : }
    1610                 :            : 
    1611                 :            : 
    1612                 :            : 
    1613                 :            : /* Function called by variable_decl() that adds a name to the symbol table.  */
    1614                 :            : 
    1615                 :            : static bool
    1616                 :     173429 : build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
    1617                 :            :            gfc_array_spec **as, locus *var_locus)
    1618                 :            : {
    1619                 :     173429 :   symbol_attribute attr;
    1620                 :     173429 :   gfc_symbol *sym;
    1621                 :     173429 :   int upper;
    1622                 :     173429 :   gfc_symtree *st;
    1623                 :            : 
    1624                 :            :   /* Symbols in a submodule are host associated from the parent module or
    1625                 :            :      submodules. Therefore, they can be overridden by declarations in the
    1626                 :            :      submodule scope. Deal with this by attaching the existing symbol to
    1627                 :            :      a new symtree and recycling the old symtree with a new symbol...  */
    1628                 :     173429 :   st = gfc_find_symtree (gfc_current_ns->sym_root, name);
    1629                 :     173429 :   if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
    1630                 :         12 :       && st->n.sym != NULL
    1631                 :         12 :       && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
    1632                 :            :     {
    1633                 :         12 :       gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
    1634                 :         12 :       s->n.sym = st->n.sym;
    1635                 :         12 :       sym = gfc_new_symbol (name, gfc_current_ns);
    1636                 :            : 
    1637                 :            : 
    1638                 :         12 :       st->n.sym = sym;
    1639                 :         12 :       sym->refs++;
    1640                 :         12 :       gfc_set_sym_referenced (sym);
    1641                 :            :     }
    1642                 :            :   /* ...Otherwise generate a new symtree and new symbol.  */
    1643                 :     173417 :   else if (gfc_get_symbol (name, NULL, &sym))
    1644                 :            :     return false;
    1645                 :            : 
    1646                 :            :   /* Check if the name has already been defined as a type.  The
    1647                 :            :      first letter of the symtree will be in upper case then.  Of
    1648                 :            :      course, this is only necessary if the upper case letter is
    1649                 :            :      actually different.  */
    1650                 :            : 
    1651                 :     173429 :   upper = TOUPPER(name[0]);
    1652                 :     173429 :   if (upper != name[0])
    1653                 :            :     {
    1654                 :     172795 :       char u_name[GFC_MAX_SYMBOL_LEN + 1];
    1655                 :     172795 :       gfc_symtree *st;
    1656                 :            : 
    1657                 :     172795 :       gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
    1658                 :     172795 :       strcpy (u_name, name);
    1659                 :     172795 :       u_name[0] = upper;
    1660                 :            : 
    1661                 :     172795 :       st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
    1662                 :            : 
    1663                 :            :       /* STRUCTURE types can alias symbol names */
    1664                 :     172795 :       if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
    1665                 :            :         {
    1666                 :          1 :           gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
    1667                 :            :                      &st->n.sym->declared_at);
    1668                 :          1 :           return false;
    1669                 :            :         }
    1670                 :            :     }
    1671                 :            : 
    1672                 :            :   /* Start updating the symbol table.  Add basic type attribute if present.  */
    1673                 :     173428 :   if (current_ts.type != BT_UNKNOWN
    1674                 :     173428 :       && (sym->attr.implicit_type == 0
    1675                 :        203 :           || !gfc_compare_types (&sym->ts, &current_ts))
    1676                 :     346657 :       && !gfc_add_type (sym, &current_ts, var_locus))
    1677                 :            :     return false;
    1678                 :            : 
    1679                 :     173406 :   if (sym->ts.type == BT_CHARACTER)
    1680                 :            :     {
    1681                 :      20811 :       sym->ts.u.cl = cl;
    1682                 :      20811 :       sym->ts.deferred = cl_deferred;
    1683                 :            :     }
    1684                 :            : 
    1685                 :            :   /* Add dimension attribute if present.  */
    1686                 :     173406 :   if (!gfc_set_array_spec (sym, *as, var_locus))
    1687                 :            :     return false;
    1688                 :     173404 :   *as = NULL;
    1689                 :            : 
    1690                 :            :   /* Add attribute to symbol.  The copy is so that we can reset the
    1691                 :            :      dimension attribute.  */
    1692                 :     173404 :   attr = current_attr;
    1693                 :     173404 :   attr.dimension = 0;
    1694                 :     173404 :   attr.codimension = 0;
    1695                 :            : 
    1696                 :     173404 :   if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
    1697                 :            :     return false;
    1698                 :            : 
    1699                 :            :   /* Finish any work that may need to be done for the binding label,
    1700                 :            :      if it's a bind(c).  The bind(c) attr is found before the symbol
    1701                 :            :      is made, and before the symbol name (for data decls), so the
    1702                 :            :      current_ts is holding the binding label, or nothing if the
    1703                 :            :      name= attr wasn't given.  Therefore, test here if we're dealing
    1704                 :            :      with a bind(c) and make sure the binding label is set correctly.  */
    1705                 :     173392 :   if (sym->attr.is_bind_c == 1)
    1706                 :            :     {
    1707                 :        317 :       if (!sym->binding_label)
    1708                 :            :         {
    1709                 :            :           /* Set the binding label and verify that if a NAME= was specified
    1710                 :            :              then only one identifier was in the entity-decl-list.  */
    1711                 :        111 :           if (!set_binding_label (&sym->binding_label, sym->name,
    1712                 :            :                                   num_idents_on_line))
    1713                 :            :             return false;
    1714                 :            :         }
    1715                 :            :     }
    1716                 :            : 
    1717                 :            :   /* See if we know we're in a common block, and if it's a bind(c)
    1718                 :            :      common then we need to make sure we're an interoperable type.  */
    1719                 :     173390 :   if (sym->attr.in_common == 1)
    1720                 :            :     {
    1721                 :            :       /* Test the common block object.  */
    1722                 :        628 :       if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
    1723                 :          6 :           && sym->ts.is_c_interop != 1)
    1724                 :            :         {
    1725                 :          0 :           gfc_error_now ("Variable %qs in common block %qs at %C "
    1726                 :            :                          "must be declared with a C interoperable "
    1727                 :            :                          "kind since common block %qs is BIND(C)",
    1728                 :            :                          sym->name, sym->common_block->name,
    1729                 :          0 :                          sym->common_block->name);
    1730                 :          0 :           gfc_clear_error ();
    1731                 :            :         }
    1732                 :            :     }
    1733                 :            : 
    1734                 :     173390 :   sym->attr.implied_index = 0;
    1735                 :            : 
    1736                 :            :   /* Use the parameter expressions for a parameterized derived type.  */
    1737                 :     173390 :   if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
    1738                 :      22930 :       && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
    1739                 :        465 :     sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
    1740                 :            : 
    1741                 :     173390 :   if (sym->ts.type == BT_CLASS)
    1742                 :       7458 :     return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
    1743                 :            : 
    1744                 :            :   return true;
    1745                 :            : }
    1746                 :            : 
    1747                 :            : 
    1748                 :            : /* Set character constant to the given length. The constant will be padded or
    1749                 :            :    truncated.  If we're inside an array constructor without a typespec, we
    1750                 :            :    additionally check that all elements have the same length; check_len -1
    1751                 :            :    means no checking.  */
    1752                 :            : 
    1753                 :            : void
    1754                 :       9561 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
    1755                 :            :                                 gfc_charlen_t check_len)
    1756                 :            : {
    1757                 :       9561 :   gfc_char_t *s;
    1758                 :       9561 :   gfc_charlen_t slen;
    1759                 :            : 
    1760                 :       9561 :   if (expr->ts.type != BT_CHARACTER)
    1761                 :            :     return;
    1762                 :            : 
    1763                 :       9560 :   if (expr->expr_type != EXPR_CONSTANT)
    1764                 :            :     {
    1765                 :          1 :       gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
    1766                 :          1 :       return;
    1767                 :            :     }
    1768                 :            : 
    1769                 :       9559 :   slen = expr->value.character.length;
    1770                 :       9559 :   if (len != slen)
    1771                 :            :     {
    1772                 :       1189 :       s = gfc_get_wide_string (len + 1);
    1773                 :       1189 :       memcpy (s, expr->value.character.string,
    1774                 :       1189 :               MIN (len, slen) * sizeof (gfc_char_t));
    1775                 :       1189 :       if (len > slen)
    1776                 :       1043 :         gfc_wide_memset (&s[slen], ' ', len - slen);
    1777                 :            : 
    1778                 :       1189 :       if (warn_character_truncation && slen > len)
    1779                 :          1 :         gfc_warning_now (OPT_Wcharacter_truncation,
    1780                 :            :                          "CHARACTER expression at %L is being truncated "
    1781                 :            :                          "(%ld/%ld)", &expr->where,
    1782                 :            :                          (long) slen, (long) len);
    1783                 :            : 
    1784                 :            :       /* Apply the standard by 'hand' otherwise it gets cleared for
    1785                 :            :          initializers.  */
    1786                 :       1189 :       if (check_len != -1 && slen != check_len
    1787                 :         36 :           && !(gfc_option.allow_std & GFC_STD_GNU))
    1788                 :          0 :         gfc_error_now ("The CHARACTER elements of the array constructor "
    1789                 :            :                        "at %L must have the same length (%ld/%ld)",
    1790                 :            :                        &expr->where, (long) slen,
    1791                 :            :                        (long) check_len);
    1792                 :            : 
    1793                 :       1189 :       s[len] = '\0';
    1794                 :       1189 :       free (expr->value.character.string);
    1795                 :       1189 :       expr->value.character.string = s;
    1796                 :       1189 :       expr->value.character.length = len;
    1797                 :            :       /* If explicit representation was given, clear it
    1798                 :            :          as it is no longer needed after padding.  */
    1799                 :       1189 :       if (expr->representation.length)
    1800                 :            :         {
    1801                 :         80 :           expr->representation.length = 0;
    1802                 :         80 :           free (expr->representation.string);
    1803                 :         80 :           expr->representation.string = NULL;
    1804                 :            :         }
    1805                 :            :     }
    1806                 :            : }
    1807                 :            : 
    1808                 :            : 
    1809                 :            : /* Function to create and update the enumerator history
    1810                 :            :    using the information passed as arguments.
    1811                 :            :    Pointer "max_enum" is also updated, to point to
    1812                 :            :    enum history node containing largest initializer.
    1813                 :            : 
    1814                 :            :    SYM points to the symbol node of enumerator.
    1815                 :            :    INIT points to its enumerator value.  */
    1816                 :            : 
    1817                 :            : static void
    1818                 :        543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
    1819                 :            : {
    1820                 :        543 :   enumerator_history *new_enum_history;
    1821                 :        543 :   gcc_assert (sym != NULL && init != NULL);
    1822                 :            : 
    1823                 :        543 :   new_enum_history = XCNEW (enumerator_history);
    1824                 :            : 
    1825                 :        543 :   new_enum_history->sym = sym;
    1826                 :        543 :   new_enum_history->initializer = init;
    1827                 :        543 :   new_enum_history->next = NULL;
    1828                 :            : 
    1829                 :        543 :   if (enum_history == NULL)
    1830                 :            :     {
    1831                 :        160 :       enum_history = new_enum_history;
    1832                 :        160 :       max_enum = enum_history;
    1833                 :            :     }
    1834                 :            :   else
    1835                 :            :     {
    1836                 :        383 :       new_enum_history->next = enum_history;
    1837                 :        383 :       enum_history = new_enum_history;
    1838                 :            : 
    1839                 :        383 :       if (mpz_cmp (max_enum->initializer->value.integer,
    1840                 :        383 :                    new_enum_history->initializer->value.integer) < 0)
    1841                 :        381 :         max_enum = new_enum_history;
    1842                 :            :     }
    1843                 :        543 : }
    1844                 :            : 
    1845                 :            : 
    1846                 :            : /* Function to free enum kind history.  */
    1847                 :            : 
    1848                 :            : void
    1849                 :        175 : gfc_free_enum_history (void)
    1850                 :            : {
    1851                 :        175 :   enumerator_history *current = enum_history;
    1852                 :        718 :   enumerator_history *next;
    1853                 :            : 
    1854                 :        718 :   while (current != NULL)
    1855                 :            :     {
    1856                 :        543 :       next = current->next;
    1857                 :        543 :       free (current);
    1858                 :        543 :       current = next;
    1859                 :            :     }
    1860                 :        175 :   max_enum = NULL;
    1861                 :        175 :   enum_history = NULL;
    1862                 :        175 : }
    1863                 :            : 
    1864                 :            : 
    1865                 :            : /* Function called by variable_decl() that adds an initialization
    1866                 :            :    expression to a symbol.  */
    1867                 :            : 
    1868                 :            : static bool
    1869                 :     175931 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
    1870                 :            : {
    1871                 :     175931 :   symbol_attribute attr;
    1872                 :     175931 :   gfc_symbol *sym;
    1873                 :     175931 :   gfc_expr *init;
    1874                 :            : 
    1875                 :     175931 :   init = *initp;
    1876                 :     175931 :   if (find_special (name, &sym, false))
    1877                 :            :     return false;
    1878                 :            : 
    1879                 :     175931 :   attr = sym->attr;
    1880                 :            : 
    1881                 :            :   /* If this symbol is confirming an implicit parameter type,
    1882                 :            :      then an initialization expression is not allowed.  */
    1883                 :     175931 :   if (attr.flavor == FL_PARAMETER
    1884                 :      13968 :       && sym->value != NULL
    1885                 :          0 :       && *initp != NULL)
    1886                 :            :     {
    1887                 :          0 :       gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
    1888                 :            :                  sym->name);
    1889                 :          0 :       return false;
    1890                 :            :     }
    1891                 :            : 
    1892                 :     175931 :   if (init == NULL)
    1893                 :            :     {
    1894                 :            :       /* An initializer is required for PARAMETER declarations.  */
    1895                 :     156403 :       if (attr.flavor == FL_PARAMETER)
    1896                 :            :         {
    1897                 :          1 :           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
    1898                 :          1 :           return false;
    1899                 :            :         }
    1900                 :            :     }
    1901                 :            :   else
    1902                 :            :     {
    1903                 :            :       /* If a variable appears in a DATA block, it cannot have an
    1904                 :            :          initializer.  */
    1905                 :      19528 :       if (sym->attr.data)
    1906                 :            :         {
    1907                 :          0 :           gfc_error ("Variable %qs at %C with an initializer already "
    1908                 :            :                      "appears in a DATA statement", sym->name);
    1909                 :          0 :           return false;
    1910                 :            :         }
    1911                 :            : 
    1912                 :            :       /* Check if the assignment can happen. This has to be put off
    1913                 :            :          until later for derived type variables and procedure pointers.  */
    1914                 :      18779 :       if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
    1915                 :      18757 :           && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
    1916                 :      18705 :           && !sym->attr.proc_pointer
    1917                 :      38156 :           && !gfc_check_assign_symbol (sym, NULL, init))
    1918                 :            :         return false;
    1919                 :            : 
    1920                 :      19504 :       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
    1921                 :       2543 :             && init->ts.type == BT_CHARACTER)
    1922                 :            :         {
    1923                 :            :           /* Update symbol character length according initializer.  */
    1924                 :       2508 :           if (!gfc_check_assign_symbol (sym, NULL, init))
    1925                 :            :             return false;
    1926                 :            : 
    1927                 :       2508 :           if (sym->ts.u.cl->length == NULL)
    1928                 :            :             {
    1929                 :        631 :               gfc_charlen_t clen;
    1930                 :            :               /* If there are multiple CHARACTER variables declared on the
    1931                 :            :                  same line, we don't want them to share the same length.  */
    1932                 :        631 :               sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    1933                 :            : 
    1934                 :        631 :               if (sym->attr.flavor == FL_PARAMETER)
    1935                 :            :                 {
    1936                 :        622 :                   if (init->expr_type == EXPR_CONSTANT)
    1937                 :            :                     {
    1938                 :        439 :                       clen = init->value.character.length;
    1939                 :        439 :                       sym->ts.u.cl->length
    1940                 :        439 :                                 = gfc_get_int_expr (gfc_charlen_int_kind,
    1941                 :            :                                                     NULL, clen);
    1942                 :            :                     }
    1943                 :        183 :                   else if (init->expr_type == EXPR_ARRAY)
    1944                 :            :                     {
    1945                 :        183 :                       if (init->ts.u.cl && init->ts.u.cl->length)
    1946                 :            :                         {
    1947                 :        171 :                           const gfc_expr *length = init->ts.u.cl->length;
    1948                 :        171 :                           if (length->expr_type != EXPR_CONSTANT)
    1949                 :            :                             {
    1950                 :          1 :                               gfc_error ("Cannot initialize parameter array "
    1951                 :            :                                          "at %L "
    1952                 :            :                                          "with variable length elements",
    1953                 :            :                                          &sym->declared_at);
    1954                 :          1 :                               return false;
    1955                 :            :                             }
    1956                 :        170 :                           clen = mpz_get_si (length->value.integer);
    1957                 :            :                         }
    1958                 :         12 :                       else if (init->value.constructor)
    1959                 :            :                         {
    1960                 :         12 :                           gfc_constructor *c;
    1961                 :         12 :                           c = gfc_constructor_first (init->value.constructor);
    1962                 :         12 :                           clen = c->expr->value.character.length;
    1963                 :            :                         }
    1964                 :            :                       else
    1965                 :          0 :                           gcc_unreachable ();
    1966                 :        182 :                       sym->ts.u.cl->length
    1967                 :        182 :                                 = gfc_get_int_expr (gfc_charlen_int_kind,
    1968                 :            :                                                     NULL, clen);
    1969                 :            :                     }
    1970                 :          0 :                   else if (init->ts.u.cl && init->ts.u.cl->length)
    1971                 :          0 :                     sym->ts.u.cl->length =
    1972                 :          0 :                                 gfc_copy_expr (init->ts.u.cl->length);
    1973                 :            :                 }
    1974                 :            :             }
    1975                 :            :           /* Update initializer character length according symbol.  */
    1976                 :       1877 :           else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    1977                 :            :             {
    1978                 :       1877 :               if (!gfc_specification_expr (sym->ts.u.cl->length))
    1979                 :            :                 return false;
    1980                 :            : 
    1981                 :       1877 :               int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
    1982                 :            :                                          false);
    1983                 :            :               /* resolve_charlen will complain later on if the length
    1984                 :            :                  is too large.  Just skeep the initialization in that case.  */
    1985                 :       1877 :               if (mpz_cmp (sym->ts.u.cl->length->value.integer,
    1986                 :       1877 :                            gfc_integer_kinds[k].huge) <= 0)
    1987                 :            :                 {
    1988                 :       1876 :                   HOST_WIDE_INT len
    1989                 :       1876 :                     = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);
    1990                 :            : 
    1991                 :       1876 :                   if (init->expr_type == EXPR_CONSTANT)
    1992                 :       1374 :                     gfc_set_constant_character_len (len, init, -1);
    1993                 :        502 :                   else if (init->expr_type == EXPR_ARRAY)
    1994                 :            :                     {
    1995                 :        502 :                       gfc_constructor *c;
    1996                 :            : 
    1997                 :            :                       /* Build a new charlen to prevent simplification from
    1998                 :            :                          deleting the length before it is resolved.  */
    1999                 :        502 :                       init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    2000                 :        502 :                       init->ts.u.cl->length
    2001                 :        502 :                         = gfc_copy_expr (sym->ts.u.cl->length);
    2002                 :            : 
    2003                 :        502 :                       for (c = gfc_constructor_first (init->value.constructor);
    2004                 :       5676 :                            c; c = gfc_constructor_next (c))
    2005                 :       2587 :                         gfc_set_constant_character_len (len, c->expr, -1);
    2006                 :            :                     }
    2007                 :            :                 }
    2008                 :            :             }
    2009                 :            :         }
    2010                 :            : 
    2011                 :            :       /* If sym is implied-shape, set its upper bounds from init.  */
    2012                 :      19503 :       if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
    2013                 :       2164 :           && sym->as->type == AS_IMPLIED_SHAPE)
    2014                 :            :         {
    2015                 :        146 :           int dim;
    2016                 :            : 
    2017                 :        146 :           if (init->rank == 0)
    2018                 :            :             {
    2019                 :          1 :               gfc_error ("Cannot initialize implied-shape array at %L"
    2020                 :            :                          " with scalar", &sym->declared_at);
    2021                 :          1 :               return false;
    2022                 :            :             }
    2023                 :            : 
    2024                 :            :           /* The shape may be NULL for EXPR_ARRAY, set it.  */
    2025                 :        145 :           if (init->shape == NULL)
    2026                 :            :             {
    2027                 :          1 :               gcc_assert (init->expr_type == EXPR_ARRAY);
    2028                 :          1 :               init->shape = gfc_get_shape (1);
    2029                 :          1 :               if (!gfc_array_size (init, &init->shape[0]))
    2030                 :          0 :                   gfc_internal_error ("gfc_array_size failed");
    2031                 :            :             }
    2032                 :            : 
    2033                 :        367 :           for (dim = 0; dim < sym->as->rank; ++dim)
    2034                 :            :             {
    2035                 :        223 :               int k;
    2036                 :        223 :               gfc_expr *e, *lower;
    2037                 :            : 
    2038                 :        223 :               lower = sym->as->lower[dim];
    2039                 :            : 
    2040                 :            :               /* If the lower bound is an array element from another
    2041                 :            :                  parameterized array, then it is marked with EXPR_VARIABLE and
    2042                 :            :                  is an initialization expression.  Try to reduce it.  */
    2043                 :        223 :               if (lower->expr_type == EXPR_VARIABLE)
    2044                 :          7 :                 gfc_reduce_init_expr (lower);
    2045                 :            : 
    2046                 :        223 :               if (lower->expr_type == EXPR_CONSTANT)
    2047                 :            :                 {
    2048                 :            :                   /* All dimensions must be without upper bound.  */
    2049                 :        222 :                   gcc_assert (!sym->as->upper[dim]);
    2050                 :            : 
    2051                 :        222 :                   k = lower->ts.kind;
    2052                 :        222 :                   e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
    2053                 :        222 :                   mpz_add (e->value.integer, lower->value.integer,
    2054                 :        222 :                            init->shape[dim]);
    2055                 :        222 :                   mpz_sub_ui (e->value.integer, e->value.integer, 1);
    2056                 :        222 :                   sym->as->upper[dim] = e;
    2057                 :            :                 }
    2058                 :            :               else
    2059                 :            :                 {
    2060                 :          1 :                   gfc_error ("Non-constant lower bound in implied-shape"
    2061                 :            :                              " declaration at %L", &lower->where);
    2062                 :          1 :                   return false;
    2063                 :            :                 }
    2064                 :            :             }
    2065                 :            : 
    2066                 :        144 :           sym->as->type = AS_EXPLICIT;
    2067                 :            :         }
    2068                 :            : 
    2069                 :            :       /* Need to check if the expression we initialized this
    2070                 :            :          to was one of the iso_c_binding named constants.  If so,
    2071                 :            :          and we're a parameter (constant), let it be iso_c.
    2072                 :            :          For example:
    2073                 :            :          integer(c_int), parameter :: my_int = c_int
    2074                 :            :          integer(my_int) :: my_int_2
    2075                 :            :          If we mark my_int as iso_c (since we can see it's value
    2076                 :            :          is equal to one of the named constants), then my_int_2
    2077                 :            :          will be considered C interoperable.  */
    2078                 :      19501 :       if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
    2079                 :            :         {
    2080                 :      16210 :           sym->ts.is_iso_c |= init->ts.is_iso_c;
    2081                 :      16210 :           sym->ts.is_c_interop |= init->ts.is_c_interop;
    2082                 :            :           /* attr bits needed for module files.  */
    2083                 :      16210 :           sym->attr.is_iso_c |= init->ts.is_iso_c;
    2084                 :      16210 :           sym->attr.is_c_interop |= init->ts.is_c_interop;
    2085                 :      16210 :           if (init->ts.is_iso_c)
    2086                 :         17 :             sym->ts.f90_type = init->ts.f90_type;
    2087                 :            :         }
    2088                 :            : 
    2089                 :            :       /* Add initializer.  Make sure we keep the ranks sane.  */
    2090                 :      19501 :       if (sym->attr.dimension && init->rank == 0)
    2091                 :            :         {
    2092                 :        806 :           mpz_t size;
    2093                 :        806 :           gfc_expr *array;
    2094                 :        806 :           int n;
    2095                 :        806 :           if (sym->attr.flavor == FL_PARAMETER
    2096                 :        315 :                 && init->expr_type == EXPR_CONSTANT
    2097                 :        313 :                 && spec_size (sym->as, &size)
    2098                 :       1116 :                 && mpz_cmp_si (size, 0) > 0)
    2099                 :            :             {
    2100                 :        200 :               array = gfc_get_array_expr (init->ts.type, init->ts.kind,
    2101                 :            :                                           &init->where);
    2102                 :      66876 :               for (n = 0; n < (int)mpz_get_si (size); n++)
    2103                 :     133152 :                 gfc_constructor_append_expr (&array->value.constructor,
    2104                 :            :                                              n == 0
    2105                 :            :                                                 ? init
    2106                 :      66476 :                                                 : gfc_copy_expr (init),
    2107                 :            :                                              &init->where);
    2108                 :            : 
    2109                 :        200 :               array->shape = gfc_get_shape (sym->as->rank);
    2110                 :        474 :               for (n = 0; n < sym->as->rank; n++)
    2111                 :        274 :                 spec_dimen_size (sym->as, n, &array->shape[n]);
    2112                 :            : 
    2113                 :        200 :               init = array;
    2114                 :        200 :               mpz_clear (size);
    2115                 :            :             }
    2116                 :        806 :           init->rank = sym->as->rank;
    2117                 :            :         }
    2118                 :            : 
    2119                 :      19501 :       sym->value = init;
    2120                 :      19501 :       if (sym->attr.save == SAVE_NONE)
    2121                 :      16929 :         sym->attr.save = SAVE_IMPLICIT;
    2122                 :      19501 :       *initp = NULL;
    2123                 :            :     }
    2124                 :            : 
    2125                 :            :   return true;
    2126                 :            : }
    2127                 :            : 
    2128                 :            : 
    2129                 :            : /* Function called by variable_decl() that adds a name to a structure
    2130                 :            :    being built.  */
    2131                 :            : 
    2132                 :            : static bool
    2133                 :      13206 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
    2134                 :            :               gfc_array_spec **as)
    2135                 :            : {
    2136                 :      13206 :   gfc_state_data *s;
    2137                 :      13206 :   gfc_component *c;
    2138                 :            : 
    2139                 :            :   /* F03:C438/C439. If the current symbol is of the same derived type that we're
    2140                 :            :      constructing, it must have the pointer attribute.  */
    2141                 :      13206 :   if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
    2142                 :       2489 :       && current_ts.u.derived == gfc_current_block ()
    2143                 :        199 :       && current_attr.pointer == 0)
    2144                 :            :     {
    2145                 :         40 :       if (current_attr.allocatable
    2146                 :         40 :           && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
    2147                 :         40 :                              "must have the POINTER attribute"))
    2148                 :            :         {
    2149                 :            :           return false;
    2150                 :            :         }
    2151                 :         39 :       else if (current_attr.allocatable == 0)
    2152                 :            :         {
    2153                 :          0 :           gfc_error ("Component at %C must have the POINTER attribute");
    2154                 :          0 :           return false;
    2155                 :            :         }
    2156                 :            :     }
    2157                 :            : 
    2158                 :            :   /* F03:C437.  */
    2159                 :      13205 :   if (current_ts.type == BT_CLASS
    2160                 :        606 :       && !(current_attr.pointer || current_attr.allocatable))
    2161                 :            :     {
    2162                 :          5 :       gfc_error ("Component %qs with CLASS at %C must be allocatable "
    2163                 :            :                  "or pointer", name);
    2164                 :          5 :       return false;
    2165                 :            :     }
    2166                 :            : 
    2167                 :      13200 :   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
    2168                 :            :     {
    2169                 :          0 :       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
    2170                 :            :         {
    2171                 :          0 :           gfc_error ("Array component of structure at %C must have explicit "
    2172                 :            :                      "or deferred shape");
    2173                 :          0 :           return false;
    2174                 :            :         }
    2175                 :            :     }
    2176                 :            : 
    2177                 :            :   /* If we are in a nested union/map definition, gfc_add_component will not
    2178                 :            :      properly find repeated components because:
    2179                 :            :        (i) gfc_add_component does a flat search, where components of unions
    2180                 :            :            and maps are implicity chained so nested components may conflict.
    2181                 :            :       (ii) Unions and maps are not linked as components of their parent
    2182                 :            :            structures until after they are parsed.
    2183                 :            :      For (i) we use gfc_find_component which searches recursively, and for (ii)
    2184                 :            :      we search each block directly from the parse stack until we find the top
    2185                 :            :      level structure.  */
    2186                 :            : 
    2187                 :      13200 :   s = gfc_state_stack;
    2188                 :      13200 :   if (s->state == COMP_UNION || s->state == COMP_MAP)
    2189                 :            :     {
    2190                 :       1434 :       while (s->state == COMP_UNION || gfc_comp_struct (s->state))
    2191                 :            :         {
    2192                 :       1434 :           c = gfc_find_component (s->sym, name, true, true, NULL);
    2193                 :       1434 :           if (c != NULL)
    2194                 :            :             {
    2195                 :          0 :               gfc_error_now ("Component %qs at %C already declared at %L",
    2196                 :            :                              name, &c->loc);
    2197                 :          0 :               return false;
    2198                 :            :             }
    2199                 :            :           /* Break after we've searched the entire chain.  */
    2200                 :       1434 :           if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
    2201                 :            :             break;
    2202                 :       1000 :           s = s->previous;
    2203                 :            :         }
    2204                 :            :     }
    2205                 :            : 
    2206                 :      13200 :   if (!gfc_add_component (gfc_current_block(), name, &c))
    2207                 :            :     return false;
    2208                 :            : 
    2209                 :      13194 :   c->ts = current_ts;
    2210                 :      13194 :   if (c->ts.type == BT_CHARACTER)
    2211                 :       1450 :     c->ts.u.cl = cl;
    2212                 :            : 
    2213                 :      13194 :   if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
    2214                 :      10711 :       && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
    2215                 :       1525 :       && saved_kind_expr != NULL)
    2216                 :         87 :     c->kind_expr = gfc_copy_expr (saved_kind_expr);
    2217                 :            : 
    2218                 :      13194 :   c->attr = current_attr;
    2219                 :            : 
    2220                 :      13194 :   c->initializer = *init;
    2221                 :      13194 :   *init = NULL;
    2222                 :            : 
    2223                 :      13194 :   c->as = *as;
    2224                 :      13194 :   if (c->as != NULL)
    2225                 :            :     {
    2226                 :       3287 :       if (c->as->corank)
    2227                 :         87 :         c->attr.codimension = 1;
    2228                 :       3287 :       if (c->as->rank)
    2229                 :       3222 :         c->attr.dimension = 1;
    2230                 :            :     }
    2231                 :      13194 :   *as = NULL;
    2232                 :            : 
    2233                 :      13194 :   gfc_apply_init (&c->ts, &c->attr, c->initializer);
    2234                 :            : 
    2235                 :            :   /* Check array components.  */
    2236                 :      13194 :   if (!c->attr.dimension)
    2237                 :       9972 :     goto scalar;
    2238                 :            : 
    2239                 :       3222 :   if (c->attr.pointer)
    2240                 :            :     {
    2241                 :        435 :       if (c->as->type != AS_DEFERRED)
    2242                 :            :         {
    2243                 :          2 :           gfc_error ("Pointer array component of structure at %C must have a "
    2244                 :            :                      "deferred shape");
    2245                 :          2 :           return false;
    2246                 :            :         }
    2247                 :            :     }
    2248                 :       2787 :   else if (c->attr.allocatable)
    2249                 :            :     {
    2250                 :       1592 :       if (c->as->type != AS_DEFERRED)
    2251                 :            :         {
    2252                 :         10 :           gfc_error ("Allocatable component of structure at %C must have a "
    2253                 :            :                      "deferred shape");
    2254                 :         10 :           return false;
    2255                 :            :         }
    2256                 :            :     }
    2257                 :            :   else
    2258                 :            :     {
    2259                 :       1195 :       if (c->as->type != AS_EXPLICIT)
    2260                 :            :         {
    2261                 :          1 :           gfc_error ("Array component of structure at %C must have an "
    2262                 :            :                      "explicit shape");
    2263                 :          1 :           return false;
    2264                 :            :         }
    2265                 :            :     }
    2266                 :            : 
    2267                 :       1194 : scalar:
    2268                 :      13181 :   if (c->ts.type == BT_CLASS)
    2269                 :        597 :     return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
    2270                 :            : 
    2271                 :      12584 :   if (c->attr.pdt_kind || c->attr.pdt_len)
    2272                 :            :     {
    2273                 :        266 :       gfc_symbol *sym;
    2274                 :        266 :       gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
    2275                 :            :                        0, &sym);
    2276                 :        266 :       if (sym == NULL)
    2277                 :            :         {
    2278                 :          0 :           gfc_error ("Type parameter %qs at %C has no corresponding entry "
    2279                 :            :                      "in the type parameter name list at %L",
    2280                 :          0 :                      c->name, &gfc_current_block ()->declared_at);
    2281                 :          0 :           return false;
    2282                 :            :         }
    2283                 :        266 :       sym->ts = c->ts;
    2284                 :        266 :       sym->attr.pdt_kind = c->attr.pdt_kind;
    2285                 :        266 :       sym->attr.pdt_len = c->attr.pdt_len;
    2286                 :        266 :       if (c->initializer)
    2287                 :        101 :         sym->value = gfc_copy_expr (c->initializer);
    2288                 :        266 :       sym->attr.flavor = FL_VARIABLE;
    2289                 :            :     }
    2290                 :            : 
    2291                 :      12584 :   if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
    2292                 :       1882 :       && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
    2293                 :         39 :       && decl_type_param_list)
    2294                 :         39 :     c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
    2295                 :            : 
    2296                 :            :   return true;
    2297                 :            : }
    2298                 :            : 
    2299                 :            : 
    2300                 :            : /* Match a 'NULL()', and possibly take care of some side effects.  */
    2301                 :            : 
    2302                 :            : match
    2303                 :       1225 : gfc_match_null (gfc_expr **result)
    2304                 :            : {
    2305                 :       1225 :   gfc_symbol *sym;
    2306                 :       1225 :   match m, m2 = MATCH_NO;
    2307                 :            : 
    2308                 :       1225 :   if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
    2309                 :            :     return MATCH_ERROR;
    2310                 :            : 
    2311                 :       1225 :   if (m == MATCH_NO)
    2312                 :            :     {
    2313                 :        446 :       locus old_loc;
    2314                 :        446 :       char name[GFC_MAX_SYMBOL_LEN + 1];
    2315                 :            : 
    2316                 :        446 :       if ((m2 = gfc_match (" null (")) != MATCH_YES)
    2317                 :        440 :         return m2;
    2318                 :            : 
    2319                 :          6 :       old_loc = gfc_current_locus;
    2320                 :          6 :       if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
    2321                 :            :         return MATCH_ERROR;
    2322                 :          6 :       if (m2 != MATCH_YES
    2323                 :          6 :           && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
    2324                 :            :         return MATCH_ERROR;
    2325                 :          6 :       if (m2 == MATCH_NO)
    2326                 :            :         {
    2327                 :          0 :           gfc_current_locus = old_loc;
    2328                 :          0 :           return MATCH_NO;
    2329                 :            :         }
    2330                 :            :     }
    2331                 :            : 
    2332                 :            :   /* The NULL symbol now has to be/become an intrinsic function.  */
    2333                 :        785 :   if (gfc_get_symbol ("null", NULL, &sym))
    2334                 :            :     {
    2335                 :          0 :       gfc_error ("NULL() initialization at %C is ambiguous");
    2336                 :          0 :       return MATCH_ERROR;
    2337                 :            :     }
    2338                 :            : 
    2339                 :        785 :   gfc_intrinsic_symbol (sym);
    2340                 :            : 
    2341                 :        785 :   if (sym->attr.proc != PROC_INTRINSIC
    2342                 :        544 :       && !(sym->attr.use_assoc && sym->attr.intrinsic)
    2343                 :       1328 :       && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
    2344                 :        543 :           || !gfc_add_function (&sym->attr, sym->name, NULL)))
    2345                 :          0 :     return MATCH_ERROR;
    2346                 :            : 
    2347                 :        785 :   *result = gfc_get_null_expr (&gfc_current_locus);
    2348                 :            : 
    2349                 :            :   /* Invalid per F2008, C512.  */
    2350                 :        785 :   if (m2 == MATCH_YES)
    2351                 :            :     {
    2352                 :          6 :       gfc_error ("NULL() initialization at %C may not have MOLD");
    2353                 :          6 :       return MATCH_ERROR;
    2354                 :            :     }
    2355                 :            : 
    2356                 :            :   return MATCH_YES;
    2357                 :            : }
    2358                 :            : 
    2359                 :            : 
    2360                 :            : /* Match the initialization expr for a data pointer or procedure pointer.  */
    2361                 :            : 
    2362                 :            : static match
    2363                 :        931 : match_pointer_init (gfc_expr **init, int procptr)
    2364                 :            : {
    2365                 :        931 :   match m;
    2366                 :            : 
    2367                 :        931 :   if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
    2368                 :            :     {
    2369                 :          1 :       gfc_error ("Initialization of pointer at %C is not allowed in "
    2370                 :            :                  "a PURE procedure");
    2371                 :          1 :       return MATCH_ERROR;
    2372                 :            :     }
    2373                 :        930 :   gfc_unset_implicit_pure (gfc_current_ns->proc_name);
    2374                 :            : 
    2375                 :            :   /* Match NULL() initialization.  */
    2376                 :        930 :   m = gfc_match_null (init);
    2377                 :        930 :   if (m != MATCH_NO)
    2378                 :            :     return m;
    2379                 :            : 
    2380                 :            :   /* Match non-NULL initialization.  */
    2381                 :        152 :   gfc_matching_ptr_assignment = !procptr;
    2382                 :        152 :   gfc_matching_procptr_assignment = procptr;
    2383                 :        152 :   m = gfc_match_rvalue (init);
    2384                 :        152 :   gfc_matching_ptr_assignment = 0;
    2385                 :        152 :   gfc_matching_procptr_assignment = 0;
    2386                 :        152 :   if (m == MATCH_ERROR)
    2387                 :            :     return MATCH_ERROR;
    2388                 :        151 :   else if (m == MATCH_NO)
    2389                 :            :     {
    2390                 :          2 :       gfc_error ("Error in pointer initialization at %C");
    2391                 :          2 :       return MATCH_ERROR;
    2392                 :            :     }
    2393                 :            : 
    2394                 :        149 :   if (!procptr && !gfc_resolve_expr (*init))
    2395                 :            :     return MATCH_ERROR;
    2396                 :            : 
    2397                 :        148 :   if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
    2398                 :            :                        "initialization at %C"))
    2399                 :          0 :     return MATCH_ERROR;
    2400                 :            : 
    2401                 :            :   return MATCH_YES;
    2402                 :            : }
    2403                 :            : 
    2404                 :            : 
    2405                 :            : static bool
    2406                 :     193319 : check_function_name (char *name)
    2407                 :            : {
    2408                 :            :   /* In functions that have a RESULT variable defined, the function name always
    2409                 :            :      refers to function calls.  Therefore, the name is not allowed to appear in
    2410                 :            :      specification statements. When checking this, be careful about
    2411                 :            :      'hidden' procedure pointer results ('ppr@').  */
    2412                 :            : 
    2413                 :     193319 :   if (gfc_current_state () == COMP_FUNCTION)
    2414                 :            :     {
    2415                 :      26843 :       gfc_symbol *block = gfc_current_block ();
    2416                 :      26843 :       if (block && block->result && block->result != block
    2417                 :       8951 :           && strcmp (block->result->name, "ppr@") != 0
    2418                 :       8894 :           && strcmp (block->name, name) == 0)
    2419                 :            :         {
    2420                 :          9 :           gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
    2421                 :            :                      "from appearing in a specification statement",
    2422                 :            :                      block->result->name, &block->result->declared_at, name);
    2423                 :          9 :           return false;
    2424                 :            :         }
    2425                 :            :     }
    2426                 :            : 
    2427                 :            :   return true;
    2428                 :            : }
    2429                 :            : 
    2430                 :            : 
    2431                 :            : /* Match a variable name with an optional initializer.  When this
    2432                 :            :    subroutine is called, a variable is expected to be parsed next.
    2433                 :            :    Depending on what is happening at the moment, updates either the
    2434                 :            :    symbol table or the current interface.  */
    2435                 :            : 
    2436                 :            : static match
    2437                 :     186283 : variable_decl (int elem)
    2438                 :            : {
    2439                 :     186283 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    2440                 :     186283 :   static unsigned int fill_id = 0;
    2441                 :     186283 :   gfc_expr *initializer, *char_len;
    2442                 :     186283 :   gfc_array_spec *as;
    2443                 :     186283 :   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
    2444                 :     186283 :   gfc_charlen *cl;
    2445                 :     186283 :   bool cl_deferred;
    2446                 :     186283 :   locus var_locus;
    2447                 :     186283 :   match m;
    2448                 :     186283 :   bool t;
    2449                 :     186283 :   gfc_symbol *sym;
    2450                 :     186283 :   char c;
    2451                 :            : 
    2452                 :     186283 :   initializer = NULL;
    2453                 :     186283 :   as = NULL;
    2454                 :     186283 :   cp_as = NULL;
    2455                 :            : 
    2456                 :            :   /* When we get here, we've just matched a list of attributes and
    2457                 :            :      maybe a type and a double colon.  The next thing we expect to see
    2458                 :            :      is the name of the symbol.  */
    2459                 :            : 
    2460                 :            :   /* If we are parsing a structure with legacy support, we allow the symbol
    2461                 :            :      name to be '%FILL' which gives it an anonymous (inaccessible) name.  */
    2462                 :     186283 :   m = MATCH_NO;
    2463                 :     186283 :   gfc_gobble_whitespace ();
    2464                 :     186283 :   c = gfc_peek_ascii_char ();
    2465                 :     186283 :   if (c == '%')
    2466                 :            :     {
    2467                 :         12 :       gfc_next_ascii_char ();   /* Burn % character.  */
    2468                 :         12 :       m = gfc_match ("fill");
    2469                 :         12 :       if (m == MATCH_YES)
    2470                 :            :         {
    2471                 :         11 :           if (gfc_current_state () != COMP_STRUCTURE)
    2472                 :            :             {
    2473                 :          2 :               if (flag_dec_structure)
    2474                 :          1 :                 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
    2475                 :            :               else
    2476                 :          1 :                 gfc_error ("%qs at %C is a DEC extension, enable with "
    2477                 :            :                        "%<-fdec-structure%>", "%FILL");
    2478                 :          2 :               m = MATCH_ERROR;
    2479                 :          2 :               goto cleanup;
    2480                 :            :             }
    2481                 :            : 
    2482                 :          9 :           if (attr_seen)
    2483                 :            :             {
    2484                 :          1 :               gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
    2485                 :          1 :               m = MATCH_ERROR;
    2486                 :          1 :               goto cleanup;
    2487                 :            :             }
    2488                 :            : 
    2489                 :            :           /* %FILL components are given invalid fortran names.  */
    2490                 :          8 :           snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
    2491                 :            :         }
    2492                 :            :       else
    2493                 :            :         {
    2494                 :          1 :           gfc_error ("Invalid character %qc in variable name at %C", c);
    2495                 :          1 :           return MATCH_ERROR;
    2496                 :            :         }
    2497                 :            :     }
    2498                 :            :   else
    2499                 :            :     {
    2500                 :     186271 :       m = gfc_match_name (name);
    2501                 :     186270 :       if (m != MATCH_YES)
    2502                 :         12 :         goto cleanup;
    2503                 :            :     }
    2504                 :            : 
    2505                 :     186266 :   var_locus = gfc_current_locus;
    2506                 :            : 
    2507                 :            :   /* Now we could see the optional array spec. or character length.  */
    2508                 :     186266 :   m = gfc_match_array_spec (&as, true, true);
    2509                 :     186265 :   if (m == MATCH_ERROR)
    2510                 :         25 :     goto cleanup;
    2511                 :            : 
    2512                 :     186240 :   if (m == MATCH_NO)
    2513                 :     151880 :     as = gfc_copy_array_spec (current_as);
    2514                 :      34360 :   else if (current_as
    2515                 :      34360 :            && !merge_array_spec (current_as, as, true))
    2516                 :            :     {
    2517                 :          3 :       m = MATCH_ERROR;
    2518                 :          3 :       goto cleanup;
    2519                 :            :     }
    2520                 :            : 
    2521                 :     186237 :   if (flag_cray_pointer)
    2522                 :       3027 :     cp_as = gfc_copy_array_spec (as);
    2523                 :            : 
    2524                 :            :   /* At this point, we know for sure if the symbol is PARAMETER and can thus
    2525                 :            :      determine (and check) whether it can be implied-shape.  If it
    2526                 :            :      was parsed as assumed-size, change it because PARAMETERs cannot
    2527                 :            :      be assumed-size.
    2528                 :            : 
    2529                 :            :      An explicit-shape-array cannot appear under several conditions.
    2530                 :            :      That check is done here as well.  */
    2531                 :     186237 :   if (as)
    2532                 :            :     {
    2533                 :      53592 :       if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
    2534                 :            :         {
    2535                 :          2 :           m = MATCH_ERROR;
    2536                 :          2 :           gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
    2537                 :            :                      name, &var_locus);
    2538                 :          2 :           goto cleanup;
    2539                 :            :         }
    2540                 :            : 
    2541                 :      53590 :       if (as->type == AS_ASSUMED_SIZE && as->rank == 1
    2542                 :       3279 :           && current_attr.flavor == FL_PARAMETER)
    2543                 :        106 :         as->type = AS_IMPLIED_SHAPE;
    2544                 :            : 
    2545                 :      53590 :       if (as->type == AS_IMPLIED_SHAPE
    2546                 :      53590 :           && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
    2547                 :            :                               &var_locus))
    2548                 :            :         {
    2549                 :          1 :           m = MATCH_ERROR;
    2550                 :          1 :           goto cleanup;
    2551                 :            :         }
    2552                 :            : 
    2553                 :      53589 :       gfc_seen_div0 = false;
    2554                 :            :       
    2555                 :            :       /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
    2556                 :            :          constant expressions shall appear only in a subprogram, derived
    2557                 :            :          type definition, BLOCK construct, or interface body.  */
    2558                 :      53589 :       if (as->type == AS_EXPLICIT
    2559                 :      31180 :           && gfc_current_state () != COMP_BLOCK
    2560                 :      31044 :           && gfc_current_state () != COMP_DERIVED
    2561                 :      29937 :           && gfc_current_state () != COMP_FUNCTION
    2562                 :      27838 :           && gfc_current_state () != COMP_INTERFACE
    2563                 :      27838 :           && gfc_current_state () != COMP_SUBROUTINE)
    2564                 :            :         {
    2565                 :            :           gfc_expr *e;
    2566                 :      39772 :           bool not_constant = false;
    2567                 :            : 
    2568                 :      39772 :           for (int i = 0; i < as->rank; i++)
    2569                 :            :             {
    2570                 :      22746 :               e = gfc_copy_expr (as->lower[i]);
    2571                 :      22746 :               if (!gfc_resolve_expr (e) && gfc_seen_div0)
    2572                 :            :                 {
    2573                 :          0 :                   m = MATCH_ERROR;
    2574                 :          0 :                   goto cleanup;
    2575                 :            :                 }
    2576                 :            : 
    2577                 :      22746 :               gfc_simplify_expr (e, 0);
    2578                 :      22746 :               if (e && (e->expr_type != EXPR_CONSTANT))
    2579                 :            :                 {
    2580                 :            :                   not_constant = true;
    2581                 :            :                   break;
    2582                 :            :                 }
    2583                 :      22746 :               gfc_free_expr (e);
    2584                 :            : 
    2585                 :      22746 :               e = gfc_copy_expr (as->upper[i]);
    2586                 :      22746 :               if (!gfc_resolve_expr (e)  && gfc_seen_div0)
    2587                 :            :                 {
    2588                 :          3 :                   m = MATCH_ERROR;
    2589                 :          3 :                   goto cleanup;
    2590                 :            :                 }
    2591                 :            : 
    2592                 :      22743 :               gfc_simplify_expr (e, 0);
    2593                 :      22743 :               if (e && (e->expr_type != EXPR_CONSTANT))
    2594                 :            :                 {
    2595                 :            :                   not_constant = true;
    2596                 :            :                   break;
    2597                 :            :                 }
    2598                 :      22732 :               gfc_free_expr (e);
    2599                 :            :             }
    2600                 :            : 
    2601                 :      17037 :           if (not_constant)
    2602                 :            :             {
    2603                 :         11 :               gfc_error ("Explicit shaped array with nonconstant bounds at %C");
    2604                 :         11 :               m = MATCH_ERROR;
    2605                 :         11 :               goto cleanup;
    2606                 :            :             }
    2607                 :            :         }
    2608                 :      53575 :       if (as->type == AS_EXPLICIT)
    2609                 :            :         {
    2610                 :      73094 :           for (int i = 0; i < as->rank; i++)
    2611                 :            :             {
    2612                 :      41928 :               gfc_expr *e, *n;
    2613                 :      41928 :               e = as->lower[i];
    2614                 :      41928 :               if (e->expr_type != EXPR_CONSTANT)
    2615                 :            :                 {
    2616                 :        286 :                   n = gfc_copy_expr (e);
    2617                 :        286 :                   if (!gfc_simplify_expr (n, 1)  && gfc_seen_div0) 
    2618                 :            :                     {
    2619                 :          0 :                       m = MATCH_ERROR;
    2620                 :          0 :                       goto cleanup;
    2621                 :            :                     }
    2622                 :            : 
    2623                 :        286 :                   if (n->expr_type == EXPR_CONSTANT)
    2624                 :          4 :                     gfc_replace_expr (e, n);
    2625                 :            :                   else
    2626                 :        282 :                     gfc_free_expr (n);
    2627                 :            :                 }
    2628                 :      41928 :               e = as->upper[i];
    2629                 :      41928 :               if (e->expr_type != EXPR_CONSTANT)
    2630                 :            :                 {
    2631                 :       5237 :                   n = gfc_copy_expr (e);
    2632                 :       5237 :                   if (!gfc_simplify_expr (n, 1)  && gfc_seen_div0) 
    2633                 :            :                     {
    2634                 :          0 :                       m = MATCH_ERROR;
    2635                 :          0 :                       goto cleanup;
    2636                 :            :                     }
    2637                 :            :                   
    2638                 :       5237 :                   if (n->expr_type == EXPR_CONSTANT)
    2639                 :         21 :                     gfc_replace_expr (e, n);
    2640                 :            :                   else
    2641                 :       5216 :                     gfc_free_expr (n);
    2642                 :            :                 }
    2643                 :            :             }
    2644                 :            :         }
    2645                 :            :     }
    2646                 :            : 
    2647                 :     186220 :   char_len = NULL;
    2648                 :     186220 :   cl = NULL;
    2649                 :     186220 :   cl_deferred = false;
    2650                 :            : 
    2651                 :     186220 :   if (current_ts.type == BT_CHARACTER)
    2652                 :            :     {
    2653                 :      22301 :       switch (match_char_length (&char_len, &cl_deferred, false))
    2654                 :            :         {
    2655                 :        435 :         case MATCH_YES:
    2656                 :        435 :           cl = gfc_new_charlen (gfc_current_ns, NULL);
    2657                 :            : 
    2658                 :        435 :           cl->length = char_len;
    2659                 :        435 :           break;
    2660                 :            : 
    2661                 :            :         /* Non-constant lengths need to be copied after the first
    2662                 :            :            element.  Also copy assumed lengths.  */
    2663                 :      21865 :         case MATCH_NO:
    2664                 :      21865 :           if (elem > 1
    2665                 :       2610 :               && (current_ts.u.cl->length == NULL
    2666                 :       2004 :                   || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
    2667                 :            :             {
    2668                 :        631 :               cl = gfc_new_charlen (gfc_current_ns, NULL);
    2669                 :        631 :               cl->length = gfc_copy_expr (current_ts.u.cl->length);
    2670                 :            :             }
    2671                 :            :           else
    2672                 :      21234 :             cl = current_ts.u.cl;
    2673                 :            : 
    2674                 :      21865 :           cl_deferred = current_ts.deferred;
    2675                 :            : 
    2676                 :      21865 :           break;
    2677                 :            : 
    2678                 :          1 :         case MATCH_ERROR:
    2679                 :          1 :           goto cleanup;
    2680                 :            :         }
    2681                 :            :     }
    2682                 :            : 
    2683                 :            :   /* The dummy arguments and result of the abreviated form of MODULE
    2684                 :            :      PROCEDUREs, used in SUBMODULES should not be redefined.  */
    2685                 :     186219 :   if (gfc_current_ns->proc_name
    2686                 :     181864 :       && gfc_current_ns->proc_name->abr_modproc_decl)
    2687                 :            :     {
    2688                 :         34 :       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
    2689                 :         34 :       if (sym != NULL && (sym->attr.dummy || sym->attr.result))
    2690                 :            :         {
    2691                 :          2 :           m = MATCH_ERROR;
    2692                 :          2 :           gfc_error ("%qs at %C is a redefinition of the declaration "
    2693                 :            :                      "in the corresponding interface for MODULE "
    2694                 :            :                      "PROCEDURE %qs", sym->name,
    2695                 :          2 :                      gfc_current_ns->proc_name->name);
    2696                 :          2 :           goto cleanup;
    2697                 :            :         }
    2698                 :            :     }
    2699                 :            : 
    2700                 :            :   /* %FILL components may not have initializers.  */
    2701                 :     186217 :   if (gfc_str_startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
    2702                 :            :     {
    2703                 :          1 :       gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
    2704                 :          1 :       m = MATCH_ERROR;
    2705                 :          1 :       goto cleanup;
    2706                 :            :     }
    2707                 :            : 
    2708                 :            :   /*  If this symbol has already shown up in a Cray Pointer declaration,
    2709                 :            :       and this is not a component declaration,
    2710                 :            :       then we want to set the type & bail out.  */
    2711                 :     186216 :   if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
    2712                 :            :     {
    2713                 :       2923 :       gfc_find_symbol (name, gfc_current_ns, 0, &sym);
    2714                 :       2923 :       if (sym != NULL && sym->attr.cray_pointee)
    2715                 :            :         {
    2716                 :        101 :           m = MATCH_YES;
    2717                 :        101 :           if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
    2718                 :            :             {
    2719                 :          1 :               m = MATCH_ERROR;
    2720                 :          1 :               goto cleanup;
    2721                 :            :             }
    2722                 :            : 
    2723                 :            :           /* Check to see if we have an array specification.  */
    2724                 :        100 :           if (cp_as != NULL)
    2725                 :            :             {
    2726                 :         49 :               if (sym->as != NULL)
    2727                 :            :                 {
    2728                 :          1 :                   gfc_error ("Duplicate array spec for Cray pointee at %C");
    2729                 :          1 :                   gfc_free_array_spec (cp_as);
    2730                 :          1 :                   m = MATCH_ERROR;
    2731                 :          1 :                   goto cleanup;
    2732                 :            :                 }
    2733                 :            :               else
    2734                 :            :                 {
    2735                 :         48 :                   if (!gfc_set_array_spec (sym, cp_as, &var_locus))
    2736                 :          0 :                     gfc_internal_error ("Cannot set pointee array spec.");
    2737                 :            : 
    2738                 :            :                   /* Fix the array spec.  */
    2739                 :         48 :                   m = gfc_mod_pointee_as (sym->as);
    2740                 :         48 :                   if (m == MATCH_ERROR)
    2741                 :          0 :                     goto cleanup;
    2742                 :            :                 }
    2743                 :            :             }
    2744                 :         99 :           goto cleanup;
    2745                 :            :         }
    2746                 :            :       else
    2747                 :            :         {
    2748                 :       2822 :           gfc_free_array_spec (cp_as);
    2749                 :            :         }
    2750                 :            :     }
    2751                 :            : 
    2752                 :            :   /* Procedure pointer as function result.  */
    2753                 :     186115 :   if (gfc_current_state () == COMP_FUNCTION
    2754                 :      26551 :       && strcmp ("ppr@", gfc_current_block ()->name) == 0
    2755                 :         24 :       && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
    2756                 :          6 :     strcpy (name, "ppr@");
    2757                 :            : 
    2758                 :     186115 :   if (gfc_current_state () == COMP_FUNCTION
    2759                 :      26551 :       && strcmp (name, gfc_current_block ()->name) == 0
    2760                 :       5739 :       && gfc_current_block ()->result
    2761                 :       5739 :       && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
    2762                 :         12 :     strcpy (name, "ppr@");
    2763                 :            : 
    2764                 :            :   /* OK, we've successfully matched the declaration.  Now put the
    2765                 :            :      symbol in the current namespace, because it might be used in the
    2766                 :            :      optional initialization expression for this symbol, e.g. this is
    2767                 :            :      perfectly legal:
    2768                 :            : 
    2769                 :            :      integer, parameter :: i = huge(i)
    2770                 :            : 
    2771                 :            :      This is only true for parameters or variables of a basic type.
    2772                 :            :      For components of derived types, it is not true, so we don't
    2773                 :            :      create a symbol for those yet.  If we fail to create the symbol,
    2774                 :            :      bail out.  */
    2775                 :     173315 :   if (!gfc_comp_struct (gfc_current_state ())
    2776                 :     358996 :       && !build_sym (name, cl, cl_deferred, &as, &var_locus))
    2777                 :            :     {
    2778                 :         38 :       m = MATCH_ERROR;
    2779                 :         38 :       goto cleanup;
    2780                 :            :     }
    2781                 :            : 
    2782                 :     186077 :   if (!check_function_name (name))
    2783                 :            :     {
    2784                 :          0 :       m = MATCH_ERROR;
    2785                 :          0 :       goto cleanup;
    2786                 :            :     }
    2787                 :            : 
    2788                 :            :   /* We allow old-style initializations of the form
    2789                 :            :        integer i /2/, j(4) /3*3, 1/
    2790                 :            :      (if no colon has been seen). These are different from data
    2791                 :            :      statements in that initializers are only allowed to apply to the
    2792                 :            :      variable immediately preceding, i.e.
    2793                 :            :        integer i, j /1, 2/
    2794                 :            :      is not allowed. Therefore we have to do some work manually, that
    2795                 :            :      could otherwise be left to the matchers for DATA statements.  */
    2796                 :            : 
    2797                 :     186077 :   if (!colon_seen && gfc_match (" /") == MATCH_YES)
    2798                 :            :     {
    2799                 :        127 :       if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
    2800                 :            :                            "initialization at %C"))
    2801                 :            :         return MATCH_ERROR;
    2802                 :            : 
    2803                 :            :       /* Allow old style initializations for components of STRUCTUREs and MAPs
    2804                 :            :          but not components of derived types.  */
    2805                 :        127 :       else if (gfc_current_state () == COMP_DERIVED)
    2806                 :            :         {
    2807                 :          2 :           gfc_error ("Invalid old style initialization for derived type "
    2808                 :            :                      "component at %C");
    2809                 :          2 :           m = MATCH_ERROR;
    2810                 :          2 :           goto cleanup;
    2811                 :            :         }
    2812                 :            : 
    2813                 :            :       /* For structure components, read the initializer as a special
    2814                 :            :          expression and let the rest of this function apply the initializer
    2815                 :            :          as usual.  */
    2816                 :        125 :       else if (gfc_comp_struct (gfc_current_state ()))
    2817                 :            :         {
    2818                 :         73 :           m = match_clist_expr (&initializer, &current_ts, as);
    2819                 :         73 :           if (m == MATCH_NO)
    2820                 :          0 :             gfc_error ("Syntax error in old style initialization of %s at %C",
    2821                 :            :                        name);
    2822                 :         73 :           if (m != MATCH_YES)
    2823                 :         14 :             goto cleanup;
    2824                 :            :         }
    2825                 :            : 
    2826                 :            :       /* Otherwise we treat the old style initialization just like a
    2827                 :            :          DATA declaration for the current variable.  */
    2828                 :            :       else
    2829                 :         52 :         return match_old_style_init (name);
    2830                 :            :     }
    2831                 :            : 
    2832                 :            :   /* The double colon must be present in order to have initializers.
    2833                 :            :      Otherwise the statement is ambiguous with an assignment statement.  */
    2834                 :     186009 :   if (colon_seen)
    2835                 :            :     {
    2836                 :     149741 :       if (gfc_match (" =>") == MATCH_YES)
    2837                 :            :         {
    2838                 :        800 :           if (!current_attr.pointer)
    2839                 :            :             {
    2840                 :          0 :               gfc_error ("Initialization at %C isn't for a pointer variable");
    2841                 :          0 :               m = MATCH_ERROR;
    2842                 :          0 :               goto cleanup;
    2843                 :            :             }
    2844                 :            : 
    2845                 :        800 :           m = match_pointer_init (&initializer, 0);
    2846                 :        800 :           if (m != MATCH_YES)
    2847                 :         10 :             goto cleanup;
    2848                 :            : 
    2849                 :            :           /* The target of a pointer initialization must have the SAVE
    2850                 :            :              attribute.  A variable in PROGRAM, MODULE, or SUBMODULE scope
    2851                 :            :              is implicit SAVEd.  Explicitly, set the SAVE_IMPLICIT value.  */
    2852                 :        790 :           if (initializer->expr_type == EXPR_VARIABLE
    2853                 :        113 :               && initializer->symtree->n.sym->attr.save == SAVE_NONE
    2854                 :         24 :               && (gfc_current_state () == COMP_PROGRAM
    2855                 :            :                   || gfc_current_state () == COMP_MODULE
    2856                 :         24 :                   || gfc_current_state () == COMP_SUBMODULE))
    2857                 :         10 :             initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
    2858                 :            :         }
    2859                 :     148941 :       else if (gfc_match_char ('=') == MATCH_YES)
    2860                 :            :         {
    2861                 :      17889 :           if (current_attr.pointer)
    2862                 :            :             {
    2863                 :          0 :               gfc_error ("Pointer initialization at %C requires %<=>%>, "
    2864                 :            :                          "not %<=%>");
    2865                 :          0 :               m = MATCH_ERROR;
    2866                 :          0 :               goto cleanup;
    2867                 :            :             }
    2868                 :            : 
    2869                 :      17889 :           m = gfc_match_init_expr (&initializer);
    2870                 :      17889 :           if (m == MATCH_NO)
    2871                 :            :             {
    2872                 :          0 :               gfc_error ("Expected an initialization expression at %C");
    2873                 :          0 :               m = MATCH_ERROR;
    2874                 :            :             }
    2875                 :            : 
    2876                 :       7041 :           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
    2877                 :      17891 :               && !gfc_comp_struct (gfc_state_stack->state))
    2878                 :            :             {
    2879                 :          1 :               gfc_error ("Initialization of variable at %C is not allowed in "
    2880                 :            :                          "a PURE procedure");
    2881                 :          1 :               m = MATCH_ERROR;
    2882                 :            :             }
    2883                 :            : 
    2884                 :      17889 :           if (current_attr.flavor != FL_PARAMETER
    2885                 :       7041 :               && !gfc_comp_struct (gfc_state_stack->state))
    2886                 :       5172 :             gfc_unset_implicit_pure (gfc_current_ns->proc_name);
    2887                 :            : 
    2888                 :      17889 :           if (m != MATCH_YES)
    2889                 :         92 :             goto cleanup;
    2890                 :            :         }
    2891                 :            :     }
    2892                 :            : 
    2893                 :     185907 :   if (initializer != NULL && current_attr.allocatable
    2894                 :          3 :         && gfc_comp_struct (gfc_current_state ()))
    2895                 :            :     {
    2896                 :          2 :       gfc_error ("Initialization of allocatable component at %C is not "
    2897                 :            :                  "allowed");
    2898                 :          2 :       m = MATCH_ERROR;
    2899                 :          2 :       goto cleanup;
    2900                 :            :     }
    2901                 :            : 
    2902                 :     185905 :   if (gfc_current_state () == COMP_DERIVED
    2903                 :      12253 :       && gfc_current_block ()->attr.pdt_template)
    2904                 :            :     {
    2905                 :        474 :       gfc_symbol *param;
    2906                 :        474 :       gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
    2907                 :            :                        0, &param);
    2908                 :        474 :       if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
    2909                 :            :         {
    2910                 :          1 :           gfc_error ("The component with KIND or LEN attribute at %C does not "
    2911                 :            :                      "not appear in the type parameter list at %L",
    2912                 :          1 :                      &gfc_current_block ()->declared_at);
    2913                 :          1 :           m = MATCH_ERROR;
    2914                 :          4 :           goto cleanup;
    2915                 :            :         }
    2916                 :        473 :       else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
    2917                 :            :         {
    2918                 :          1 :           gfc_error ("The component at %C that appears in the type parameter "
    2919                 :            :                      "list at %L has neither the KIND nor LEN attribute",
    2920                 :          1 :                      &gfc_current_block ()->declared_at);
    2921                 :          1 :           m = MATCH_ERROR;
    2922                 :          1 :           goto cleanup;
    2923                 :            :         }
    2924                 :        472 :       else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
    2925                 :            :         {
    2926                 :          1 :           gfc_error ("The component at %C which is a type parameter must be "
    2927                 :            :                      "a scalar");
    2928                 :          1 :           m = MATCH_ERROR;
    2929                 :          1 :           goto cleanup;
    2930                 :            :         }
    2931                 :        471 :       else if (param && initializer)
    2932                 :            :         {
    2933                 :        102 :           if (initializer->ts.type == BT_BOZ)
    2934                 :            :             {
    2935                 :          1 :               gfc_error ("BOZ literal constant at %L cannot appear as an "
    2936                 :            :                          "initializer", &initializer->where);
    2937                 :          1 :               m = MATCH_ERROR;
    2938                 :          1 :               goto cleanup;
    2939                 :            :             }
    2940                 :        101 :           param->value = gfc_copy_expr (initializer);
    2941                 :            :         }
    2942                 :            :     }
    2943                 :            : 
    2944                 :            :   /* Before adding a possible initilizer, do a simple check for compatibility
    2945                 :            :      of lhs and rhs types.  Assigning a REAL value to a derived type is not a
    2946                 :            :      good thing.  */
    2947                 :      17351 :   if (current_ts.type == BT_DERIVED && initializer
    2948                 :     186841 :       && (gfc_numeric_ts (&initializer->ts)
    2949                 :        939 :           || initializer->ts.type == BT_LOGICAL
    2950                 :        939 :           || initializer->ts.type == BT_CHARACTER))
    2951                 :            :     {
    2952                 :          1 :       gfc_error ("Incompatible initialization between a derived type "
    2953                 :            :                  "entity and an entity with %qs type at %C",
    2954                 :            :                   gfc_typename (initializer));
    2955                 :          1 :       m = MATCH_ERROR;
    2956                 :          1 :       goto cleanup;
    2957                 :            :     }
    2958                 :            : 
    2959                 :            : 
    2960                 :            :   /* Add the initializer.  Note that it is fine if initializer is
    2961                 :            :      NULL here, because we sometimes also need to check if a
    2962                 :            :      declaration *must* have an initialization expression.  */
    2963                 :     185900 :   if (!gfc_comp_struct (gfc_current_state ()))
    2964                 :     172694 :     t = add_init_expr_to_sym (name, &initializer, &var_locus);
    2965                 :            :   else
    2966                 :            :     {
    2967                 :      13206 :       if (current_ts.type == BT_DERIVED
    2968                 :       1882 :           && !current_attr.pointer && !initializer)
    2969                 :       1419 :         initializer = gfc_default_initializer (&current_ts);
    2970                 :      13206 :       t = build_struct (name, cl, &initializer, &as);
    2971                 :            : 
    2972                 :            :       /* If we match a nested structure definition we expect to see the
    2973                 :            :        * body even if the variable declarations blow up, so we need to keep
    2974                 :            :        * the structure declaration around.  */
    2975                 :      13206 :       if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
    2976                 :         34 :         gfc_commit_symbol (gfc_new_block);
    2977                 :            :     }
    2978                 :            : 
    2979                 :     185900 :   m = (t) ? MATCH_YES : MATCH_ERROR;
    2980                 :            : 
    2981                 :     186228 : cleanup:
    2982                 :            :   /* Free stuff up and return.  */
    2983                 :     186228 :   gfc_seen_div0 = false;
    2984                 :     186228 :   gfc_free_expr (initializer);
    2985                 :     186228 :   gfc_free_array_spec (as);
    2986                 :            : 
    2987                 :     186228 :   return m;
    2988                 :            : }
    2989                 :            : 
    2990                 :            : 
    2991                 :            : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
    2992                 :            :    This assumes that the byte size is equal to the kind number for
    2993                 :            :    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
    2994                 :            : 
    2995                 :            : match
    2996                 :      73960 : gfc_match_old_kind_spec (gfc_typespec *ts)
    2997                 :            : {
    2998                 :      73960 :   match m;
    2999                 :      73960 :   int original_kind;
    3000                 :            : 
    3001                 :      73960 :   if (gfc_match_char ('*') != MATCH_YES)
    3002                 :            :     return MATCH_NO;
    3003                 :            : 
    3004                 :        749 :   m = gfc_match_small_literal_int (&ts->kind, NULL);
    3005                 :        749 :   if (m != MATCH_YES)
    3006                 :            :     return MATCH_ERROR;
    3007                 :            : 
    3008                 :        749 :   original_kind = ts->kind;
    3009                 :            : 
    3010                 :            :   /* Massage the kind numbers for complex types.  */
    3011                 :        749 :   if (ts->type == BT_COMPLEX)
    3012                 :            :     {
    3013                 :         88 :       if (ts->kind % 2)
    3014                 :            :         {
    3015                 :          0 :           gfc_error ("Old-style type declaration %s*%d not supported at %C",
    3016                 :            :                      gfc_basic_typename (ts->type), original_kind);
    3017                 :          0 :           return MATCH_ERROR;
    3018                 :            :         }
    3019                 :         88 :       ts->kind /= 2;
    3020                 :            : 
    3021                 :            :     }
    3022                 :            : 
    3023                 :        749 :   if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
    3024                 :          0 :     ts->kind = 8;
    3025                 :            : 
    3026                 :        749 :   if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
    3027                 :            :     {
    3028                 :        455 :       if (ts->kind == 4)
    3029                 :            :         {
    3030                 :        128 :           if (flag_real4_kind == 8)
    3031                 :          0 :             ts->kind =  8;
    3032                 :        128 :           if (flag_real4_kind == 10)
    3033                 :          0 :             ts->kind = 10;
    3034                 :        128 :           if (flag_real4_kind == 16)
    3035                 :          0 :             ts->kind = 16;
    3036                 :            :         }
    3037                 :            : 
    3038                 :        455 :       if (ts->kind == 8)
    3039                 :            :         {
    3040                 :        320 :           if (flag_real8_kind == 4)
    3041                 :          0 :             ts->kind = 4;
    3042                 :        320 :           if (flag_real8_kind == 10)
    3043                 :          0 :             ts->kind = 10;
    3044                 :        320 :           if (flag_real8_kind == 16)
    3045                 :          0 :             ts->kind = 16;
    3046                 :            :         }
    3047                 :            :     }
    3048                 :            : 
    3049                 :        749 :   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
    3050                 :            :     {
    3051                 :          8 :       gfc_error ("Old-style type declaration %s*%d not supported at %C",
    3052                 :            :                  gfc_basic_typename (ts->type), original_kind);
    3053                 :          8 :       return MATCH_ERROR;
    3054                 :            :     }
    3055                 :            : 
    3056                 :        741 :   if (!gfc_notify_std (GFC_STD_GNU,
    3057                 :            :                        "Nonstandard type declaration %s*%d at %C",
    3058                 :            :                        gfc_basic_typename(ts->type), original_kind))
    3059                 :          0 :     return MATCH_ERROR;
    3060                 :            : 
    3061                 :            :   return MATCH_YES;
    3062                 :            : }
    3063                 :            : 
    3064                 :            : 
    3065                 :            : /* Match a kind specification.  Since kinds are generally optional, we
    3066                 :            :    usually return MATCH_NO if something goes wrong.  If a "kind="
    3067                 :            :    string is found, then we know we have an error.  */
    3068                 :            : 
    3069                 :            : match
    3070                 :     101323 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
    3071                 :            : {
    3072                 :     101323 :   locus where, loc;
    3073                 :     101323 :   gfc_expr *e;
    3074                 :     101323 :   match m, n;
    3075                 :     101323 :   char c;
    3076                 :            : 
    3077                 :     101323 :   m = MATCH_NO;
    3078                 :     101323 :   n = MATCH_YES;
    3079                 :     101323 :   e = NULL;
    3080                 :     101323 :   saved_kind_expr = NULL;
    3081                 :            : 
    3082                 :     101323 :   where = loc = gfc_current_locus;
    3083                 :            : 
    3084                 :     101323 :   if (kind_expr_only)
    3085                 :          0 :     goto kind_expr;
    3086                 :            : 
    3087                 :     101323 :   if (gfc_match_char ('(') == MATCH_NO)
    3088                 :            :     return MATCH_NO;
    3089                 :            : 
    3090                 :            :   /* Also gobbles optional text.  */
    3091                 :      26847 :   if (gfc_match (" kind = ") == MATCH_YES)
    3092                 :      26847 :     m = MATCH_ERROR;
    3093                 :            : 
    3094                 :      26847 :   loc = gfc_current_locus;
    3095                 :            : 
    3096                 :      26847 : kind_expr:
    3097                 :            : 
    3098                 :      26847 :   n = gfc_match_init_expr (&e);
    3099                 :            : 
    3100                 :      26847 :   if (gfc_derived_parameter_expr (e))
    3101                 :            :     {
    3102                 :         75 :       ts->kind = 0;
    3103                 :         75 :       saved_kind_expr = gfc_copy_expr (e);
    3104                 :         75 :       goto close_brackets;
    3105                 :            :     }
    3106                 :            : 
    3107                 :      26772 :   if (n != MATCH_YES)
    3108                 :            :     {
    3109                 :         64 :       if (gfc_matching_function)
    3110                 :            :         {
    3111                 :            :           /* The function kind expression might include use associated or
    3112                 :            :              imported parameters and try again after the specification
    3113                 :            :              expressions.....  */
    3114                 :         44 :           if (gfc_match_char (')') != MATCH_YES)
    3115                 :            :             {
    3116                 :          0 :               gfc_error ("Missing right parenthesis at %C");
    3117                 :          0 :               m = MATCH_ERROR;
    3118                 :          0 :               goto no_match;
    3119                 :            :             }
    3120                 :            : 
    3121                 :         44 :           gfc_free_expr (e);
    3122                 :         44 :           gfc_undo_symbols ();
    3123                 :         44 :           return MATCH_YES;
    3124                 :            :         }
    3125                 :            :       else
    3126                 :            :         {
    3127                 :            :           /* ....or else, the match is real.  */
    3128                 :         20 :           if (n == MATCH_NO)
    3129                 :          0 :             gfc_error ("Expected initialization expression at %C");
    3130                 :         20 :           if (n != MATCH_YES)
    3131                 :         20 :             return MATCH_ERROR;
    3132                 :            :         }
    3133                 :            :     }
    3134                 :            : 
    3135                 :      26708 :   if (e->rank != 0)
    3136                 :            :     {
    3137                 :          0 :       gfc_error ("Expected scalar initialization expression at %C");
    3138                 :          0 :       m = MATCH_ERROR;
    3139                 :          0 :       goto no_match;
    3140                 :            :     }
    3141                 :            : 
    3142                 :      26708 :   if (gfc_extract_int (e, &ts->kind, 1))
    3143                 :            :     {
    3144                 :          0 :       m = MATCH_ERROR;
    3145                 :          0 :       goto no_match;
    3146                 :            :     }
    3147                 :            : 
    3148                 :            :   /* Before throwing away the expression, let's see if we had a
    3149                 :            :      C interoperable kind (and store the fact).  */
    3150                 :      26708 :   if (e->ts.is_c_interop == 1)
    3151                 :            :     {
    3152                 :            :       /* Mark this as C interoperable if being declared with one
    3153                 :            :          of the named constants from iso_c_binding.  */
    3154                 :       6592 :       ts->is_c_interop = e->ts.is_iso_c;
    3155                 :       6592 :       ts->f90_type = e->ts.f90_type;
    3156                 :       6592 :       if (e->symtree)
    3157                 :       6591 :         ts->interop_kind = e->symtree->n.sym;
    3158                 :            :     }
    3159                 :            : 
    3160                 :      26708 :   gfc_free_expr (e);
    3161                 :      26708 :   e = NULL;
    3162                 :            : 
    3163                 :            :   /* Ignore errors to this point, if we've gotten here.  This means
    3164                 :            :      we ignore the m=MATCH_ERROR from above.  */
    3165                 :      26708 :   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
    3166                 :            :     {
    3167                 :          7 :       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
    3168                 :            :                  gfc_basic_typename (ts->type));
    3169                 :          7 :       gfc_current_locus = where;
    3170                 :          7 :       return MATCH_ERROR;
    3171                 :            :     }
    3172                 :            : 
    3173                 :            :   /* Warn if, e.g., c_int is used for a REAL variable, but not
    3174                 :            :      if, e.g., c_double is used for COMPLEX as the standard
    3175                 :            :      explicitly says that the kind type parameter for complex and real
    3176                 :            :      variable is the same, i.e. c_float == c_float_complex.  */
    3177                 :      26701 :   if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
    3178                 :         16 :       && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
    3179                 :          1 :            || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
    3180                 :         12 :     gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
    3181                 :            :                      "is %s", gfc_basic_typename (ts->f90_type), &where,
    3182                 :            :                      gfc_basic_typename (ts->type));
    3183                 :            : 
    3184                 :      26689 : close_brackets:
    3185                 :            : 
    3186                 :      26776 :   gfc_gobble_whitespace ();
    3187                 :      26776 :   if ((c = gfc_next_ascii_char ()) != ')'
    3188                 :      26776 :       && (ts->type != BT_CHARACTER || c != ','))
    3189                 :            :     {
    3190                 :          0 :       if (ts->type == BT_CHARACTER)
    3191                 :          0 :         gfc_error ("Missing right parenthesis or comma at %C");
    3192                 :            :       else
    3193                 :          0 :         gfc_error ("Missing right parenthesis at %C");
    3194                 :          0 :       m = MATCH_ERROR;
    3195                 :            :     }
    3196                 :            :   else
    3197                 :            :      /* All tests passed.  */
    3198                 :            :      m = MATCH_YES;
    3199                 :            : 
    3200                 :          0 :   if(m == MATCH_ERROR)
    3201                 :          0 :      gfc_current_locus = where;
    3202                 :            : 
    3203                 :      26776 :   if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
    3204                 :          0 :     ts->kind =  8;
    3205                 :            : 
    3206                 :      26776 :   if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
    3207                 :            :     {
    3208                 :      11211 :       if (ts->kind == 4)
    3209                 :            :         {
    3210                 :       3756 :           if (flag_real4_kind == 8)
    3211                 :          0 :             ts->kind =  8;
    3212                 :       3756 :           if (flag_real4_kind == 10)
    3213                 :          0 :             ts->kind = 10;
    3214                 :       3756 :           if (flag_real4_kind == 16)
    3215                 :          0 :             ts->kind = 16;
    3216                 :            :         }
    3217                 :            : 
    3218                 :      11211 :       if (ts->kind == 8)
    3219                 :            :         {
    3220                 :       5424 :           if (flag_real8_kind == 4)
    3221                 :          0 :             ts->kind = 4;
    3222                 :       5424 :           if (flag_real8_kind == 10)
    3223                 :          0 :             ts->kind = 10;
    3224                 :       5424 :           if (flag_real8_kind == 16)
    3225                 :          0 :             ts->kind = 16;
    3226                 :            :         }
    3227                 :            :     }
    3228                 :            : 
    3229                 :            :   /* Return what we know from the test(s).  */
    3230                 :            :   return m;
    3231                 :            : 
    3232                 :          0 : no_match:
    3233                 :          0 :   gfc_free_expr (e);
    3234                 :          0 :   gfc_current_locus = where;
    3235                 :          0 :   return m;
    3236                 :            : }
    3237                 :            : 
    3238                 :            : 
    3239                 :            : static match
    3240                 :       1593 : match_char_kind (int * kind, int * is_iso_c)
    3241                 :            : {
    3242                 :       1593 :   locus where;
    3243                 :       1593 :   gfc_expr *e;
    3244                 :       1593 :   match m, n;
    3245                 :       1593 :   bool fail;
    3246                 :            : 
    3247                 :       1593 :   m = MATCH_NO;
    3248                 :       1593 :   e = NULL;
    3249                 :       1593 :   where = gfc_current_locus;
    3250                 :            : 
    3251                 :       1593 :   n = gfc_match_init_expr (&e);
    3252                 :            : 
    3253                 :       1593 :   if (n != MATCH_YES && gfc_matching_function)
    3254                 :            :     {
    3255                 :            :       /* The expression might include use-associated or imported
    3256                 :            :          parameters and try again after the specification
    3257                 :            :          expressions.  */
    3258                 :          4 :       gfc_free_expr (e);
    3259                 :          4 :       gfc_undo_symbols ();
    3260                 :          4 :       return MATCH_YES;
    3261                 :            :     }
    3262                 :            : 
    3263                 :       1589 :   if (n == MATCH_NO)
    3264                 :          0 :     gfc_error ("Expected initialization expression at %C");
    3265                 :       1589 :   if (n != MATCH_YES)
    3266                 :            :     return MATCH_ERROR;
    3267                 :            : 
    3268                 :       1586 :   if (e->rank != 0)
    3269                 :            :     {
    3270                 :          0 :       gfc_error ("Expected scalar initialization expression at %C");
    3271                 :          0 :       m = MATCH_ERROR;
    3272                 :          0 :       goto no_match;
    3273                 :            :     }
    3274                 :            : 
    3275                 :       1586 :   if (gfc_derived_parameter_expr (e))
    3276                 :            :     {
    3277                 :         12 :       saved_kind_expr = e;
    3278                 :         12 :       *kind = 0;
    3279                 :         12 :       return MATCH_YES;
    3280                 :            :     }
    3281                 :            : 
    3282                 :       1574 :   fail = gfc_extract_int (e, kind, 1);
    3283                 :       1574 :   *is_iso_c = e->ts.is_iso_c;
    3284                 :       1574 :   if (fail)
    3285                 :            :     {
    3286                 :          0 :       m = MATCH_ERROR;
    3287                 :          0 :       goto no_match;
    3288                 :            :     }
    3289                 :            : 
    3290                 :       1574 :   gfc_free_expr (e);
    3291                 :            : 
    3292                 :            :   /* Ignore errors to this point, if we've gotten here.  This means
    3293                 :            :      we ignore the m=MATCH_ERROR from above.  */
    3294                 :       1574 :   if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
    3295                 :            :     {
    3296                 :         14 :       gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
    3297                 :         14 :       m = MATCH_ERROR;
    3298                 :            :     }
    3299                 :            :   else
    3300                 :            :      /* All tests passed.  */
    3301                 :            :      m = MATCH_YES;
    3302                 :            : 
    3303                 :         14 :   if (m == MATCH_ERROR)
    3304                 :         14 :      gfc_current_locus = where;
    3305                 :            : 
    3306                 :            :   /* Return what we know from the test(s).  */
    3307                 :            :   return m;
    3308                 :            : 
    3309                 :          0 : no_match:
    3310                 :          0 :   gfc_free_expr (e);
    3311                 :          0 :   gfc_current_locus = where;
    3312                 :          0 :   return m;
    3313                 :            : }
    3314                 :            : 
    3315                 :            : 
    3316                 :            : /* Match the various kind/length specifications in a CHARACTER
    3317                 :            :    declaration.  We don't return MATCH_NO.  */
    3318                 :            : 
    3319                 :            : match
    3320                 :      21582 : gfc_match_char_spec (gfc_typespec *ts)
    3321                 :            : {
    3322                 :      21582 :   int kind, seen_length, is_iso_c;
    3323                 :      21582 :   gfc_charlen *cl;
    3324                 :      21582 :   gfc_expr *len;
    3325                 :      21582 :   match m;
    3326                 :      21582 :   bool deferred;
    3327                 :            : 
    3328                 :      21582 :   len = NULL;
    3329                 :      21582 :   seen_length = 0;
    3330                 :      21582 :   kind = 0;
    3331                 :      21582 :   is_iso_c = 0;
    3332                 :      21582 :   deferred = false;
    3333                 :            : 
    3334                 :            :   /* Try the old-style specification first.  */
    3335                 :      21582 :   old_char_selector = 0;
    3336                 :            : 
    3337                 :      21582 :   m = match_char_length (&len, &deferred, true);
    3338                 :      21582 :   if (m != MATCH_NO)
    3339                 :            :     {
    3340                 :       2242 :       if (m == MATCH_YES)
    3341                 :       2242 :         old_char_selector = 1;
    3342                 :       2242 :       seen_length = 1;
    3343                 :       2242 :       goto done;
    3344                 :            :     }
    3345                 :            : 
    3346                 :      19340 :   m = gfc_match_char ('(');
    3347                 :      19340 :   if (m != MATCH_YES)
    3348                 :            :     {
    3349                 :       1121 :       m = MATCH_YES;    /* Character without length is a single char.  */
    3350                 :       1121 :       goto done;
    3351                 :            :     }
    3352                 :            : 
    3353                 :            :   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
    3354                 :      18219 :   if (gfc_match (" kind =") == MATCH_YES)
    3355                 :            :     {
    3356                 :       1103 :       m = match_char_kind (&kind, &is_iso_c);
    3357                 :            : 
    3358                 :       1103 :       if (m == MATCH_ERROR)
    3359                 :         15 :         goto done;
    3360                 :       1088 :       if (m == MATCH_NO)
    3361                 :          0 :         goto syntax;
    3362                 :            : 
    3363                 :       1088 :       if (gfc_match (" , len =") == MATCH_NO)
    3364                 :        132 :         goto rparen;
    3365                 :            : 
    3366                 :        956 :       m = char_len_param_value (&len, &deferred);
    3367                 :        956 :       if (m == MATCH_NO)
    3368                 :          0 :         goto syntax;
    3369                 :        956 :       if (m == MATCH_ERROR)
    3370                 :          2 :         goto done;
    3371                 :        954 :       seen_length = 1;
    3372                 :            : 
    3373                 :        954 :       goto rparen;
    3374                 :            :     }
    3375                 :            : 
    3376                 :            :   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
    3377                 :      17116 :   if (gfc_match (" len =") == MATCH_YES)
    3378                 :            :     {
    3379                 :      10733 :       m = char_len_param_value (&len, &deferred);
    3380                 :      10733 :       if (m == MATCH_NO)
    3381                 :          2 :         goto syntax;
    3382                 :      10731 :       if (m == MATCH_ERROR)
    3383                 :          8 :         goto done;
    3384                 :      10723 :       seen_length = 1;
    3385                 :            : 
    3386                 :      10723 :       if (gfc_match_char (')') == MATCH_YES)
    3387                 :      10314 :         goto done;
    3388                 :            : 
    3389                 :        409 :       if (gfc_match (" , kind =") != MATCH_YES)
    3390                 :          0 :         goto syntax;
    3391                 :            : 
    3392                 :        409 :       if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
    3393                 :          2 :         goto done;
    3394                 :            : 
    3395                 :        407 :       goto rparen;
    3396                 :            :     }
    3397                 :            : 
    3398                 :            :   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
    3399                 :       6383 :   m = char_len_param_value (&len, &deferred);
    3400                 :       6383 :   if (m == MATCH_NO)
    3401                 :          0 :     goto syntax;
    3402                 :       6383 :   if (m == MATCH_ERROR)
    3403                 :         32 :     goto done;
    3404                 :       6351 :   seen_length = 1;
    3405                 :            : 
    3406                 :       6351 :   m = gfc_match_char (')');
    3407                 :       6351 :   if (m == MATCH_YES)
    3408                 :       6268 :     goto done;
    3409                 :            : 
    3410                 :         83 :   if (gfc_match_char (',') != MATCH_YES)
    3411                 :          2 :     goto syntax;
    3412                 :            : 
    3413                 :         81 :   gfc_match (" kind =");      /* Gobble optional text.  */
    3414                 :            : 
    3415                 :         81 :   m = match_char_kind (&kind, &is_iso_c);
    3416                 :         81 :   if (m == MATCH_ERROR)
    3417                 :          0 :     goto done;
    3418                 :         81 :   if (m == MATCH_NO)
    3419                 :          0 :     goto syntax;
    3420                 :            : 
    3421                 :         81 : rparen:
    3422                 :            :   /* Require a right-paren at this point.  */
    3423                 :       1574 :   m = gfc_match_char (')');
    3424                 :       1574 :   if (m == MATCH_YES)
    3425                 :       1574 :     goto done;
    3426                 :            : 
    3427                 :          0 : syntax:
    3428                 :          4 :   gfc_error ("Syntax error in CHARACTER declaration at %C");
    3429                 :          4 :   m = MATCH_ERROR;
    3430                 :          4 :   gfc_free_expr (len);
    3431                 :          4 :   return m;
    3432                 :            : 
    3433                 :      21578 : done:
    3434                 :            :   /* Deal with character functions after USE and IMPORT statements.  */
    3435                 :      21578 :   if (gfc_matching_function)
    3436                 :            :     {
    3437                 :        981 :       gfc_free_expr (len);
    3438                 :        981 :       gfc_undo_symbols ();
    3439                 :        981 :       return MATCH_YES;
    3440                 :            :     }
    3441                 :            : 
    3442                 :      20597 :   if (m != MATCH_YES)
    3443                 :            :     {
    3444                 :         49 :       gfc_free_expr (len);
    3445                 :         49 :       return m;
    3446                 :            :     }
    3447                 :            : 
    3448                 :            :   /* Do some final massaging of the length values.  */
    3449                 :      20548 :   cl = gfc_new_charlen (gfc_current_ns, NULL);
    3450                 :            : 
    3451                 :      20548 :   if (seen_length == 0)
    3452                 :       1208 :     cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
    3453                 :            :   else
    3454                 :            :     {
    3455                 :            :       /* If gfortran ends up here, then len may be reducible to a constant.
    3456                 :            :          Try to do that here.  If it does not reduce, simply assign len to
    3457                 :            :          charlen.  A complication occurs with user-defined generic functions,
    3458                 :            :          which are not resolved.  Use a private namespace to deal with
    3459                 :            :          generic functions.  */
    3460                 :            : 
    3461                 :      19340 :       if (len && len->expr_type != EXPR_CONSTANT)
    3462                 :            :         {
    3463                 :       1871 :           gfc_namespace *old_ns;
    3464                 :       1871 :           gfc_expr *e;
    3465                 :            : 
    3466                 :       1871 :           old_ns = gfc_current_ns;
    3467                 :       1871 :           gfc_current_ns = gfc_get_namespace (NULL, 0);
    3468                 :            : 
    3469                 :       1871 :           e = gfc_copy_expr (len);
    3470                 :       1871 :           gfc_reduce_init_expr (e);
    3471                 :       1871 :           if (e->expr_type == EXPR_CONSTANT)
    3472                 :            :             {
    3473                 :        184 :               gfc_replace_expr (len, e);
    3474                 :        184 :               if (mpz_cmp_si (len->value.integer, 0) < 0)
    3475                 :          7 :                 mpz_set_ui (len->value.integer, 0);
    3476                 :            :             }
    3477                 :            :           else
    3478                 :       1687 :             gfc_free_expr (e);
    3479                 :            : 
    3480                 :       1871 :           gfc_free_namespace (gfc_current_ns);
    3481                 :       1871 :           gfc_current_ns = old_ns;
    3482                 :            :         }
    3483                 :            : 
    3484                 :      19340 :       cl->length = len;
    3485                 :            :     }
    3486                 :            : 
    3487                 :      20548 :   ts->u.cl = cl;
    3488                 :      20548 :   ts->kind = kind == 0 ? gfc_default_character_kind : kind;
    3489                 :      20548 :   ts->deferred = deferred;
    3490                 :            : 
    3491                 :            :   /* We have to know if it was a C interoperable kind so we can
    3492                 :            :      do accurate type checking of bind(c) procs, etc.  */
    3493                 :      20548 :   if (kind != 0)
    3494                 :            :     /* Mark this as C interoperable if being declared with one
    3495                 :            :        of the named constants from iso_c_binding.  */
    3496                 :       1503 :     ts->is_c_interop = is_iso_c;
    3497                 :      19045 :   else if (len != NULL)
    3498                 :            :     /* Here, we might have parsed something such as: character(c_char)
    3499                 :            :        In this case, the parsing code above grabs the c_char when
    3500                 :            :        looking for the length (line 1690, roughly).  it's the last
    3501                 :            :        testcase for parsing the kind params of a character variable.
    3502                 :            :        However, it's not actually the length.    this seems like it
    3503                 :            :        could be an error.
    3504                 :            :        To see if the user used a C interop kind, test the expr
    3505                 :            :        of the so called length, and see if it's C interoperable.  */
    3506                 :      13143 :     ts->is_c_interop = len->ts.is_iso_c;
    3507                 :            : 
    3508                 :            :   return MATCH_YES;
    3509                 :            : }
    3510                 :            : 
    3511                 :            : 
    3512                 :            : /* Matches a RECORD declaration. */
    3513                 :            : 
    3514                 :            : static match
    3515                 :     627681 : match_record_decl (char *name)
    3516                 :            : {
    3517                 :     627681 :     locus old_loc;
    3518                 :     627681 :     old_loc = gfc_current_locus;
    3519                 :     627681 :     match m;
    3520                 :            : 
    3521                 :     627681 :     m = gfc_match (" record /");
    3522                 :     627681 :     if (m == MATCH_YES)
    3523                 :            :       {
    3524                 :        350 :           if (!flag_dec_structure)
    3525                 :            :             {
    3526                 :          6 :                 gfc_current_locus = old_loc;
    3527                 :          6 :                 gfc_error ("RECORD at %C is an extension, enable it with "
    3528                 :            :                            "%<-fdec-structure%>");
    3529                 :          6 :                 return MATCH_ERROR;
    3530                 :            :             }
    3531                 :        344 :           m = gfc_match (" %n/", name);
    3532                 :        344 :           if (m == MATCH_YES)
    3533                 :            :             return MATCH_YES;
    3534                 :            :       }
    3535                 :            : 
    3536                 :     627334 :   gfc_current_locus = old_loc;
    3537                 :     627334 :   if (flag_dec_structure
    3538                 :     627334 :       && (gfc_match (" record% ") == MATCH_YES
    3539                 :       7987 :           || gfc_match (" record%t") == MATCH_YES))
    3540                 :          6 :     gfc_error ("Structure name expected after RECORD at %C");
    3541                 :     627334 :   if (m == MATCH_NO)
    3542                 :     627334 :     return MATCH_NO;
    3543                 :            : 
    3544                 :            :   return MATCH_ERROR;
    3545                 :            : }
    3546                 :            : 
    3547                 :            : 
    3548                 :            : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
    3549                 :            :    of expressions to substitute into the possibly parameterized expression
    3550                 :            :    'e'. Using a list is inefficient but should not be too bad since the
    3551                 :            :    number of type parameters is not likely to be large.  */
    3552                 :            : static bool
    3553                 :       1562 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
    3554                 :            :                         int* f)
    3555                 :            : {
    3556                 :       1562 :   gfc_actual_arglist *param;
    3557                 :       1562 :   gfc_expr *copy;
    3558                 :            : 
    3559                 :       1562 :   if (e->expr_type != EXPR_VARIABLE)
    3560                 :            :     return false;
    3561                 :            : 
    3562                 :        764 :   gcc_assert (e->symtree);
    3563                 :        764 :   if (e->symtree->n.sym->attr.pdt_kind
    3564                 :        764 :       || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
    3565                 :            :     {
    3566                 :        794 :       for (param = type_param_spec_list; param; param = param->next)
    3567                 :        794 :         if (strcmp (e->symtree->n.sym->name, param->name) == 0)
    3568                 :            :           break;
    3569                 :            : 
    3570                 :        487 :       if (param)
    3571                 :            :         {
    3572                 :        487 :           copy = gfc_copy_expr (param->expr);
    3573                 :        487 :           *e = *copy;
    3574                 :        487 :           free (copy);
    3575                 :            :         }
    3576                 :            :     }
    3577                 :            : 
    3578                 :            :   return false;
    3579                 :            : }
    3580                 :            : 
    3581                 :            : 
    3582                 :            : bool
    3583                 :        549 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
    3584                 :            : {
    3585                 :        549 :   return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
    3586                 :            : }
    3587                 :            : 
    3588                 :            : 
    3589                 :            : bool
    3590                 :        634 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
    3591                 :            : {
    3592                 :        634 :   gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
    3593                 :        634 :   type_param_spec_list = param_list;
    3594                 :        634 :   return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
    3595                 :            :   type_param_spec_list = NULL;
    3596                 :            :   type_param_spec_list = old_param_spec_list;
    3597                 :            : }
    3598                 :            : 
    3599                 :            : /* Determines the instance of a parameterized derived type to be used by
    3600                 :            :    matching determining the values of the kind parameters and using them
    3601                 :            :    in the name of the instance. If the instance exists, it is used, otherwise
    3602                 :            :    a new derived type is created.  */
    3603                 :            : match
    3604                 :        600 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
    3605                 :            :                       gfc_actual_arglist **ext_param_list)
    3606                 :            : {
    3607                 :            :   /* The PDT template symbol.  */
    3608                 :        600 :   gfc_symbol *pdt = *sym;
    3609                 :            :   /* The symbol for the parameter in the template f2k_namespace.  */
    3610                 :        600 :   gfc_symbol *param;
    3611                 :            :   /* The hoped for instance of the PDT.  */
    3612                 :        600 :   gfc_symbol *instance;
    3613                 :            :   /* The list of parameters appearing in the PDT declaration.  */
    3614                 :        600 :   gfc_formal_arglist *type_param_name_list;
    3615                 :            :   /* Used to store the parameter specification list during recursive calls.  */
    3616                 :        600 :   gfc_actual_arglist *old_param_spec_list;
    3617                 :            :   /* Pointers to the parameter specification being used.  */
    3618                 :        600 :   gfc_actual_arglist *actual_param;
    3619                 :        600 :   gfc_actual_arglist *tail = NULL;
    3620                 :            :   /* Used to build up the name of the PDT instance. The prefix uses 4
    3621                 :            :      characters and each KIND parameter 2 more.  Allow 8 of the latter. */
    3622                 :        600 :   char name[GFC_MAX_SYMBOL_LEN + 21];
    3623                 :            : 
    3624                 :        600 :   bool name_seen = (param_list == NULL);
    3625                 :        600 :   bool assumed_seen = false;
    3626                 :        600 :   bool deferred_seen = false;
    3627                 :        600 :   bool spec_error = false;
    3628                 :        600 :   int kind_value, i;
    3629                 :        600 :   gfc_expr *kind_expr;
    3630                 :        600 :   gfc_component *c1, *c2;
    3631                 :        600 :   match m;
    3632                 :            : 
    3633                 :        600 :   type_param_spec_list = NULL;
    3634                 :            : 
    3635                 :        600 :   type_param_name_list = pdt->formal;
    3636                 :        600 :   actual_param = param_list;
    3637                 :        600 :   sprintf (name, "Pdt%s", pdt->name);
    3638                 :            : 
    3639                 :            :   /* Run through the parameter name list and pick up the actual
    3640                 :            :      parameter values or use the default values in the PDT declaration.  */
    3641                 :       1791 :   for (; type_param_name_list;
    3642                 :       1191 :        type_param_name_list = type_param_name_list->next)
    3643                 :            :     {
    3644                 :       1197 :       if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
    3645                 :            :         {
    3646                 :            :           if (actual_param->spec_type == SPEC_ASSUMED)
    3647                 :            :             spec_error = deferred_seen;
    3648                 :            :           else
    3649                 :            :             spec_error = assumed_seen;
    3650                 :            : 
    3651                 :            :           if (spec_error)
    3652                 :            :             {
    3653                 :            :               gfc_error ("The type parameter spec list at %C cannot contain "
    3654                 :            :                          "both ASSUMED and DEFERRED parameters");
    3655                 :            :               goto error_return;
    3656                 :            :             }
    3657                 :            :         }
    3658                 :            : 
    3659                 :       1197 :       if (actual_param && actual_param->name)
    3660                 :        308 :         name_seen = true;
    3661                 :       1197 :       param = type_param_name_list->sym;
    3662                 :            : 
    3663                 :       1197 :       if (!param || !param->name)
    3664                 :          1 :         continue;
    3665                 :            : 
    3666                 :       1196 :       c1 = gfc_find_component (pdt, param->name, false, true, NULL);
    3667                 :            :       /* An error should already have been thrown in resolve.c
    3668                 :            :          (resolve_fl_derived0).  */
    3669                 :       1196 :       if (!pdt->attr.use_assoc && !c1)
    3670                 :          1 :         goto error_return;
    3671                 :            : 
    3672                 :       1195 :       kind_expr = NULL;
    3673                 :       1195 :       if (!name_seen)
    3674                 :            :         {
    3675                 :        813 :           if (!actual_param && !(c1 && c1->initializer))
    3676                 :            :             {
    3677                 :          1 :               gfc_error ("The type parameter spec list at %C does not contain "
    3678                 :            :                          "enough parameter expressions");
    3679                 :          1 :               goto error_return;
    3680                 :            :             }
    3681                 :        812 :           else if (!actual_param && c1 && c1->initializer)
    3682                 :          1 :             kind_expr = gfc_copy_expr (c1->initializer);
    3683                 :        811 :           else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
    3684                 :        498 :             kind_expr = gfc_copy_expr (actual_param->expr);
    3685                 :            :         }
    3686                 :            :       else
    3687                 :            :         {
    3688                 :            :           actual_param = param_list;
    3689                 :        525 :           for (;actual_param; actual_param = actual_param->next)
    3690                 :        445 :             if (actual_param->name
    3691                 :        443 :                 && strcmp (actual_param->name, param->name) == 0)
    3692                 :            :               break;
    3693                 :        382 :           if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
    3694                 :        239 :             kind_expr = gfc_copy_expr (actual_param->expr);
    3695                 :            :           else
    3696                 :            :             {
    3697                 :        143 :               if (c1->initializer)
    3698                 :        135 :                 kind_expr = gfc_copy_expr (c1->initializer);
    3699                 :          8 :               else if (!(actual_param && param->attr.pdt_len))
    3700                 :            :                 {
    3701                 :          0 :                   gfc_error ("The derived parameter %qs at %C does not "
    3702                 :            :                              "have a default value", param->name);
    3703                 :          0 :                   goto error_return;
    3704                 :            :                 }
    3705                 :            :             }
    3706                 :            :         }
    3707                 :            : 
    3708                 :            :       /* Store the current parameter expressions in a temporary actual
    3709                 :            :          arglist 'list' so that they can be substituted in the corresponding
    3710                 :            :          expressions in the PDT instance.  */
    3711                 :       1194 :       if (type_param_spec_list == NULL)
    3712                 :            :         {
    3713                 :        600 :           type_param_spec_list = gfc_get_actual_arglist ();
    3714                 :        600 :           tail = type_param_spec_list;
    3715                 :            :         }
    3716                 :            :       else
    3717                 :            :         {
    3718                 :        594 :           tail->next = gfc_get_actual_arglist ();
    3719                 :        594 :           tail = tail->next;
    3720                 :            :         }
    3721                 :       1194 :       tail->name = param->name;
    3722                 :            : 
    3723                 :       1194 :       if (kind_expr)
    3724                 :            :         {
    3725                 :            :           /* Try simplification even for LEN expressions.  */
    3726                 :        873 :           gfc_resolve_expr (kind_expr);
    3727                 :        873 :           gfc_simplify_expr (kind_expr, 1);
    3728                 :            :           /* Variable expressions seem to default to BT_PROCEDURE.
    3729                 :            :              TODO find out why this is and fix it.  */
    3730                 :        873 :           if (kind_expr->ts.type != BT_INTEGER
    3731                 :         49 :               && kind_expr->ts.type != BT_PROCEDURE)
    3732                 :            :             {
    3733                 :          1 :               gfc_error ("The parameter expression at %C must be of "
    3734                 :            :                          "INTEGER type and not %s type",
    3735                 :            :                          gfc_basic_typename (kind_expr->ts.type));
    3736                 :          1 :               goto error_return;
    3737                 :            :             }
    3738                 :            : 
    3739                 :        872 :           tail->expr = gfc_copy_expr (kind_expr);
    3740                 :            :         }
    3741                 :            : 
    3742                 :       1193 :       if (actual_param)
    3743                 :       1112 :         tail->spec_type = actual_param->spec_type;
    3744                 :            : 
    3745                 :       1193 :       if (!param->attr.pdt_kind)
    3746                 :            :         {
    3747                 :        658 :           if (!name_seen && actual_param)
    3748                 :        475 :             actual_param = actual_param->next;
    3749                 :        658 :           if (kind_expr)
    3750                 :            :             {
    3751                 :        339 :               gfc_free_expr (kind_expr);
    3752                 :        339 :               kind_expr = NULL;
    3753                 :            :             }
    3754                 :        658 :           continue;
    3755                 :            :         }
    3756                 :            : 
    3757                 :        535 :       if (actual_param
    3758                 :        478 :           && (actual_param->spec_type == SPEC_ASSUMED
    3759                 :        478 :               || actual_param->spec_type == SPEC_DEFERRED))
    3760                 :            :         {
    3761                 :          2 :           gfc_error ("The KIND parameter %qs at %C cannot either be "
    3762                 :            :                      "ASSUMED or DEFERRED", param->name);
    3763                 :          2 :           goto error_return;
    3764                 :            :         }
    3765                 :            : 
    3766                 :        533 :       if (!kind_expr || !gfc_is_constant_expr (kind_expr))
    3767                 :            :         {
    3768                 :          1 :           gfc_error ("The value for the KIND parameter %qs at %C does not "
    3769                 :            :                      "reduce to a constant expression", param->name);
    3770                 :          1 :           goto error_return;
    3771                 :            :         }
    3772                 :            : 
    3773                 :        532 :       gfc_extract_int (kind_expr, &kind_value);
    3774                 :        532 :       sprintf (name + strlen (name), "_%d", kind_value);
    3775                 :            : 
    3776                 :        532 :       if (!name_seen && actual_param)
    3777                 :        332 :         actual_param = actual_param->next;
    3778                 :        532 :       gfc_free_expr (kind_expr);
    3779                 :            :     }
    3780                 :            : 
    3781                 :        594 :   if (!name_seen && actual_param)
    3782                 :            :     {
    3783                 :          1 :       gfc_error ("The type parameter spec list at %C contains too many "
    3784                 :            :                  "parameter expressions");
    3785                 :          1 :       goto error_return;
    3786                 :            :     }
    3787                 :            : 
    3788                 :            :   /* Now we search for the PDT instance 'name'. If it doesn't exist, we
    3789                 :            :      build it, using 'pdt' as a template.  */
    3790                 :        593 :   if (gfc_get_symbol (name, pdt->ns, &instance))
    3791                 :            :     {
    3792                 :          0 :       gfc_error ("Parameterized derived type at %C is ambiguous");
    3793                 :          0 :       goto error_return;
    3794                 :            :     }
    3795                 :            : 
    3796                 :        593 :   m = MATCH_YES;
    3797                 :            : 
    3798                 :        593 :   if (instance->attr.flavor == FL_DERIVED
    3799                 :        593 :       && instance->attr.pdt_type)
    3800                 :            :     {
    3801                 :        385 :       instance->refs++;
    3802                 :        385 :       if (ext_param_list)
    3803                 :         74 :         *ext_param_list = type_param_spec_list;
    3804                 :        385 :       *sym = instance;
    3805                 :        385 :       gfc_commit_symbols ();
    3806                 :        385 :       return m;
    3807                 :            :     }
    3808                 :            : 
    3809                 :            :   /* Start building the new instance of the parameterized type.  */
    3810                 :        208 :   gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
    3811                 :        208 :   instance->attr.pdt_template = 0;
    3812                 :        208 :   instance->attr.pdt_type = 1;
    3813                 :        208 :   instance->declared_at = gfc_current_locus;
    3814                 :            : 
    3815                 :            :   /* Add the components, replacing the parameters in all expressions
    3816                 :            :      with the expressions for their values in 'type_param_spec_list'.  */
    3817                 :        208 :   c1 = pdt->components;
    3818                 :        208 :   tail = type_param_spec_list;
    3819                 :        874 :   for (; c1; c1 = c1->next)
    3820                 :            :     {
    3821                 :        667 :       gfc_add_component (instance, c1->name, &c2);
    3822                 :            : 
    3823                 :        667 :       c2->ts = c1->ts;
    3824                 :        667 :       c2->attr = c1->attr;
    3825                 :            : 
    3826                 :            :       /* The order of declaration of the type_specs might not be the
    3827                 :            :          same as that of the components.  */
    3828                 :        667 :       if (c1->attr.pdt_kind || c1->attr.pdt_len)
    3829                 :            :         {
    3830                 :        571 :           for (tail = type_param_spec_list; tail; tail = tail->next)
    3831                 :        571 :             if (strcmp (c1->name, tail->name) == 0)
    3832                 :            :               break;
    3833                 :            :         }
    3834                 :            : 
    3835                 :            :       /* Deal with type extension by recursively calling this function
    3836                 :            :          to obtain the instance of the extended type.  */
    3837                 :        667 :       if (gfc_current_state () != COMP_DERIVED
    3838                 :        667 :           && c1 == pdt->components
    3839                 :        208 :           && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
    3840                 :         26 :           && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
    3841                 :        693 :           && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
    3842                 :            :         {
    3843                 :         26 :           gfc_formal_arglist *f;
    3844                 :            : 
    3845                 :         26 :           old_param_spec_list = type_param_spec_list;
    3846                 :            : 
    3847                 :            :           /* Obtain a spec list appropriate to the extended type..*/
    3848                 :         26 :           actual_param = gfc_copy_actual_arglist (type_param_spec_list);
    3849                 :         26 :           type_param_spec_list = actual_param;
    3850                 :         64 :           for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
    3851                 :         38 :             actual_param = actual_param->next;
    3852                 :         26 :           if (actual_param)
    3853                 :            :             {
    3854                 :         26 :               gfc_free_actual_arglist (actual_param->next);
    3855                 :         26 :               actual_param->next = NULL;
    3856                 :            :             }
    3857                 :            : 
    3858                 :            :           /* Now obtain the PDT instance for the extended type.  */
    3859                 :         26 :           c2->param_list = type_param_spec_list;
    3860                 :         26 :           m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
    3861                 :            :                                     NULL);
    3862                 :         26 :           type_param_spec_list = old_param_spec_list;
    3863                 :            : 
    3864                 :         26 :           c2->ts.u.derived->refs++;
    3865                 :         26 :           gfc_set_sym_referenced (c2->ts.u.derived);
    3866                 :            : 
    3867                 :            :           /* Set extension level.  */
    3868                 :         26 :           if (c2->ts.u.derived->attr.extension == 255)
    3869                 :            :             {
    3870                 :            :               /* Since the extension field is 8 bit wide, we can only have
    3871                 :            :                  up to 255 extension levels.  */
    3872                 :          0 :               gfc_error ("Maximum extension level reached with type %qs at %L",
    3873                 :            :                          c2->ts.u.derived->name,
    3874                 :            :                          &c2->ts.u.derived->declared_at);
    3875                 :          0 :               goto error_return;
    3876                 :            :             }
    3877                 :         26 :           instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
    3878                 :            : 
    3879                 :         26 :           continue;
    3880                 :            :         }
    3881                 :            : 
    3882                 :            :       /* Set the component kind using the parameterized expression.  */
    3883                 :        641 :       if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
    3884                 :        214 :            && c1->kind_expr != NULL)
    3885                 :            :         {
    3886                 :        127 :           gfc_expr *e = gfc_copy_expr (c1->kind_expr);
    3887                 :        127 :           gfc_insert_kind_parameter_exprs (e);
    3888                 :        127 :           gfc_simplify_expr (e, 1);
    3889                 :        127 :           gfc_extract_int (e, &c2->ts.kind);
    3890                 :        127 :           gfc_free_expr (e);
    3891                 :        127 :           if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
    3892                 :            :             {
    3893                 :          1 :               gfc_error ("Kind %d not supported for type %s at %C",
    3894                 :            :                          c2->ts.kind, gfc_basic_typename (c2->ts.type));
    3895                 :          1 :               goto error_return;
    3896                 :            :             }
    3897                 :            :         }
    3898                 :            : 
    3899                 :            :       /* Similarly, set the string length if parameterized.  */
    3900                 :        640 :       if (c1->ts.type == BT_CHARACTER
    3901                 :         60 :           && c1->ts.u.cl->length
    3902                 :        700 :           && gfc_derived_parameter_expr (c1->ts.u.cl->length))
    3903                 :            :         {
    3904                 :         60 :           gfc_expr *e;
    3905                 :         60 :           e = gfc_copy_expr (c1->ts.u.cl->length);
    3906                 :         60 :           gfc_insert_kind_parameter_exprs (e);
    3907                 :         60 :           gfc_simplify_expr (e, 1);
    3908                 :         60 :           c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    3909                 :         60 :           c2->ts.u.cl->length = e;
    3910                 :         60 :           c2->attr.pdt_string = 1;
    3911                 :            :         }
    3912                 :            : 
    3913                 :            :       /* Set up either the KIND/LEN initializer, if constant,
    3914                 :            :          or the parameterized expression. Use the template
    3915                 :            :          initializer if one is not already set in this instance.  */
    3916                 :        640 :       if (c2->attr.pdt_kind || c2->attr.pdt_len)
    3917                 :            :         {
    3918                 :        351 :           if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
    3919                 :        308 :             c2->initializer = gfc_copy_expr (tail->expr);
    3920                 :         43 :           else if (tail && tail->expr)
    3921                 :            :             {
    3922                 :          3 :               c2->param_list = gfc_get_actual_arglist ();
    3923                 :          3 :               c2->param_list->name = tail->name;
    3924                 :          3 :               c2->param_list->expr = gfc_copy_expr (tail->expr);
    3925                 :          3 :               c2->param_list->next = NULL;
    3926                 :            :             }
    3927                 :            : 
    3928                 :        351 :           if (!c2->initializer && c1->initializer)
    3929                 :         14 :             c2->initializer = gfc_copy_expr (c1->initializer);
    3930                 :            :         }
    3931                 :            : 
    3932                 :            :       /* Copy the array spec.  */
    3933                 :        640 :       c2->as = gfc_copy_array_spec (c1->as);
    3934                 :        640 :       if (c1->ts.type == BT_CLASS)
    3935                 :         12 :         CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
    3936                 :            : 
    3937                 :            :       /* Determine if an array spec is parameterized. If so, substitute
    3938                 :            :          in the parameter expressions for the bounds and set the pdt_array
    3939                 :            :          attribute. Notice that this attribute must be unconditionally set
    3940                 :            :          if this is an array of parameterized character length.  */
    3941                 :        640 :       if (c1->as && c1->as->type == AS_EXPLICIT)
    3942                 :            :         {
    3943                 :            :           bool pdt_array = false;
    3944                 :            : 
    3945                 :            :           /* Are the bounds of the array parameterized?  */
    3946                 :        307 :           for (i = 0; i < c1->as->rank; i++)
    3947                 :            :             {
    3948                 :        189 :               if (gfc_derived_parameter_expr (c1->as->lower[i]))
    3949                 :          0 :                 pdt_array = true;
    3950                 :        189 :               if (gfc_derived_parameter_expr (c1->as->upper[i]))
    3951                 :        175 :                 pdt_array = true;
    3952                 :            :             }
    3953                 :            : 
    3954                 :            :           /* If they are, free the expressions for the bounds and
    3955                 :            :              replace them with the template expressions with substitute
    3956                 :            :              values.  */
    3957                 :        293 :           for (i = 0; pdt_array && i < c1->as->rank; i++)
    3958                 :            :             {
    3959                 :        175 :               gfc_expr *e;
    3960                 :        175 :               e = gfc_copy_expr (c1->as->lower[i]);
    3961                 :        175 :               gfc_insert_kind_parameter_exprs (e);
    3962                 :        175 :               gfc_simplify_expr (e, 1);
    3963                 :        175 :               gfc_free_expr (c2->as->lower[i]);
    3964                 :        175 :               c2->as->lower[i] = e;
    3965                 :        175 :               e = gfc_copy_expr (c1->as->upper[i]);
    3966                 :        175 :               gfc_insert_kind_parameter_exprs (e);
    3967                 :        175 :               gfc_simplify_expr (e, 1);
    3968                 :        175 :               gfc_free_expr (c2->as->upper[i]);
    3969                 :        175 :               c2->as->upper[i] = e;
    3970                 :            :             }
    3971                 :        118 :           c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
    3972                 :        118 :           if (c1->initializer)
    3973                 :            :             {
    3974                 :         12 :               c2->initializer = gfc_copy_expr (c1->initializer);
    3975                 :         12 :               gfc_insert_kind_parameter_exprs (c2->initializer);
    3976                 :         12 :               gfc_simplify_expr (c2->initializer, 1);
    3977                 :            :             }
    3978                 :            :         }
    3979                 :            : 
    3980                 :            :       /* Recurse into this function for PDT components.  */
    3981                 :        640 :       if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
    3982                 :         51 :           && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
    3983                 :            :         {
    3984                 :         39 :           gfc_actual_arglist *params;
    3985                 :            :           /* The component in the template has a list of specification
    3986                 :            :              expressions derived from its declaration.  */
    3987                 :         39 :           params = gfc_copy_actual_arglist (c1->param_list);
    3988                 :         39 :           actual_param = params;
    3989                 :            :           /* Substitute the template parameters with the expressions
    3990                 :            :              from the specification list.  */
    3991                 :         79 :           for (;actual_param; actual_param = actual_param->next)
    3992                 :         40 :             gfc_insert_parameter_exprs (actual_param->expr,
    3993                 :            :                                         type_param_spec_list);
    3994                 :            : 
    3995                 :            :           /* Now obtain the PDT instance for the component.  */
    3996                 :         39 :           old_param_spec_list = type_param_spec_list;
    3997                 :         39 :           m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
    3998                 :         39 :           type_param_spec_list = old_param_spec_list;
    3999                 :            : 
    4000                 :         39 :           c2->param_list = params;
    4001                 :         39 :           if (!(c2->attr.pointer || c2->attr.allocatable))
    4002                 :         26 :             c2->initializer = gfc_default_initializer (&c2->ts);
    4003                 :            : 
    4004                 :         39 :           if (c2->attr.allocatable)
    4005                 :          7 :             instance->attr.alloc_comp = 1;
    4006                 :            :         }
    4007                 :            :     }
    4008                 :            : 
    4009                 :        207 :   gfc_commit_symbol (instance);
    4010                 :        207 :   if (ext_param_list)
    4011                 :          7 :     *ext_param_list = type_param_spec_list;
    4012                 :        207 :   *sym = instance;
    4013                 :        207 :   return m;
    4014                 :            : 
    4015                 :          8 : error_return:
    4016                 :          8 :   gfc_free_actual_arglist (type_param_spec_list);
    4017                 :          8 :   return MATCH_ERROR;
    4018                 :            : }
    4019                 :            : 
    4020                 :            : 
    4021                 :            : /* Match a legacy nonstandard BYTE type-spec.  */
    4022                 :            : 
    4023                 :            : static match
    4024                 :     770221 : match_byte_typespec (gfc_typespec *ts)
    4025                 :            : {
    4026                 :     770221 :   if (gfc_match (" byte") == MATCH_YES)
    4027                 :            :     {
    4028                 :         33 :       if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
    4029                 :            :         return MATCH_ERROR;
    4030                 :            : 
    4031                 :         31 :       if (gfc_current_form == FORM_FREE)
    4032                 :            :         {
    4033                 :         19 :           char c = gfc_peek_ascii_char ();
    4034                 :         19 :           if (!gfc_is_whitespace (c) && c != ',')
    4035                 :            :             return MATCH_NO;
    4036                 :            :         }
    4037                 :            : 
    4038                 :         29 :       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
    4039                 :            :         {
    4040                 :          0 :           gfc_error ("BYTE type used at %C "
    4041                 :            :                      "is not available on the target machine");
    4042                 :          0 :           return MATCH_ERROR;
    4043                 :            :         }
    4044                 :            : 
    4045                 :         29 :       ts->type = BT_INTEGER;
    4046                 :         29 :       ts->kind = 1;
    4047                 :         29 :       return MATCH_YES;
    4048                 :            :     }
    4049                 :            :   return MATCH_NO;
    4050                 :            : }
    4051                 :            : 
    4052                 :            : 
    4053                 :            : /* Matches a declaration-type-spec (F03:R502).  If successful, sets the ts
    4054                 :            :    structure to the matched specification.  This is necessary for FUNCTION and
    4055                 :            :    IMPLICIT statements.
    4056                 :            : 
    4057                 :            :    If implicit_flag is nonzero, then we don't check for the optional
    4058                 :            :    kind specification.  Not doing so is needed for matching an IMPLICIT
    4059                 :            :    statement correctly.  */
    4060                 :            : 
    4061                 :            : match
    4062                 :     770221 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
    4063                 :            : {
    4064                 :     770221 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    4065                 :     770221 :   gfc_symbol *sym, *dt_sym;
    4066                 :     770221 :   match m;
    4067                 :     770221 :   char c;
    4068                 :     770221 :   bool seen_deferred_kind, matched_type;
    4069                 :     770221 :   const char *dt_name;
    4070                 :            : 
    4071                 :     770221 :   decl_type_param_list = NULL;
    4072                 :            : 
    4073                 :            :   /* A belt and braces check that the typespec is correctly being treated
    4074                 :            :      as a deferred characteristic association.  */
    4075                 :    1540440 :   seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
    4076                 :      48673 :                           && (gfc_current_block ()->result->ts.kind == -1)
    4077                 :     775608 :                           && (ts->kind == -1);
    4078                 :     770221 :   gfc_clear_ts (ts);
    4079                 :     770221 :   if (seen_deferred_kind)
    4080                 :       5203 :     ts->kind = -1;
    4081                 :            : 
    4082                 :            :   /* Clear the current binding label, in case one is given.  */
    4083                 :     770221 :   curr_binding_label = NULL;
    4084                 :            : 
    4085                 :            :   /* Match BYTE type-spec.  */
    4086                 :     770221 :   m = match_byte_typespec (ts);
    4087                 :     770221 :   if (m != MATCH_NO)
    4088                 :            :     return m;
    4089                 :            : 
    4090                 :     770190 :   m = gfc_match (" type (");
    4091                 :     770190 :   matched_type = (m == MATCH_YES);
    4092                 :     770190 :   if (matched_type)
    4093                 :            :     {
    4094                 :      18355 :       gfc_gobble_whitespace ();
    4095                 :      18355 :       if (gfc_peek_ascii_char () == '*')
    4096                 :            :         {
    4097                 :       3724 :           if ((m = gfc_match ("*)")) != MATCH_YES)
    4098                 :            :             return m;
    4099                 :       3724 :           if (gfc_comp_struct (gfc_current_state ()))
    4100                 :            :             {
    4101                 :          1 :               gfc_error ("Assumed type at %C is not allowed for components");
    4102                 :          1 :               return MATCH_ERROR;
    4103                 :            :             }
    4104                 :       3723 :           if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
    4105                 :            :             return MATCH_ERROR;
    4106                 :       3722 :           ts->type = BT_ASSUMED;
    4107                 :       3722 :           return MATCH_YES;
    4108                 :            :         }
    4109                 :            : 
    4110                 :      14631 :       m = gfc_match ("%n", name);
    4111                 :      14631 :       matched_type = (m == MATCH_YES);
    4112                 :            :     }
    4113                 :            : 
    4114                 :      14631 :   if ((matched_type && strcmp ("integer", name) == 0)
    4115                 :     781092 :       || (!matched_type && gfc_match (" integer") == MATCH_YES))
    4116                 :            :     {
    4117                 :      66351 :       ts->type = BT_INTEGER;
    4118                 :      66351 :       ts->kind = gfc_default_integer_kind;
    4119                 :      66351 :       goto get_kind;
    4120                 :            :     }
    4121                 :            : 
    4122                 :      14626 :   if ((matched_type && strcmp ("character", name) == 0)
    4123                 :     714737 :       || (!matched_type && gfc_match (" character") == MATCH_YES))
    4124                 :            :     {
    4125                 :      20721 :       if (matched_type
    4126                 :      20721 :           && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
    4127                 :            :                               "intrinsic-type-spec at %C"))
    4128                 :            :         return MATCH_ERROR;
    4129                 :            : 
    4130                 :      20720 :       ts->type = BT_CHARACTER;
    4131                 :      20720 :       if (implicit_flag == 0)
    4132                 :      20615 :         m = gfc_match_char_spec (ts);
    4133                 :            :       else
    4134                 :            :         m = MATCH_YES;
    4135                 :            : 
    4136                 :      20720 :       if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
    4137                 :            :         {
    4138                 :          1 :           gfc_error ("Malformed type-spec at %C");
    4139                 :          1 :           return MATCH_ERROR;
    4140                 :            :         }
    4141                 :            : 
    4142                 :      20719 :       return m;
    4143                 :            :     }
    4144                 :            : 
    4145                 :      14622 :   if ((matched_type && strcmp ("real", name) == 0)
    4146                 :     694013 :       || (!matched_type && gfc_match (" real") == MATCH_YES))
    4147                 :            :     {
    4148                 :      23754 :       ts->type = BT_REAL;
    4149                 :      23754 :       ts->kind = gfc_default_real_kind;
    4150                 :      23754 :       goto get_kind;
    4151                 :            :     }
    4152                 :            : 
    4153                 :     655640 :   if ((matched_type
    4154                 :      14619 :        && (strcmp ("doubleprecision", name) == 0
    4155                 :      14618 :            || (strcmp ("double", name) == 0
    4156                 :          5 :                && gfc_match (" precision") == MATCH_YES)))
    4157                 :     670255 :       || (!matched_type && gfc_match (" double precision") == MATCH_YES))
    4158                 :            :     {
    4159                 :       2309 :       if (matched_type
    4160                 :       2309 :           && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
    4161                 :            :                               "intrinsic-type-spec at %C"))
    4162                 :            :         return MATCH_ERROR;
    4163                 :            : 
    4164                 :       2308 :       if (matched_type && gfc_match_char (')') != MATCH_YES)
    4165                 :            :         {
    4166                 :          2 :           gfc_error ("Malformed type-spec at %C");
    4167                 :          2 :           return MATCH_ERROR;
    4168                 :            :         }
    4169                 :            : 
    4170                 :       2306 :       ts->type = BT_REAL;
    4171                 :       2306 :       ts->kind = gfc_default_double_kind;
    4172                 :       2306 :       return MATCH_YES;
    4173                 :            :     }
    4174                 :            : 
    4175                 :      14615 :   if ((matched_type && strcmp ("complex", name) == 0)
    4176                 :     667946 :       || (!matched_type && gfc_match (" complex") == MATCH_YES))
    4177                 :            :     {
    4178                 :       3139 :       ts->type = BT_COMPLEX;
    4179                 :       3139 :       ts->kind = gfc_default_complex_kind;
    4180                 :       3139 :       goto get_kind;
    4181                 :            :     }
    4182                 :            : 
    4183                 :     650192 :   if ((matched_type
    4184                 :      14615 :        && (strcmp ("doublecomplex", name) == 0
    4185                 :      14614 :            || (strcmp ("double", name) == 0
    4186                 :          2 :                && gfc_match (" complex") == MATCH_YES)))
    4187                 :     664804 :       || (!matched_type && gfc_match (" double complex") == MATCH_YES))
    4188                 :            :     {
    4189                 :        201 :       if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
    4190                 :            :         return MATCH_ERROR;
    4191                 :            : 
    4192                 :        200 :       if (matched_type
    4193                 :        200 :           && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
    4194                 :            :                               "intrinsic-type-spec at %C"))
    4195                 :            :         return MATCH_ERROR;
    4196                 :            : 
    4197                 :        200 :       if (matched_type && gfc_match_char (')') != MATCH_YES)
    4198                 :            :         {
    4199                 :          2 :           gfc_error ("Malformed type-spec at %C");
    4200                 :          2 :           return MATCH_ERROR;
    4201                 :            :         }
    4202                 :            : 
    4203                 :        198 :       ts->type = BT_COMPLEX;
    4204                 :        198 :       ts->kind = gfc_default_double_kind;
    4205                 :        198 :       return MATCH_YES;
    4206                 :            :     }
    4207                 :            : 
    4208                 :      14612 :   if ((matched_type && strcmp ("logical", name) == 0)
    4209                 :     664600 :       || (!matched_type && gfc_match (" logical") == MATCH_YES))
    4210                 :            :     {
    4211                 :       7701 :       ts->type = BT_LOGICAL;
    4212                 :       7701 :       ts->kind = gfc_default_logical_kind;
    4213                 :       7701 :       goto get_kind;
    4214                 :            :     }
    4215                 :            : 
    4216                 :     642290 :   if (matched_type)
    4217                 :            :     {
    4218                 :      14609 :       m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
    4219                 :      14609 :       if (m == MATCH_ERROR)
    4220                 :            :         return m;
    4221                 :            : 
    4222                 :      14609 :       gfc_gobble_whitespace ();
    4223                 :      14609 :       if (gfc_peek_ascii_char () != ')')
    4224                 :            :         {
    4225                 :          1 :           gfc_error ("Malformed type-spec at %C");
    4226                 :          1 :           return MATCH_ERROR;
    4227                 :            :         }
    4228                 :      14608 :       m = gfc_match_char (')'); /* Burn closing ')'.  */
    4229                 :            :     }
    4230                 :            : 
    4231                 :     642289 :   if (m != MATCH_YES)
    4232                 :     627681 :     m = match_record_decl (name);
    4233                 :            : 
    4234                 :     642289 :   if (matched_type || m == MATCH_YES)
    4235                 :            :     {
    4236                 :      14949 :       ts->type = BT_DERIVED;
    4237                 :            :       /* We accept record/s/ or type(s) where s is a structure, but we
    4238                 :            :        * don't need all the extra derived-type stuff for structures.  */
    4239                 :      14949 :       if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
    4240                 :            :         {
    4241                 :          1 :           gfc_error ("Type name %qs at %C is ambiguous", name);
    4242                 :          1 :           return MATCH_ERROR;
    4243                 :            :         }
    4244                 :            : 
    4245                 :      14948 :       if (sym && sym->attr.flavor == FL_DERIVED
    4246                 :      14834 :           && sym->attr.pdt_template
    4247                 :        360 :           && gfc_current_state () != COMP_DERIVED)
    4248                 :            :         {
    4249                 :        321 :           m = gfc_get_pdt_instance (decl_type_param_list, &sym,  NULL);
    4250                 :        321 :           if (m != MATCH_YES)
    4251                 :            :             return m;
    4252                 :        313 :           gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
    4253                 :        313 :           ts->u.derived = sym;
    4254                 :        313 :           strcpy (name, gfc_dt_lower_string (sym->name));
    4255                 :            :         }
    4256                 :            : 
    4257                 :      14940 :       if (sym && sym->attr.flavor == FL_STRUCT)
    4258                 :            :         {
    4259                 :        358 :           ts->u.derived = sym;
    4260                 :        358 :           return MATCH_YES;
    4261                 :            :         }
    4262                 :            :       /* Actually a derived type.  */
    4263                 :            :     }
    4264                 :            : 
    4265                 :            :   else
    4266                 :            :     {
    4267                 :            :       /* Match nested STRUCTURE declarations; only valid within another
    4268                 :            :          structure declaration.  */
    4269                 :     627340 :       if (flag_dec_structure
    4270                 :       7993 :           && (gfc_current_state () == COMP_STRUCTURE
    4271                 :       7539 :               || gfc_current_state () == COMP_MAP))
    4272                 :            :         {
    4273                 :        721 :           m = gfc_match (" structure");
    4274                 :        721 :           if (m == MATCH_YES)
    4275                 :            :             {
    4276                 :         27 :               m = gfc_match_structure_decl ();
    4277                 :         27 :               if (m == MATCH_YES)
    4278                 :            :                 {
    4279                 :            :                   /* gfc_new_block is updated by match_structure_decl.  */
    4280                 :         26 :                   ts->type = BT_DERIVED;
    4281                 :         26 :                   ts->u.derived = gfc_new_block;
    4282                 :         26 :                   return MATCH_YES;
    4283                 :            :                 }
    4284                 :            :             }
    4285                 :        695 :           if (m == MATCH_ERROR)
    4286                 :            :             return MATCH_ERROR;
    4287                 :            :         }
    4288                 :            : 
    4289                 :            :       /* Match CLASS declarations.  */
    4290                 :     627313 :       m = gfc_match (" class ( * )");
    4291                 :     627313 :       if (m == MATCH_ERROR)
    4292                 :            :         return MATCH_ERROR;
    4293                 :     627313 :       else if (m == MATCH_YES)
    4294                 :            :         {
    4295                 :        851 :           gfc_symbol *upe;
    4296                 :        851 :           gfc_symtree *st;
    4297                 :        851 :           ts->type = BT_CLASS;
    4298                 :        851 :           gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
    4299                 :        851 :           if (upe == NULL)
    4300                 :            :             {
    4301                 :        505 :               upe = gfc_new_symbol ("STAR", gfc_current_ns);
    4302                 :        505 :               st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
    4303                 :        505 :               st->n.sym = upe;
    4304                 :        505 :               gfc_set_sym_referenced (upe);
    4305                 :        505 :               upe->refs++;
    4306                 :        505 :               upe->ts.type = BT_VOID;
    4307                 :        505 :               upe->attr.unlimited_polymorphic = 1;
    4308                 :            :               /* This is essential to force the construction of
    4309                 :            :                  unlimited polymorphic component class containers.  */
    4310                 :        505 :               upe->attr.zero_comp = 1;
    4311                 :        505 :               if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
    4312                 :            :                                    &gfc_current_locus))
    4313                 :            :               return MATCH_ERROR;
    4314                 :            :             }
    4315                 :            :           else
    4316                 :            :             {
    4317                 :        346 :               st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
    4318                 :        346 :               st->n.sym = upe;
    4319                 :        346 :               upe->refs++;
    4320                 :            :             }
    4321                 :        851 :           ts->u.derived = upe;
    4322                 :        851 :           return m;
    4323                 :            :         }
    4324                 :            : 
    4325                 :     626462 :       m = gfc_match (" class (");
    4326                 :            : 
    4327                 :     626462 :       if (m == MATCH_YES)
    4328                 :       6641 :         m = gfc_match ("%n", name);
    4329                 :            :       else
    4330                 :            :         return m;
    4331                 :            : 
    4332                 :       6641 :       if (m != MATCH_YES)
    4333                 :            :         return m;
    4334                 :       6641 :       ts->type = BT_CLASS;
    4335                 :            : 
    4336                 :       6641 :       if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
    4337                 :            :         return MATCH_ERROR;
    4338                 :            : 
    4339                 :       6640 :       m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
    4340                 :       6640 :       if (m == MATCH_ERROR)
    4341                 :            :         return m;
    4342                 :            : 
    4343                 :       6640 :       m = gfc_match_char (')');
    4344                 :       6640 :       if (m != MATCH_YES)
    4345                 :            :         return m;
    4346                 :            :     }
    4347                 :            : 
    4348                 :            :   /* Defer association of the derived type until the end of the
    4349                 :            :      specification block.  However, if the derived type can be
    4350                 :            :      found, add it to the typespec.  */
    4351                 :      21222 :   if (gfc_matching_function)
    4352                 :            :     {
    4353                 :        239 :       ts->u.derived = NULL;
    4354                 :        239 :       if (gfc_current_state () != COMP_INTERFACE
    4355                 :        239 :             && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
    4356                 :            :         {
    4357                 :        206 :           sym = gfc_find_dt_in_generic (sym);
    4358                 :        206 :           ts->u.derived = sym;
    4359                 :            :         }
    4360                 :        239 :       return MATCH_YES;
    4361                 :            :     }
    4362                 :            : 
    4363                 :            :   /* Search for the name but allow the components to be defined later.  If
    4364                 :            :      type = -1, this typespec has been seen in a function declaration but
    4365                 :            :      the type could not be accessed at that point.  The actual derived type is
    4366                 :            :      stored in a symtree with the first letter of the name capitalized; the
    4367                 :            :      symtree with the all lower-case name contains the associated
    4368                 :            :      generic function.  */
    4369                 :      20983 :   dt_name = gfc_dt_upper_string (name);
    4370                 :      20983 :   sym = NULL;
    4371                 :      20983 :   dt_sym = NULL;
    4372                 :      20983 :   if (ts->kind != -1)
    4373                 :            :     {
    4374                 :      20660 :       gfc_get_ha_symbol (name, &sym);
    4375                 :      20660 :       if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
    4376                 :            :         {
    4377                 :          0 :           gfc_error ("Type name %qs at %C is ambiguous", name);
    4378                 :          0 :           return MATCH_ERROR;
    4379                 :            :         }
    4380                 :      20660 :       if (sym->generic && !dt_sym)
    4381                 :       9265 :         dt_sym = gfc_find_dt_in_generic (sym);
    4382                 :            : 
    4383                 :            :       /* Host associated PDTs can get confused with their constructors
    4384                 :            :          because they ar instantiated in the template's namespace.  */
    4385                 :      20660 :       if (!dt_sym)
    4386                 :            :         {
    4387                 :        407 :           if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
    4388                 :            :             {
    4389                 :          0 :               gfc_error ("Type name %qs at %C is ambiguous", name);
    4390                 :          0 :               return MATCH_ERROR;
    4391                 :            :             }
    4392                 :        407 :           if (dt_sym && !dt_sym->attr.pdt_type)
    4393                 :          0 :             dt_sym = NULL;
    4394                 :            :         }
    4395                 :            :     }
    4396                 :        323 :   else if (ts->kind == -1)
    4397                 :            :     {
    4398                 :        646 :       int iface = gfc_state_stack->previous->state != COMP_INTERFACE
    4399                 :        323 :                     || gfc_current_ns->has_import_set;
    4400                 :        323 :       gfc_find_symbol (name, NULL, iface, &sym);
    4401                 :        323 :       if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
    4402                 :            :         {
    4403                 :          0 :           gfc_error ("Type name %qs at %C is ambiguous", name);
    4404                 :          0 :           return MATCH_ERROR;
    4405                 :            :         }
    4406                 :        323 :       if (sym && sym->generic && !dt_sym)
    4407                 :          0 :         dt_sym = gfc_find_dt_in_generic (sym);
    4408                 :            : 
    4409                 :        323 :       ts->kind = 0;
    4410                 :        323 :       if (sym == NULL)
    4411                 :            :         return MATCH_NO;
    4412                 :            :     }
    4413                 :            : 
    4414                 :      20974 :   if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
    4415                 :      20690 :        && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
    4416                 :      20972 :       || sym->attr.subroutine)
    4417                 :            :     {
    4418                 :          2 :       gfc_error ("Type name %qs at %C conflicts with previously declared "
    4419                 :            :                  "entity at %L, which has the same name", name,
    4420                 :            :                  &sym->declared_at);
    4421                 :          2 :       return MATCH_ERROR;
    4422                 :            :     }
    4423                 :            : 
    4424                 :      20972 :   if (sym && sym->attr.flavor == FL_DERIVED
    4425                 :      20972 :       && sym->attr.pdt_template
    4426                 :          0 :       && gfc_current_state () != COMP_DERIVED)
    4427                 :            :     {
    4428                 :          0 :       m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
    4429                 :          0 :       if (m != MATCH_YES)
    4430                 :            :         return m;
    4431                 :          0 :       gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
    4432                 :          0 :       ts->u.derived = sym;
    4433                 :          0 :       strcpy (name, gfc_dt_lower_string (sym->name));
    4434                 :            :     }
    4435                 :            : 
    4436                 :      20972 :   gfc_save_symbol_data (sym);
    4437                 :      20972 :   gfc_set_sym_referenced (sym);
    4438                 :      20972 :   if (!sym->attr.generic
    4439                 :      20972 :       && !gfc_add_generic (&sym->attr, sym->name, NULL))
    4440                 :            :     return MATCH_ERROR;
    4441                 :            : 
    4442                 :      20972 :   if (!sym->attr.function
    4443                 :      20972 :       && !gfc_add_function (&sym->attr, sym->name, NULL))
    4444                 :            :     return MATCH_ERROR;
    4445                 :            : 
    4446                 :      20972 :   if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
    4447                 :      20878 :       && dt_sym->attr.pdt_template
    4448                 :        154 :       && gfc_current_state () != COMP_DERIVED)
    4449                 :            :     {
    4450                 :        115 :       m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
    4451                 :        115 :       if (m != MATCH_YES)
    4452                 :            :         return m;
    4453                 :        115 :       gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
    4454                 :            :     }
    4455                 :            : 
    4456                 :      20972 :   if (!dt_sym)
    4457                 :            :     {
    4458                 :         94 :       gfc_interface *intr, *head;
    4459                 :            : 
    4460                 :            :       /* Use upper case to save the actual derived-type symbol.  */
    4461                 :         94 :       gfc_get_symbol (dt_name, NULL, &dt_sym);
    4462                 :         94 :       dt_sym->name = gfc_get_string ("%s", sym->name);
    4463                 :         94 :       head = sym->generic;
    4464                 :         94 :       intr = gfc_get_interface ();
    4465                 :         94 :       intr->sym = dt_sym;
    4466                 :         94 :       intr->where = gfc_current_locus;
    4467                 :         94 :       intr->next = head;
    4468                 :         94 :       sym->generic = intr;
    4469                 :         94 :       sym->attr.if_source = IFSRC_DECL;
    4470                 :            :     }
    4471                 :            :   else
    4472                 :      20878 :     gfc_save_symbol_data (dt_sym);
    4473                 :            : 
    4474                 :      20972 :   gfc_set_sym_referenced (dt_sym);
    4475                 :            : 
    4476                 :      20972 :   if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
    4477                 :      20972 :       && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
    4478                 :            :     return MATCH_ERROR;
    4479                 :            : 
    4480                 :      20972 :   ts->u.derived = dt_sym;
    4481                 :            : 
    4482                 :      20972 :   return MATCH_YES;
    4483                 :            : 
    4484                 :     100945 : get_kind:
    4485                 :     100945 :   if (matched_type
    4486                 :     100945 :       && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
    4487                 :            :                           "intrinsic-type-spec at %C"))
    4488                 :            :     return MATCH_ERROR;
    4489                 :            : 
    4490                 :            :   /* For all types except double, derived and character, look for an
    4491                 :            :      optional kind specifier.  MATCH_NO is actually OK at this point.  */
    4492                 :     100942 :   if (implicit_flag == 1)
    4493                 :            :     {
    4494                 :        237 :         if (matched_type && gfc_match_char (')') != MATCH_YES)
    4495                 :            :           return MATCH_ERROR;
    4496                 :            : 
    4497                 :        237 :         return MATCH_YES;
    4498                 :            :     }
    4499                 :            : 
    4500                 :     100705 :   if (gfc_current_form == FORM_FREE)
    4501                 :            :     {
    4502                 :      93436 :       c = gfc_peek_ascii_char ();
    4503                 :      93436 :       if (!gfc_is_whitespace (c) && c != '*' && c != '('
    4504                 :      44706 :           && c != ':' && c != ',')
    4505                 :            :         {
    4506                 :        160 :           if (matched_type && c == ')')
    4507                 :            :             {
    4508                 :          2 :               gfc_next_ascii_char ();
    4509                 :          2 :               return MATCH_YES;
    4510                 :            :             }
    4511                 :        158 :           gfc_error ("Malformed type-spec at %C");
    4512                 :        158 :           return MATCH_NO;
    4513                 :            :         }
    4514                 :            :     }
    4515                 :            : 
    4516                 :     100545 :   m = gfc_match_kind_spec (ts, false);
    4517                 :     100545 :   if (m == MATCH_NO && ts->type != BT_CHARACTER)
    4518                 :            :     {
    4519                 :      73923 :       m = gfc_match_old_kind_spec (ts);
    4520                 :      73923 :       if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
    4521                 :            :          return MATCH_ERROR;
    4522                 :            :     }
    4523                 :            : 
    4524                 :     100537 :   if (matched_type && gfc_match_char (')') != MATCH_YES)
    4525                 :            :     {
    4526                 :          0 :       gfc_error ("Malformed type-spec at %C");
    4527                 :          0 :       return MATCH_ERROR;
    4528                 :            :     }
    4529                 :            : 
    4530                 :            :   /* Defer association of the KIND expression of function results
    4531                 :            :      until after USE and IMPORT statements.  */
    4532                 :       4320 :   if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
    4533                 :     104818 :          || gfc_matching_function)
    4534                 :       5239 :     return MATCH_YES;
    4535                 :            : 
    4536                 :      95298 :   if (m == MATCH_NO)
    4537                 :      68847 :     m = MATCH_YES;              /* No kind specifier found.  */
    4538                 :            : 
    4539                 :            :   return m;
    4540                 :            : }
    4541                 :            : 
    4542                 :            : 
    4543                 :            : /* Match an IMPLICIT NONE statement.  Actually, this statement is
    4544                 :            :    already matched in parse.c, or we would not end up here in the
    4545                 :            :    first place.  So the only thing we need to check, is if there is
    4546                 :            :    trailing garbage.  If not, the match is successful.  */
    4547                 :            : 
    4548                 :            : match
    4549                 :      16109 : gfc_match_implicit_none (void)
    4550                 :            : {
    4551                 :      16109 :   char c;
    4552                 :      16109 :   match m;
    4553                 :      16109 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    4554                 :      16109 :   bool type = false;
    4555                 :      16109 :   bool external = false;
    4556                 :      16109 :   locus cur_loc = gfc_current_locus;
    4557                 :            : 
    4558                 :      16109 :   if (gfc_current_ns->seen_implicit_none
    4559                 :      16107 :       || gfc_current_ns->has_implicit_none_export)
    4560                 :            :     {
    4561                 :          4 :       gfc_error ("Duplicate IMPLICIT NONE statement at %C");
    4562                 :          4 :       return MATCH_ERROR;
    4563                 :            :     }
    4564                 :            : 
    4565                 :      16105 :   gfc_gobble_whitespace ();
    4566                 :      16105 :   c = gfc_peek_ascii_char ();
    4567                 :      16105 :   if (c == '(')
    4568                 :            :     {
    4569                 :        408 :       (void) gfc_next_ascii_char ();
    4570                 :        408 :       if (!gfc_notify_std (GFC_STD_F2018, "IMPORT NONE with spec list at %C"))
    4571                 :            :         return MATCH_ERROR;
    4572                 :            : 
    4573                 :        407 :       gfc_gobble_whitespace ();
    4574                 :        407 :       if (gfc_peek_ascii_char () == ')')
    4575                 :            :         {
    4576                 :          1 :           (void) gfc_next_ascii_char ();
    4577                 :          1 :           type = true;
    4578                 :            :         }
    4579                 :            :       else
    4580                 :       1200 :         for(;;)
    4581                 :            :           {
    4582                 :        803 :             m = gfc_match (" %n", name);
    4583                 :        803 :             if (m != MATCH_YES)
    4584                 :            :               return MATCH_ERROR;
    4585                 :            : 
    4586                 :        803 :             if (strcmp (name, "type") == 0)
    4587                 :            :               type = true;
    4588                 :        406 :             else if (strcmp (name, "external") == 0)
    4589                 :            :               external = true;
    4590                 :            :             else
    4591                 :            :               return MATCH_ERROR;
    4592                 :            : 
    4593                 :        803 :             gfc_gobble_whitespace ();
    4594                 :        803 :             c = gfc_next_ascii_char ();
    4595                 :        803 :             if (c == ',')
    4596                 :        397 :               continue;
    4597                 :        406 :             if (c == ')')
    4598                 :            :               break;
    4599                 :            :             return MATCH_ERROR;
    4600                 :            :           }
    4601                 :            :     }
    4602                 :            :   else
    4603                 :            :     type = true;
    4604                 :            : 
    4605                 :      16104 :   if (gfc_match_eos () != MATCH_YES)
    4606                 :            :     return MATCH_ERROR;
    4607                 :            : 
    4608                 :      16104 :   gfc_set_implicit_none (type, external, &cur_loc);
    4609                 :            : 
    4610                 :      16104 :   return MATCH_YES;
    4611                 :            : }
    4612                 :            : 
    4613                 :            : 
    4614                 :            : /* Match the letter range(s) of an IMPLICIT statement.  */
    4615                 :            : 
    4616                 :            : static match
    4617                 :        619 : match_implicit_range (void)
    4618                 :            : {
    4619                 :        619 :   char c, c1, c2;
    4620                 :        619 :   int inner;
    4621                 :        619 :   locus cur_loc;
    4622                 :            : 
    4623                 :        619 :   cur_loc = gfc_current_locus;
    4624                 :            : 
    4625                 :        619 :   gfc_gobble_whitespace ();
    4626                 :        619 :   c = gfc_next_ascii_char ();
    4627                 :        619 :   if (c != '(')
    4628                 :            :     {
    4629                 :         56 :       gfc_error ("Missing character range in IMPLICIT at %C");
    4630                 :         56 :       goto bad;
    4631                 :            :     }
    4632                 :            : 
    4633                 :            :   inner = 1;
    4634                 :       1221 :   while (inner)
    4635                 :            :     {
    4636                 :        737 :       gfc_gobble_whitespace ();
    4637                 :        737 :       c1 = gfc_next_ascii_char ();
    4638                 :        737 :       if (!ISALPHA (c1))
    4639                 :         46 :         goto bad;
    4640                 :            : 
    4641                 :        691 :       gfc_gobble_whitespace ();
    4642                 :        691 :       c = gfc_next_ascii_char ();
    4643                 :            : 
    4644                 :        691 :       switch (c)
    4645                 :            :         {
    4646                 :        198 :         case ')':
    4647                 :        198 :           inner = 0;            /* Fall through.  */
    4648                 :            : 
    4649                 :            :         case ',':
    4650                 :            :           c2 = c1;
    4651                 :            :           break;
    4652                 :            : 
    4653                 :        450 :         case '-':
    4654                 :        450 :           gfc_gobble_whitespace ();
    4655                 :        450 :           c2 = gfc_next_ascii_char ();
    4656                 :        450 :           if (!ISALPHA (c2))
    4657                 :          0 :             goto bad;
    4658                 :            : 
    4659                 :        450 :           gfc_gobble_whitespace ();
    4660                 :        450 :           c = gfc_next_ascii_char ();
    4661                 :            : 
    4662                 :        450 :           if ((c != ',') && (c != ')'))
    4663                 :          0 :             goto bad;
    4664                 :        450 :           if (c == ')')
    4665                 :        286 :             inner = 0;
    4666                 :            : 
    4667                 :            :           break;
    4668                 :            : 
    4669                 :         33 :         default:
    4670                 :         33 :           goto bad;
    4671                 :            :         }
    4672                 :            : 
    4673                 :        658 :       if (c1 > c2)
    4674                 :            :         {
    4675                 :          0 :           gfc_error ("Letters must be in alphabetic order in "
    4676                 :            :                      "IMPLICIT statement at %C");
    4677                 :          0 :           goto bad;
    4678                 :            :         }
    4679                 :            : 
    4680                 :            :       /* See if we can add the newly matched range to the pending
    4681                 :            :          implicits from this IMPLICIT statement.  We do not check for
    4682                 :            :          conflicts with whatever earlier IMPLICIT statements may have
    4683                 :            :          set.  This is done when we've successfully finished matching
    4684                 :            :          the current one.  */
    4685                 :        658 :       if (!gfc_add_new_implicit_range (c1, c2))
    4686                 :          0 :         goto bad;
    4687                 :            :     }
    4688                 :            : 
    4689                 :            :   return MATCH_YES;
    4690                 :            : 
    4691                 :        135 : bad:
    4692                 :        135 :   gfc_syntax_error (ST_IMPLICIT);
    4693                 :            : 
    4694                 :        135 :   gfc_current_locus = cur_loc;
    4695                 :        135 :   return MATCH_ERROR;
    4696                 :            : }
    4697                 :            : 
    4698                 :            : 
    4699                 :            : /* Match an IMPLICIT statement, storing the types for
    4700                 :            :    gfc_set_implicit() if the statement is accepted by the parser.
    4701                 :            :    There is a strange looking, but legal syntactic construction
    4702                 :            :    possible.  It looks like:
    4703                 :            : 
    4704                 :            :      IMPLICIT INTEGER (a-b) (c-d)
    4705                 :            : 
    4706                 :            :    This is legal if "a-b" is a constant expression that happens to
    4707                 :            :    equal one of the legal kinds for integers.  The real problem
    4708                 :            :    happens with an implicit specification that looks like:
    4709                 :            : 
    4710                 :            :      IMPLICIT INTEGER (a-b)
    4711                 :            : 
    4712                 :            :    In this case, a typespec matcher that is "greedy" (as most of the
    4713                 :            :    matchers are) gobbles the character range as a kindspec, leaving
    4714                 :            :    nothing left.  We therefore have to go a bit more slowly in the
    4715                 :            :    matching process by inhibiting the kindspec checking during
    4716                 :            :    typespec matching and checking for a kind later.  */
    4717                 :            : 
    4718                 :            : match
    4719                 :      16542 : gfc_match_implicit (void)
    4720                 :            : {
    4721                 :      16542 :   gfc_typespec ts;
    4722                 :      16542 :   locus cur_loc;
    4723                 :      16542 :   char c;
    4724                 :      16542 :   match m;
    4725                 :            : 
    4726                 :      16542 :   if (gfc_current_ns->seen_implicit_none)
    4727                 :            :     {
    4728                 :          4 :       gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
    4729                 :            :                  "statement");
    4730                 :          4 :       return MATCH_ERROR;
    4731                 :            :     }
    4732                 :            : 
    4733                 :      16538 :   gfc_clear_ts (&ts);
    4734                 :            : 
    4735                 :            :   /* We don't allow empty implicit statements.  */
    4736                 :      16538 :   if (gfc_match_eos () == MATCH_YES)
    4737                 :            :     {
    4738                 :          0 :       gfc_error ("Empty IMPLICIT statement at %C");
    4739                 :          0 :       return MATCH_ERROR;
    4740                 :            :     }
    4741                 :            : 
    4742                 :      16567 :   do
    4743                 :            :     {
    4744                 :            :       /* First cleanup.  */
    4745                 :      16567 :       gfc_clear_new_implicit ();
    4746                 :            : 
    4747                 :            :       /* A basic type is mandatory here.  */
    4748                 :      16567 :       m = gfc_match_decl_type_spec (&ts, 1);
    4749                 :      16567 :       if (m == MATCH_ERROR)
    4750                 :          0 :         goto error;
    4751                 :      16567 :       if (m == MATCH_NO)
    4752                 :      16107 :         goto syntax;
    4753                 :            : 
    4754                 :        460 :       cur_loc = gfc_current_locus;
    4755                 :        460 :       m = match_implicit_range ();
    4756                 :            : 
    4757                 :        460 :       if (m == MATCH_YES)
    4758                 :            :         {
    4759                 :            :           /* We may have <TYPE> (<RANGE>).  */
    4760                 :        325 :           gfc_gobble_whitespace ();
    4761                 :        325 :           c = gfc_peek_ascii_char ();
    4762                 :        325 :           if (c == ',' || c == '\n' || c == ';' || c == '!')
    4763                 :            :             {
    4764                 :            :               /* Check for CHARACTER with no length parameter.  */
    4765                 :        298 :               if (ts.type == BT_CHARACTER && !ts.u.cl)
    4766                 :            :                 {
    4767                 :         31 :                   ts.kind = gfc_default_character_kind;
    4768                 :         31 :                   ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
    4769                 :         31 :                   ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
    4770                 :            :                                                       NULL, 1);
    4771                 :            :                 }
    4772                 :            : 
    4773                 :            :               /* Record the Successful match.  */
    4774                 :        298 :               if (!gfc_merge_new_implicit (&ts))
    4775                 :            :                 return MATCH_ERROR;
    4776                 :        296 :               if (c == ',')
    4777                 :         28 :                 c = gfc_next_ascii_char ();
    4778                 :        268 :               else if (gfc_match_eos () == MATCH_ERROR)
    4779                 :          0 :                 goto error;
    4780                 :        296 :               continue;
    4781                 :            :             }
    4782                 :            : 
    4783                 :         27 :           gfc_current_locus = cur_loc;
    4784                 :            :         }
    4785                 :            : 
    4786                 :            :       /* Discard the (incorrectly) matched range.  */
    4787                 :        162 :       gfc_clear_new_implicit ();
    4788                 :            : 
    4789                 :            :       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
    4790                 :        162 :       if (ts.type == BT_CHARACTER)
    4791                 :         74 :         m = gfc_match_char_spec (&ts);
    4792                 :            :       else
    4793                 :            :         {
    4794                 :         88 :           m = gfc_match_kind_spec (&ts, false);
    4795                 :         88 :           if (m == MATCH_NO)
    4796                 :            :             {
    4797                 :         37 :               m = gfc_match_old_kind_spec (&ts);
    4798                 :         37 :               if (m == MATCH_ERROR)
    4799                 :          0 :                 goto error;
    4800                 :         37 :               if (m == MATCH_NO)
    4801                 :          0 :                 goto syntax;
    4802                 :            :             }
    4803                 :            :         }
    4804                 :        162 :       if (m == MATCH_ERROR)
    4805                 :          3 :         goto error;
    4806                 :            : 
    4807                 :        159 :       m = match_implicit_range ();
    4808                 :        159 :       if (m == MATCH_ERROR)
    4809                 :          0 :         goto error;
    4810                 :        159 :       if (m == MATCH_NO)
    4811                 :          0 :         goto syntax;
    4812                 :            : 
    4813                 :        159 :       gfc_gobble_whitespace ();
    4814                 :        159 :       c = gfc_next_ascii_char ();
    4815                 :        159 :       if (c != ',' && gfc_match_eos () != MATCH_YES)
    4816                 :          0 :         goto syntax;
    4817                 :            : 
    4818                 :        159 :       if (!gfc_merge_new_implicit (&ts))
    4819                 :            :         return MATCH_ERROR;
    4820                 :            :     }
    4821                 :        455 :   while (c == ',');
    4822                 :            : 
    4823                 :            :   return MATCH_YES;
    4824                 :            : 
    4825                 :      16107 : syntax:
    4826                 :      16107 :   gfc_syntax_error (ST_IMPLICIT);
    4827                 :            : 
    4828                 :            : error:
    4829                 :            :   return MATCH_ERROR;
    4830                 :            : }
    4831                 :            : 
    4832                 :            : 
    4833                 :            : match
    4834                 :       2218 : gfc_match_import (void)
    4835                 :            : {
    4836                 :       2218 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    4837                 :       2218 :   match m;
    4838                 :       2218 :   gfc_symbol *sym;
    4839                 :       2218 :   gfc_symtree *st;
    4840                 :            : 
    4841                 :       2218 :   if (gfc_current_ns->proc_name == NULL
    4842                 :       2217 :       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
    4843                 :            :     {
    4844                 :          3 :       gfc_error ("IMPORT statement at %C only permitted in "
    4845                 :            :                  "an INTERFACE body");
    4846                 :          3 :       return MATCH_ERROR;
    4847                 :            :     }
    4848                 :            : 
    4849                 :       2215 :   if (gfc_current_ns->proc_name->attr.module_procedure)
    4850                 :            :     {
    4851                 :          1 :       gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
    4852                 :            :                  "in a module procedure interface body");
    4853                 :          1 :       return MATCH_ERROR;
    4854                 :            :     }
    4855                 :            : 
    4856                 :       2214 :   if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
    4857                 :            :     return MATCH_ERROR;
    4858                 :            : 
    4859                 :       2210 :   if (gfc_match_eos () == MATCH_YES)
    4860                 :            :     {
    4861                 :            :       /* All host variables should be imported.  */
    4862                 :        163 :       gfc_current_ns->has_import_set = 1;
    4863                 :        163 :       return MATCH_YES;
    4864                 :            :     }
    4865                 :            : 
    4866                 :       2047 :   if (gfc_match (" ::") == MATCH_YES)
    4867                 :            :     {
    4868                 :        202 :       if (gfc_match_eos () == MATCH_YES)
    4869                 :            :         {
    4870                 :          1 :            gfc_error ("Expecting list of named entities at %C");
    4871                 :          1 :            return MATCH_ERROR;
    4872                 :            :         }
    4873                 :            :     }
    4874                 :            : 
    4875                 :       2233 :   for(;;)
    4876                 :            :     {
    4877                 :       2233 :       sym = NULL;
    4878                 :       2233 :       m = gfc_match (" %n", name);
    4879                 :       2233 :       switch (m)
    4880                 :            :         {
    4881                 :       2233 :         case MATCH_YES:
    4882                 :       2233 :           if (gfc_current_ns->parent !=  NULL
    4883                 :       2233 :               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
    4884                 :            :             {
    4885                 :          0 :                gfc_error ("Type name %qs at %C is ambiguous", name);
    4886                 :          0 :                return MATCH_ERROR;
    4887                 :            :             }
    4888                 :          1 :           else if (!sym && gfc_current_ns->proc_name->ns->parent !=  NULL
    4889                 :       2233 :                    && gfc_find_symbol (name,
    4890                 :            :                                        gfc_current_ns->proc_name->ns->parent,
    4891                 :            :                                        1, &sym))
    4892                 :            :             {
    4893                 :          0 :                gfc_error ("Type name %qs at %C is ambiguous", name);
    4894                 :          0 :                return MATCH_ERROR;
    4895                 :            :             }
    4896                 :            : 
    4897                 :       2233 :           if (sym == NULL)
    4898                 :            :             {
    4899                 :          1 :               gfc_error ("Cannot IMPORT %qs from host scoping unit "
    4900                 :            :                          "at %C - does not exist.", name);
    4901                 :          1 :               return MATCH_ERROR;
    4902                 :            :             }
    4903                 :            : 
    4904                 :       2232 :           if (gfc_find_symtree (gfc_current_ns->sym_root, name))
    4905                 :            :             {
    4906                 :          6 :               gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
    4907                 :            :                            "at %C", name);
    4908                 :          6 :               goto next_item;
    4909                 :            :             }
    4910                 :            : 
    4911                 :       2226 :           st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
    4912                 :       2226 :           st->n.sym = sym;
    4913                 :       2226 :           sym->refs++;
    4914                 :       2226 :           sym->attr.imported = 1;
    4915                 :            : 
    4916                 :       2226 :           if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
    4917                 :            :             {
    4918                 :            :               /* The actual derived type is stored in a symtree with the first
    4919                 :            :                  letter of the name capitalized; the symtree with the all
    4920                 :            :                  lower-case name contains the associated generic function.  */
    4921                 :        297 :               st = gfc_new_symtree (&gfc_current_ns->sym_root,
    4922                 :            :                                     gfc_dt_upper_string (name));
    4923                 :        297 :               st->n.sym = sym;
    4924                 :        297 :               sym->refs++;
    4925                 :        297 :               sym->attr.imported = 1;
    4926                 :            :             }
    4927                 :            : 
    4928                 :       2226 :           goto next_item;
    4929                 :            : 
    4930                 :            :         case MATCH_NO:
    4931                 :            :           break;
    4932                 :            : 
    4933                 :            :         case MATCH_ERROR:
    4934                 :            :           return MATCH_ERROR;
    4935                 :            :         }
    4936                 :            : 
    4937                 :       2232 :     next_item:
    4938                 :       2232 :       if (gfc_match_eos () == MATCH_YES)
    4939                 :            :         break;
    4940                 :        187 :       if (gfc_match_char (',') != MATCH_YES)
    4941                 :          0 :         goto syntax;
    4942                 :            :     }
    4943                 :            : 
    4944                 :            :   return MATCH_YES;
    4945                 :            : 
    4946                 :          0 : syntax:
    4947                 :          0 :   gfc_error ("Syntax error in IMPORT statement at %C");
    4948                 :          0 :   return MATCH_ERROR;
    4949                 :            : }
    4950                 :            : 
    4951                 :            : 
    4952                 :            : /* A minimal implementation of gfc_match without whitespace, escape
    4953                 :            :    characters or variable arguments.  Returns true if the next
    4954                 :            :    characters match the TARGET template exactly.  */
    4955                 :            : 
    4956                 :            : static bool
    4957                 :          0 : match_string_p (const char *target)
    4958                 :            : {
    4959                 :          0 :   const char *p;
    4960                 :            : 
    4961                 :     500787 :   for (p = target; *p; p++)
    4962                 :     500788 :     if ((char) gfc_next_ascii_char () != *p)
    4963                 :            :       return false;
    4964                 :            :   return true;
    4965                 :            : }
    4966                 :            : 
    4967                 :            : /* Matches an attribute specification including array specs.  If
    4968                 :            :    successful, leaves the variables current_attr and current_as
    4969                 :            :    holding the specification.  Also sets the colon_seen variable for
    4970                 :            :    later use by matchers associated with initializations.
    4971                 :            : 
    4972                 :            :    This subroutine is a little tricky in the sense that we don't know
    4973                 :            :    if we really have an attr-spec until we hit the double colon.
    4974                 :            :    Until that time, we can only return MATCH_NO.  This forces us to
    4975                 :            :    check for duplicate specification at this level.  */
    4976                 :            : 
    4977                 :            : static match
    4978                 :     140293 : match_attr_spec (void)
    4979                 :            : {
    4980                 :            :   /* Modifiers that can exist in a type statement.  */
    4981                 :     140293 :   enum
    4982                 :            :   { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
    4983                 :            :     DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
    4984                 :            :     DECL_DIMENSION, DECL_EXTERNAL,
    4985                 :            :     DECL_INTRINSIC, DECL_OPTIONAL,
    4986                 :            :     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
    4987                 :            :     DECL_STATIC, DECL_AUTOMATIC,
    4988                 :            :     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
    4989                 :            :     DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
    4990                 :            :     DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
    4991                 :            :   };
    4992                 :            : 
    4993                 :            : /* GFC_DECL_END is the sentinel, index starts at 0.  */
    4994                 :            : #define NUM_DECL GFC_DECL_END
    4995                 :            : 
    4996                 :            :   /* Make sure that values from sym_intent are safe to be used here.  */
    4997                 :     140293 :   gcc_assert (INTENT_IN > 0);
    4998                 :            : 
    4999                 :     140293 :   locus start, seen_at[NUM_DECL];
    5000                 :     140293 :   int seen[NUM_DECL];
    5001                 :     140293 :   unsigned int d;
    5002                 :     140293 :   const char *attr;
    5003                 :     140293 :   match m;
    5004                 :     140293 :   bool t;
    5005                 :            : 
    5006                 :     140293 :   gfc_clear_attr (&current_attr);
    5007                 :     140293 :   start = gfc_current_locus;
    5008                 :            : 
    5009                 :     140293 :   current_as = NULL;
    5010                 :     140293 :   colon_seen = 0;
    5011                 :     140293 :   attr_seen = 0;
    5012                 :            : 
    5013                 :            :   /* See if we get all of the keywords up to the final double colon.  */
    5014                 :    3787910 :   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
    5015                 :    3647620 :     seen[d] = 0;
    5016                 :            : 
    5017                 :     214019 :   for (;;)
    5018                 :            :     {
    5019                 :     214019 :       char ch;
    5020                 :            : 
    5021                 :     214019 :       d = DECL_NONE;
    5022                 :     214019 :       gfc_gobble_whitespace ();
    5023                 :            : 
    5024                 :     214019 :       ch = gfc_next_ascii_char ();
    5025                 :     214019 :       if (ch == ':')
    5026                 :            :         {
    5027                 :            :           /* This is the successful exit condition for the loop.  */
    5028                 :     115491 :           if (gfc_next_ascii_char () == ':')
    5029                 :            :             break;
    5030                 :            :         }
    5031                 :      98528 :       else if (ch == ',')
    5032                 :            :         {
    5033                 :      73738 :           gfc_gobble_whitespace ();
    5034                 :      73738 :           switch (gfc_peek_ascii_char ())
    5035                 :            :             {
    5036                 :      10412 :             case 'a':
    5037                 :      10412 :               gfc_next_ascii_char ();
    5038                 :      10412 :               switch (gfc_next_ascii_char ())
    5039                 :            :                 {
    5040                 :            :                 case 'l':
    5041                 :     103520 :                   if (match_string_p ("locatable"))
    5042                 :            :                     {
    5043                 :            :                       /* Matched "allocatable".  */
    5044                 :            :                       d = DECL_ALLOCATABLE;
    5045                 :            :                     }
    5046                 :            :                   break;
    5047                 :            : 
    5048                 :            :                 case 's':
    5049                 :        220 :                   if (match_string_p ("ynchronous"))
    5050                 :            :                     {
    5051                 :            :                       /* Matched "asynchronous".  */
    5052                 :            :                       d = DECL_ASYNCHRONOUS;
    5053                 :            :                     }
    5054                 :            :                   break;
    5055                 :            : 
    5056                 :            :                 case 'u':
    5057                 :        320 :                   if (match_string_p ("tomatic"))
    5058                 :            :                     {
    5059                 :            :                       /* Matched "automatic".  */
    5060                 :            :                       d = DECL_AUTOMATIC;
    5061                 :            :                     }
    5062                 :            :                   break;
    5063                 :            :                 }
    5064                 :            :               break;
    5065                 :            : 
    5066                 :        136 :             case 'b':
    5067                 :            :               /* Try and match the bind(c).  */
    5068                 :        136 :               m = gfc_match_bind_c (NULL, true);
    5069                 :        136 :               if (m == MATCH_YES)
    5070                 :            :                 d = DECL_IS_BIND_C;
    5071                 :          0 :               else if (m == MATCH_ERROR)
    5072                 :          0 :                 goto cleanup;
    5073                 :            :               break;
    5074                 :            : 
    5075                 :       1315 :             case 'c':
    5076                 :       1315 :               gfc_next_ascii_char ();
    5077                 :       1315 :               if ('o' != gfc_next_ascii_char ())
    5078                 :            :                 break;
    5079                 :       1314 :               switch (gfc_next_ascii_char ())
    5080                 :            :                 {
    5081                 :            :                 case 'd':
    5082                 :        360 :                   if (match_string_p ("imension"))
    5083                 :            :                     {
    5084                 :            :                       d = DECL_CODIMENSION;
    5085                 :            :                       break;
    5086                 :            :                     }
    5087                 :            :                   /* FALLTHRU */
    5088                 :            :                 case 'n':
    5089                 :      10192 :                   if (match_string_p ("tiguous"))
    5090                 :            :                     {
    5091                 :            :                       d = DECL_CONTIGUOUS;
    5092                 :            :                       break;
    5093                 :            :                     }
    5094                 :            :                 }
    5095                 :            :               break;
    5096                 :            : 
    5097                 :            :             case 'd':
    5098                 :     165780 :               if (match_string_p ("dimension"))
    5099                 :            :                 d = DECL_DIMENSION;
    5100                 :            :               break;
    5101                 :            : 
    5102                 :            :             case 'e':
    5103                 :       1269 :               if (match_string_p ("external"))
    5104                 :            :                 d = DECL_EXTERNAL;
    5105                 :            :               break;
    5106                 :            : 
    5107                 :            :             case 'i':
    5108                 :      68744 :               if (match_string_p ("int"))
    5109                 :            :                 {
    5110                 :      17186 :                   ch = gfc_next_ascii_char ();
    5111                 :      17186 :                   if (ch == 'e')
    5112                 :            :                     {
    5113                 :      51543 :                       if (match_string_p ("nt"))
    5114                 :            :                         {
    5115                 :            :                           /* Matched "intent".  */
    5116                 :      17180 :                           d = match_intent_spec ();
    5117                 :      17180 :                           if (d == INTENT_UNKNOWN)
    5118                 :            :                             {
    5119                 :          2 :                               m = MATCH_ERROR;
    5120                 :          2 :                               goto cleanup;
    5121                 :            :                             }
    5122                 :            :                         }
    5123                 :            :                     }
    5124                 :          5 :                   else if (ch == 'r')
    5125                 :            :                     {
    5126                 :         30 :                       if (match_string_p ("insic"))
    5127                 :            :                         {
    5128                 :            :                           /* Matched "intrinsic".  */
    5129                 :            :                           d = DECL_INTRINSIC;
    5130                 :            :                         }
    5131                 :            :                     }
    5132                 :            :                 }
    5133                 :            :               break;
    5134                 :            : 
    5135                 :            :             case 'k':
    5136                 :        605 :               if (match_string_p ("kind"))
    5137                 :            :                 d = DECL_KIND;
    5138                 :            :               break;
    5139                 :            : 
    5140                 :            :             case 'l':
    5141                 :        580 :               if (match_string_p ("len"))
    5142                 :            :                 d = DECL_LEN;
    5143                 :            :               break;
    5144                 :            : 
    5145                 :            :             case 'o':
    5146                 :      21996 :               if (match_string_p ("optional"))
    5147                 :            :                 d = DECL_OPTIONAL;
    5148                 :            :               break;
    5149                 :            : 
    5150                 :      17884 :             case 'p':
    5151                 :      17884 :               gfc_next_ascii_char ();
    5152                 :      17884 :               switch (gfc_next_ascii_char ())
    5153                 :            :                 {
    5154                 :            :                 case 'a':
    5155                 :      76720 :                   if (match_string_p ("rameter"))
    5156                 :            :                     {
    5157                 :            :                       /* Matched "parameter".  */
    5158                 :            :                       d = DECL_PARAMETER;
    5159                 :            :                     }
    5160                 :            :                   break;
    5161                 :            : 
    5162                 :            :                 case 'o':
    5163                 :      47346 :                   if (match_string_p ("inter"))
    5164                 :            :                     {
    5165                 :            :                       /* Matched "pointer".  */
    5166                 :            :                       d = DECL_POINTER;
    5167                 :            :                     }
    5168                 :            :                   break;
    5169                 :            : 
    5170                 :        209 :                 case 'r':
    5171                 :        209 :                   ch = gfc_next_ascii_char ();
    5172                 :        209 :                   if (ch == 'i')
    5173                 :            :                     {
    5174                 :        845 :                       if (match_string_p ("vate"))
    5175                 :            :                         {
    5176                 :            :                           /* Matched "private".  */
    5177                 :            :                           d = DECL_PRIVATE;
    5178                 :            :                         }
    5179                 :            :                     }
    5180                 :         40 :                   else if (ch == 'o')
    5181                 :            :                     {
    5182                 :        280 :                       if (match_string_p ("tected"))
    5183                 :            :                         {
    5184                 :            :                           /* Matched "protected".  */
    5185                 :            :                           d = DECL_PROTECTED;
    5186                 :            :                         }
    5187                 :            :                     }
    5188                 :            :                   break;
    5189                 :            : 
    5190                 :            :                 case 'u':
    5191                 :        970 :                   if (match_string_p ("blic"))
    5192                 :            :                     {
    5193                 :            :                       /* Matched "public".  */
    5194                 :            :                       d = DECL_PUBLIC;
    5195                 :            :                     }
    5196                 :            :                   break;
    5197                 :            :                 }
    5198                 :            :               break;
    5199                 :            : 
    5200                 :       1039 :             case 's':
    5201                 :       1039 :               gfc_next_ascii_char ();
    5202                 :       1039 :               switch (gfc_next_ascii_char ())
    5203                 :            :                 {
    5204                 :            :                   case 'a':
    5205                 :       3081 :                     if (match_string_p ("ve"))
    5206                 :            :                       {
    5207                 :            :                         /* Matched "save".  */
    5208                 :            :                         d = DECL_SAVE;
    5209                 :            :                       }
    5210                 :            :                     break;
    5211                 :            : 
    5212                 :            :                   case 't':
    5213                 :         60 :                     if (match_string_p ("atic"))
    5214                 :            :                       {
    5215                 :            :                         /* Matched "static".  */
    5216                 :            :                         d = DECL_STATIC;
    5217                 :            :                       }
    5218                 :            :                     break;
    5219                 :            :                 }
    5220                 :            :               break;
    5221                 :            : 
    5222                 :            :             case 't':
    5223                 :      24759 :               if (match_string_p ("target"))
    5224                 :            :                 d = DECL_TARGET;
    5225                 :            :               break;
    5226                 :            : 
    5227                 :       2800 :             case 'v':
    5228                 :       2800 :               gfc_next_ascii_char ();
    5229                 :       2800 :               ch = gfc_next_ascii_char ();
    5230                 :       2800 :               if (ch == 'a')
    5231                 :            :                 {
    5232                 :       9660 :                   if (match_string_p ("lue"))
    5233                 :            :                     {
    5234                 :            :                       /* Matched "value".  */
    5235                 :            :                       d = DECL_VALUE;
    5236                 :            :                     }
    5237                 :            :                 }
    5238                 :        385 :               else if (ch == 'o')
    5239                 :            :                 {
    5240                 :       2695 :                   if (match_string_p ("latile"))
    5241                 :            :                     {
    5242                 :            :                       /* Matched "volatile".  */
    5243                 :            :                       d = DECL_VOLATILE;
    5244                 :            :                     }
    5245                 :            :                 }
    5246                 :            :               break;
    5247                 :            :             }
    5248                 :            :         }
    5249                 :            : 
    5250                 :            :       /* No double colon and no recognizable decl_type, so assume that
    5251                 :            :          we've been looking at something else the whole time.  */
    5252                 :      33938 :       if (d == DECL_NONE)
    5253                 :            :         {
    5254                 :      24793 :           m = MATCH_NO;
    5255                 :      24793 :           goto cleanup;
    5256                 :            :         }
    5257                 :            : 
    5258                 :            :       /* Check to make sure any parens are paired up correctly.  */
    5259                 :      73734 :       if (gfc_match_parens () == MATCH_ERROR)
    5260                 :            :         {
    5261                 :          1 :           m = MATCH_ERROR;
    5262                 :          1 :           goto cleanup;
    5263                 :            :         }
    5264                 :            : 
    5265                 :      73733 :       seen[d]++;
    5266                 :      73733 :       seen_at[d] = gfc_current_locus;
    5267                 :            : 
    5268                 :      73733 :       if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
    5269                 :            :         {
    5270                 :      16617 :           gfc_array_spec *as = NULL;
    5271                 :            : 
    5272                 :      16617 :           m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
    5273                 :            :                                     d == DECL_CODIMENSION);
    5274                 :            : 
    5275                 :      16617 :           if (current_as == NULL)
    5276                 :      16601 :             current_as = as;
    5277                 :         16 :           else if (m == MATCH_YES)
    5278                 :            :             {
    5279                 :         16 :               if (!merge_array_spec (as, current_as, false))
    5280                 :          2 :                 m = MATCH_ERROR;
    5281                 :         16 :               free (as);
    5282                 :            :             }
    5283                 :            : 
    5284                 :      16617 :           if (m == MATCH_NO)
    5285                 :            :             {
    5286                 :          0 :               if (d == DECL_CODIMENSION)
    5287                 :          0 :                 gfc_error ("Missing codimension specification at %C");
    5288                 :            :               else
    5289                 :          0 :                 gfc_error ("Missing dimension specification at %C");
    5290                 :            :               m = MATCH_ERROR;
    5291                 :            :             }
    5292                 :            : 
    5293                 :      16617 :           if (m == MATCH_ERROR)
    5294                 :          7 :             goto cleanup;
    5295                 :            :         }
    5296                 :            :     }
    5297                 :            : 
    5298                 :            :   /* Since we've seen a double colon, we have to be looking at an
    5299                 :            :      attr-spec.  This means that we can now issue errors.  */
    5300                 :    3118210 :   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
    5301                 :    3002720 :     if (seen[d] > 1)
    5302                 :            :       {
    5303                 :          2 :         switch (d)
    5304                 :            :           {
    5305                 :            :           case DECL_ALLOCATABLE:
    5306                 :            :             attr = "ALLOCATABLE";
    5307                 :            :             break;
    5308                 :          0 :           case DECL_ASYNCHRONOUS:
    5309                 :          0 :             attr = "ASYNCHRONOUS";
    5310                 :          0 :             break;
    5311                 :          0 :           case DECL_CODIMENSION:
    5312                 :          0 :             attr = "CODIMENSION";
    5313                 :          0 :             break;
    5314                 :          0 :           case DECL_CONTIGUOUS:
    5315                 :          0 :             attr = "CONTIGUOUS";
    5316                 :          0 :             break;
    5317                 :          0 :           case DECL_DIMENSION:
    5318                 :          0 :             attr = "DIMENSION";
    5319                 :          0 :             break;
    5320                 :          0 :           case DECL_EXTERNAL:
    5321                 :          0 :             attr = "EXTERNAL";
    5322                 :          0 :             break;
    5323                 :          0 :           case DECL_IN:
    5324                 :          0 :             attr = "INTENT (IN)";
    5325                 :          0 :             break;
    5326                 :          0 :           case DECL_OUT:
    5327                 :          0 :             attr = "INTENT (OUT)";
    5328                 :          0 :             break;
    5329                 :          0 :           case DECL_INOUT:
    5330                 :          0 :             attr = "INTENT (IN OUT)";
    5331                 :          0 :             break;
    5332                 :          0 :           case DECL_INTRINSIC:
    5333                 :          0 :             attr = "INTRINSIC";
    5334                 :          0 :             break;
    5335                 :          0 :           case DECL_OPTIONAL:
    5336                 :          0 :             attr = "OPTIONAL";
    5337                 :          0 :             break;
    5338                 :          0 :           case DECL_KIND:
    5339                 :          0 :             attr = "KIND";
    5340                 :          0 :             break;
    5341                 :          0 :           case DECL_LEN:
    5342                 :          0 :             attr = "LEN";
    5343                 :          0 :             break;
    5344                 :          0 :           case DECL_PARAMETER:
    5345                 :          0 :             attr = "PARAMETER";
    5346                 :          0 :             break;
    5347                 :          0 :           case DECL_POINTER:
    5348                 :          0 :             attr = "POINTER";
    5349                 :          0 :             break;
    5350                 :          0 :           case DECL_PROTECTED:
    5351                 :          0 :             attr = "PROTECTED";
    5352                 :          0 :             break;
    5353                 :          0 :           case DECL_PRIVATE:
    5354                 :          0 :             attr = "PRIVATE";
    5355                 :          0 :             break;
    5356                 :          0 :           case DECL_PUBLIC:
    5357                 :          0 :             attr = "PUBLIC";
    5358                 :          0 :             break;
    5359                 :          0 :           case DECL_SAVE:
    5360                 :          0 :             attr = "SAVE";
    5361                 :          0 :             break;
    5362                 :          0 :           case DECL_STATIC:
    5363                 :          0 :             attr = "STATIC";
    5364                 :          0 :             break;
    5365                 :          1 :           case DECL_AUTOMATIC:
    5366                 :          1 :             attr = "AUTOMATIC";
    5367                 :          1 :             break;
    5368                 :          0 :           case DECL_TARGET:
    5369                 :          0 :             attr = "TARGET";
    5370                 :          0 :             break;
    5371                 :          0 :           case DECL_IS_BIND_C:
    5372                 :          0 :             attr = "IS_BIND_C";
    5373                 :          0 :             break;
    5374                 :          0 :           case DECL_VALUE:
    5375                 :          0 :             attr = "VALUE";
    5376                 :          0 :             break;
    5377                 :          1 :           case DECL_VOLATILE:
    5378                 :          1 :             attr = "VOLATILE";
    5379                 :          1 :             break;
    5380                 :          0 :           default:
    5381                 :          0 :             attr = NULL;        /* This shouldn't happen.  */
    5382                 :            :           }
    5383                 :            : 
    5384                 :          2 :         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
    5385                 :          2 :         m = MATCH_ERROR;
    5386                 :          2 :         goto cleanup;
    5387                 :            :       }
    5388                 :            : 
    5389                 :            :   /* Now that we've dealt with duplicate attributes, add the attributes
    5390                 :            :      to the current attribute.  */
    5391                 :    3117680 :   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
    5392                 :            :     {
    5393                 :    3002240 :       if (seen[d] == 0)
    5394                 :    2928520 :         continue;
    5395                 :            :       else
    5396                 :      73718 :         attr_seen = 1;
    5397                 :            : 
    5398                 :      73718 :       if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
    5399                 :         50 :           && !flag_dec_static)
    5400                 :            :         {
    5401                 :          3 :           gfc_error ("%s at %L is a DEC extension, enable with "
    5402                 :            :                      "%<-fdec-static%>",
    5403                 :            :                      d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
    5404                 :          2 :           m = MATCH_ERROR;
    5405                 :          2 :           goto cleanup;
    5406                 :            :         }
    5407                 :            :       /* Allow SAVE with STATIC, but don't complain.  */
    5408                 :      73716 :       if (d == DECL_STATIC && seen[DECL_SAVE])
    5409                 :          0 :         continue;
    5410                 :            : 
    5411                 :      73716 :       if (gfc_current_state () == COMP_DERIVED
    5412                 :       4750 :           && d != DECL_DIMENSION && d != DECL_CODIMENSION
    5413                 :       3929 :           && d != DECL_POINTER   && d != DECL_PRIVATE
    5414                 :       2758 :           && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
    5415                 :            :         {
    5416                 :       2718 :           if (d == DECL_ALLOCATABLE)
    5417                 :            :             {
    5418                 :       2454 :               if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
    5419                 :            :                                    "attribute at %C in a TYPE definition"))
    5420                 :            :                 {
    5421                 :          2 :                   m = MATCH_ERROR;
    5422                 :          2 :                   goto cleanup;
    5423                 :            :                 }
    5424                 :            :             }
    5425                 :        264 :           else if (d == DECL_KIND)
    5426                 :            :             {
    5427                 :        120 :               if (!gfc_notify_std (GFC_STD_F2003, "KIND "
    5428                 :            :                                    "attribute at %C in a TYPE definition"))
    5429                 :            :                 {
    5430                 :          0 :                   m = MATCH_ERROR;
    5431                 :          0 :                   goto cleanup;
    5432                 :            :                 }
    5433                 :        120 :               if (current_ts.type != BT_INTEGER)
    5434                 :            :                 {
    5435                 :          2 :                   gfc_error ("Component with KIND attribute at %C must be "
    5436                 :            :                              "INTEGER");
    5437                 :          2 :                   m = MATCH_ERROR;
    5438                 :          2 :                   goto cleanup;
    5439                 :            :                 }
    5440                 :        118 :               if (current_ts.kind != gfc_default_integer_kind)
    5441                 :            :                 {
    5442                 :          1 :                   gfc_error ("Component with KIND attribute at %C must be "
    5443                 :            :                              "default integer kind (%d)",
    5444                 :            :                               gfc_default_integer_kind);
    5445                 :          1 :                   m = MATCH_ERROR;
    5446                 :          1 :                   goto cleanup;
    5447                 :            :                 }
    5448                 :            :             }
    5449                 :        144 :           else if (d == DECL_LEN)
    5450                 :            :             {
    5451                 :        144 :               if (!gfc_notify_std (GFC_STD_F2003, "LEN "
    5452                 :            :                                    "attribute at %C in a TYPE definition"))
    5453                 :            :                 {
    5454                 :          0 :                   m = MATCH_ERROR;
    5455                 :          0 :                   goto cleanup;
    5456                 :            :                 }
    5457                 :        144 :               if (current_ts.type != BT_INTEGER)
    5458                 :            :                 {
    5459                 :          1 :                   gfc_error ("Component with LEN attribute at %C must be "
    5460                 :            :                              "INTEGER");
    5461                 :          1 :                   m = MATCH_ERROR;
    5462                 :          1 :                   goto cleanup;
    5463                 :            :                 }
    5464                 :        143 :               if (current_ts.kind != gfc_default_integer_kind)
    5465                 :            :                 {
    5466                 :          1 :                   gfc_error ("Component with LEN attribute at %C must be "
    5467                 :            :                              "default integer kind (%d)",
    5468                 :            :                               gfc_default_integer_kind);
    5469                 :          1 :                   m = MATCH_ERROR;
    5470                 :          1 :                   goto cleanup;
    5471                 :            :                 }
    5472                 :            :             }
    5473                 :            :           else
    5474                 :            :             {
    5475                 :          0 :               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
    5476                 :            :                          &seen_at[d]);
    5477                 :          0 :               m = MATCH_ERROR;
    5478                 :          0 :               goto cleanup;
    5479                 :            :             }
    5480                 :            :         }
    5481                 :            : 
    5482                 :      73709 :       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
    5483                 :        363 :           && gfc_current_state () != COMP_MODULE)
    5484                 :            :         {
    5485                 :         93 :           if (d == DECL_PRIVATE)
    5486                 :            :             attr = "PRIVATE";
    5487                 :            :           else
    5488                 :         29 :             attr = "PUBLIC";
    5489                 :         93 :           if (gfc_current_state () == COMP_DERIVED
    5490                 :         89 :               && gfc_state_stack->previous
    5491                 :         89 :               && gfc_state_stack->previous->state == COMP_MODULE)
    5492                 :            :             {
    5493                 :         86 :               if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
    5494                 :            :                                    "at %L in a TYPE definition", attr,
    5495                 :            :                                    &seen_at[d]))
    5496                 :            :                 {
    5497                 :          2 :                   m = MATCH_ERROR;
    5498                 :          2 :                   goto cleanup;
    5499                 :            :                 }
    5500                 :            :             }
    5501                 :            :           else
    5502                 :            :             {
    5503                 :          7 :               gfc_error ("%s attribute at %L is not allowed outside of the "
    5504                 :            :                          "specification part of a module", attr, &seen_at[d]);
    5505                 :          7 :               m = MATCH_ERROR;
    5506                 :          7 :               goto cleanup;
    5507                 :            :             }
    5508                 :            :         }
    5509                 :            : 
    5510                 :      73700 :       if (gfc_current_state () != COMP_DERIVED
    5511                 :      68962 :           && (d == DECL_KIND || d == DECL_LEN))
    5512                 :            :         {
    5513                 :          2 :           gfc_error ("Attribute at %L is not allowed outside a TYPE "
    5514                 :            :                      "definition", &seen_at[d]);
    5515                 :          2 :           m = MATCH_ERROR;
    5516                 :          2 :           goto cleanup;
    5517                 :            :         }
    5518                 :            : 
    5519                 :      73698 :       switch (d)
    5520                 :            :         {
    5521                 :      10350 :         case DECL_ALLOCATABLE:
    5522                 :      10350 :           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
    5523                 :      10350 :           break;
    5524                 :            : 
    5525                 :         20 :         case DECL_ASYNCHRONOUS:
    5526                 :         20 :           if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
    5527                 :            :             t = false;
    5528                 :            :           else
    5529                 :         20 :             t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
    5530                 :            :           break;
    5531                 :            : 
    5532                 :         38 :         case DECL_CODIMENSION:
    5533                 :         38 :           t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
    5534                 :         38 :           break;
    5535                 :            : 
    5536                 :       1274 :         case DECL_CONTIGUOUS:
    5537                 :       1274 :           if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
    5538                 :            :             t = false;
    5539                 :            :           else
    5540                 :       1273 :             t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
    5541                 :            :           break;
    5542                 :            : 
    5543                 :      16570 :         case DECL_DIMENSION:
    5544                 :      16570 :           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
    5545                 :      16570 :           break;
    5546                 :            : 
    5547                 :        141 :         case DECL_EXTERNAL:
    5548                 :        141 :           t = gfc_add_external (&current_attr, &seen_at[d]);
    5549                 :        141 :           break;
    5550                 :            : 
    5551                 :      12767 :         case DECL_IN:
    5552                 :      12767 :           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
    5553                 :      12767 :           break;
    5554                 :            : 
    5555                 :       2225 :         case DECL_OUT:
    5556                 :       2225 :           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
    5557                 :       2225 :           break;
    5558                 :            : 
    5559                 :       2185 :         case DECL_INOUT:
    5560                 :       2185 :           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
    5561                 :       2185 :           break;
    5562                 :            : 
    5563                 :          5 :         case DECL_INTRINSIC:
    5564                 :          5 :           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
    5565                 :          5 :           break;
    5566                 :            : 
    5567                 :       2444 :         case DECL_OPTIONAL:
    5568                 :       2444 :           t = gfc_add_optional (&current_attr, &seen_at[d]);
    5569                 :       2444 :           break;
    5570                 :            : 
    5571                 :        117 :         case DECL_KIND:
    5572                 :        117 :           t = gfc_add_kind (&current_attr, &seen_at[d]);
    5573                 :        117 :           break;
    5574                 :            : 
    5575                 :        142 :         case DECL_LEN:
    5576                 :        142 :           t = gfc_add_len (&current_attr, &seen_at[d]);
    5577                 :        142 :           break;
    5578                 :            : 
    5579                 :       9590 :         case DECL_PARAMETER:
    5580                 :       9590 :           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
    5581                 :       9590 :           break;
    5582                 :            : 
    5583                 :       7891 :         case DECL_POINTER:
    5584                 :       7891 :           t = gfc_add_pointer (&current_attr, &seen_at[d]);
    5585                 :       7891 :           break;
    5586                 :            : 
    5587                 :         40 :         case DECL_PROTECTED:
    5588                 :         40 :           if (gfc_current_state () != COMP_MODULE
    5589                 :         38 :               || (gfc_current_ns->proc_name
    5590                 :         38 :                   && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
    5591                 :            :             {
    5592                 :          2 :                gfc_error ("PROTECTED at %C only allowed in specification "
    5593                 :            :                           "part of a module");
    5594                 :          2 :                t = false;
    5595                 :          2 :                break;
    5596                 :            :             }
    5597                 :            : 
    5598                 :         38 :           if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
    5599                 :            :             t = false;
    5600                 :            :           else
    5601                 :         35 :             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
    5602                 :            :           break;
    5603                 :            : 
    5604                 :        167 :         case DECL_PRIVATE:
    5605                 :        167 :           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
    5606                 :            :                               &seen_at[d]);
    5607                 :        167 :           break;
    5608                 :            : 
    5609                 :        187 :         case DECL_PUBLIC:
    5610                 :        187 :           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
    5611                 :            :                               &seen_at[d]);
    5612                 :        187 :           break;
    5613                 :            : 
    5614                 :       1038 :         case DECL_STATIC:
    5615                 :       1038 :         case DECL_SAVE:
    5616                 :       1038 :           t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
    5617                 :       1038 :           break;
    5618                 :            : 
    5619                 :         37 :         case DECL_AUTOMATIC:
    5620                 :         37 :           t = gfc_add_automatic (&current_attr, NULL, &seen_at[d]);
    5621                 :         37 :           break;
    5622                 :            : 
    5623                 :       3536 :         case DECL_TARGET:
    5624                 :       3536 :           t = gfc_add_target (&current_attr, &seen_at[d]);
    5625                 :       3536 :           break;
    5626                 :            : 
    5627                 :        136 :         case DECL_IS_BIND_C:
    5628                 :        136 :            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
    5629                 :        136 :            break;
    5630                 :            : 
    5631                 :       2415 :         case DECL_VALUE:
    5632                 :       2415 :           if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
    5633                 :            :             t = false;
    5634                 :            :           else
    5635                 :       2415 :             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
    5636                 :            :           break;
    5637                 :            : 
    5638                 :        383 :         case DECL_VOLATILE:
    5639                 :        383 :           if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
    5640                 :            :             t = false;
    5641                 :            :           else
    5642                 :        382 :             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
    5643                 :            :           break;
    5644                 :            : 
    5645                 :          0 :         default:
    5646                 :          0 :           gfc_internal_error ("match_attr_spec(): Bad attribute");
    5647                 :            :         }
    5648                 :            : 
    5649                 :      73693 :       if (!t)
    5650                 :            :         {
    5651                 :         32 :           m = MATCH_ERROR;
    5652                 :         32 :           goto cleanup;
    5653                 :            :         }
    5654                 :            :     }
    5655                 :            : 
    5656                 :            :   /* Since Fortran 2008 module variables implicitly have the SAVE attribute.  */
    5657                 :     115436 :   if ((gfc_current_state () == COMP_MODULE
    5658                 :     115436 :        || gfc_current_state () == COMP_SUBMODULE)
    5659                 :       3353 :       && !current_attr.save
    5660                 :       3188 :       && (gfc_option.allow_std & GFC_STD_F2008) != 0)
    5661                 :       3096 :     current_attr.save = SAVE_IMPLICIT;
    5662                 :            : 
    5663                 :     115436 :   colon_seen = 1;
    5664                 :     115436 :   return MATCH_YES;
    5665                 :            : 
    5666                 :      24857 : cleanup:
    5667                 :      24857 :   gfc_current_locus = start;
    5668                 :      24857 :   gfc_free_array_spec (current_as);
    5669                 :      24857 :   current_as = NULL;
    5670                 :      24857 :   attr_seen = 0;
    5671                 :      24857 :   return m;
    5672                 :            : }
    5673                 :            : 
    5674                 :            : 
    5675                 :            : /* Set the binding label, dest_label, either with the binding label
    5676                 :            :    stored in the given gfc_typespec, ts, or if none was provided, it
    5677                 :            :    will be the symbol name in all lower case, as required by the draft
    5678                 :            :    (J3/04-007, section 15.4.1).  If a binding label was given and
    5679                 :            :    there is more than one argument (num_idents), it is an error.  */
    5680                 :            : 
    5681                 :            : static bool
    5682                 :        279 : set_binding_label (const char **dest_label, const char *sym_name,
    5683                 :            :                    int num_idents)
    5684                 :            : {
    5685                 :        279 :   if (num_idents > 1 && has_name_equals)
    5686                 :            :     {
    5687                 :          4 :       gfc_error ("Multiple identifiers provided with "
    5688                 :            :                  "single NAME= specifier at %C");
    5689                 :          4 :       return false;
    5690                 :            :     }
    5691                 :            : 
    5692                 :        275 :   if (curr_binding_label)
    5693                 :            :     /* Binding label given; store in temp holder till have sym.  */
    5694                 :        106 :     *dest_label = curr_binding_label;
    5695                 :            :   else
    5696                 :            :     {
    5697                 :            :       /* No binding label given, and the NAME= specifier did not exist,
    5698                 :            :          which means there was no NAME="".  */
    5699                 :        169 :       if (sym_name != NULL && has_name_equals == 0)
    5700                 :        139 :         *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
    5701                 :            :     }
    5702                 :            : 
    5703                 :            :   return true;
    5704                 :            : }
    5705                 :            : 
    5706                 :            : 
    5707                 :            : /* Set the status of the given common block as being BIND(C) or not,
    5708                 :            :    depending on the given parameter, is_bind_c.  */
    5709                 :            : 
    5710                 :            : void
    5711                 :         75 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
    5712                 :            : {
    5713                 :         75 :   com_block->is_bind_c = is_bind_c;
    5714                 :         75 :   return;
    5715                 :            : }
    5716                 :            : 
    5717                 :            : 
    5718                 :            : /* Verify that the given gfc_typespec is for a C interoperable type.  */
    5719                 :            : 
    5720                 :            : bool
    5721                 :       2697 : gfc_verify_c_interop (gfc_typespec *ts)
    5722                 :            : {
    5723                 :       2697 :   if (ts->type == BT_DERIVED && ts->u.derived != NULL)
    5724                 :        550 :     return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
    5725                 :        545 :            ? true : false;
    5726                 :       2154 :   else if (ts->type == BT_CLASS)
    5727                 :            :     return false;
    5728                 :       2152 :   else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
    5729                 :        196 :     return false;
    5730                 :            : 
    5731                 :            :   return true;
    5732                 :            : }
    5733                 :            : 
    5734                 :            : 
    5735                 :            : /* Verify that the variables of a given common block, which has been
    5736                 :            :    defined with the attribute specifier bind(c), to be of a C
    5737                 :            :    interoperable type.  Errors will be reported here, if
    5738                 :            :    encountered.  */
    5739                 :            : 
    5740                 :            : bool
    5741                 :          1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
    5742                 :            : {
    5743                 :          1 :   gfc_symbol *curr_sym = NULL;
    5744                 :          1 :   bool retval = true;
    5745                 :            : 
    5746                 :          1 :   curr_sym = com_block->head;
    5747                 :            : 
    5748                 :            :   /* Make sure we have at least one symbol.  */
    5749                 :          1 :   if (curr_sym == NULL)
    5750                 :            :     return retval;
    5751                 :            : 
    5752                 :            :   /* Here we know we have a symbol, so we'll execute this loop
    5753                 :            :      at least once.  */
    5754                 :          1 :   do
    5755                 :            :     {
    5756                 :            :       /* The second to last param, 1, says this is in a common block.  */
    5757                 :          1 :       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
    5758                 :          1 :       curr_sym = curr_sym->common_next;
    5759                 :          1 :     } while (curr_sym != NULL);
    5760                 :            : 
    5761                 :            :   return retval;
    5762                 :            : }
    5763                 :            : 
    5764                 :            : 
    5765                 :            : /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
    5766                 :            :    an appropriate error message is reported.  */
    5767                 :            : 
    5768                 :            : bool
    5769                 :       1552 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
    5770                 :            :                    int is_in_common, gfc_common_head *com_block)
    5771                 :            : {
    5772                 :       1552 :   bool bind_c_function = false;
    5773                 :       1552 :   bool retval = true;
    5774                 :            : 
    5775                 :       1552 :   if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
    5776                 :        478 :     bind_c_function = true;
    5777                 :            : 
    5778                 :       1552 :   if (tmp_sym->attr.function && tmp_sym->result != NULL)
    5779                 :            :     {
    5780                 :        478 :       tmp_sym = tmp_sym->result;
    5781                 :            :       /* Make sure it wasn't an implicitly typed result.  */
    5782                 :        478 :       if (tmp_sym->attr.implicit_type && warn_c_binding_type)
    5783                 :            :         {
    5784                 :          1 :           gfc_warning (OPT_Wc_binding_type,
    5785                 :            :                        "Implicitly declared BIND(C) function %qs at "
    5786                 :            :                        "%L may not be C interoperable", tmp_sym->name,
    5787                 :            :                        &tmp_sym->declared_at);
    5788                 :          1 :           tmp_sym->ts.f90_type = tmp_sym->ts.type;
    5789                 :            :           /* Mark it as C interoperable to prevent duplicate warnings.  */
    5790                 :          1 :           tmp_sym->ts.is_c_interop = 1;
    5791                 :          1 :           tmp_sym->attr.is_c_interop = 1;
    5792                 :            :         }
    5793                 :            :     }
    5794                 :            : 
    5795                 :            :   /* Here, we know we have the bind(c) attribute, so if we have
    5796                 :            :      enough type info, then verify that it's a C interop kind.
    5797                 :            :      The info could be in the symbol already, or possibly still in
    5798                 :            :      the given ts (current_ts), so look in both.  */
    5799                 :       1552 :   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
    5800                 :            :     {
    5801                 :        610 :       if (!gfc_verify_c_interop (&(tmp_sym->ts)))
    5802                 :            :         {
    5803                 :            :           /* See if we're dealing with a sym in a common block or not.  */
    5804                 :        103 :           if (is_in_common == 1 && warn_c_binding_type)
    5805                 :            :             {
    5806                 :          0 :               gfc_warning (OPT_Wc_binding_type,
    5807                 :            :                            "Variable %qs in common block %qs at %L "
    5808                 :            :                            "may not be a C interoperable "
    5809                 :            :                            "kind though common block %qs is BIND(C)",
    5810                 :            :                            tmp_sym->name, com_block->name,
    5811                 :          0 :                            &(tmp_sym->declared_at), com_block->name);
    5812                 :            :             }
    5813                 :            :           else
    5814                 :            :             {
    5815                 :        103 :               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
    5816                 :          1 :                 gfc_error ("Type declaration %qs at %L is not C "
    5817                 :            :                            "interoperable but it is BIND(C)",
    5818                 :            :                            tmp_sym->name, &(tmp_sym->declared_at));
    5819                 :        102 :               else if (warn_c_binding_type)
    5820                 :          3 :                 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
    5821                 :            :                              "may not be a C interoperable "
    5822                 :            :                              "kind but it is BIND(C)",
    5823                 :            :                              tmp_sym->name, &(tmp_sym->declared_at));
    5824                 :            :             }
    5825                 :            :         }
    5826                 :            : 
    5827                 :            :       /* Variables declared w/in a common block can't be bind(c)
    5828                 :            :          since there's no way for C to see these variables, so there's
    5829                 :            :          semantically no reason for the attribute.  */
    5830                 :        610 :       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
    5831                 :            :         {
    5832                 :          1 :           gfc_error ("Variable %qs in common block %qs at "
    5833                 :            :                      "%L cannot be declared with BIND(C) "
    5834                 :            :                      "since it is not a global",
    5835                 :          1 :                      tmp_sym->name, com_block->name,
    5836                 :            :                      &(tmp_sym->declared_at));
    5837                 :          1 :           retval = false;
    5838                 :            :         }
    5839                 :            : 
    5840                 :            :       /* Scalar variables that are bind(c) cannot have the pointer
    5841                 :            :          or allocatable attributes.  */
    5842                 :        610 :       if (tmp_sym->attr.is_bind_c == 1)
    5843                 :            :         {
    5844                 :        492 :           if (tmp_sym->attr.pointer == 1)
    5845                 :            :             {
    5846                 :          1 :               gfc_error ("Variable %qs at %L cannot have both the "
    5847                 :            :                          "POINTER and BIND(C) attributes",
    5848                 :            :                          tmp_sym->name, &(tmp_sym->declared_at));
    5849                 :          1 :               retval = false;
    5850                 :            :             }
    5851                 :            : 
    5852                 :        492 :           if (tmp_sym->attr.allocatable == 1)
    5853                 :            :             {
    5854                 :          0 :               gfc_error ("Variable %qs at %L cannot have both the "
    5855                 :            :                          "ALLOCATABLE and BIND(C) attributes",
    5856                 :            :                          tmp_sym->name, &(tmp_sym->declared_at));
    5857                 :          0 :               retval = false;
    5858                 :            :             }
    5859                 :            : 
    5860                 :            :         }
    5861                 :            : 
    5862                 :            :       /* If it is a BIND(C) function, make sure the return value is a
    5863                 :            :          scalar value.  The previous tests in this function made sure
    5864                 :            :          the type is interoperable.  */
    5865                 :        610 :       if (bind_c_function && tmp_sym->as != NULL)
    5866                 :          2 :         gfc_error ("Return type of BIND(C) function %qs at %L cannot "
    5867                 :            :                    "be an array", tmp_sym->name, &(tmp_sym->declared_at));
    5868                 :            : 
    5869                 :            :       /* BIND(C) functions cannot return a character string.  */
    5870                 :        610 :       if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
    5871                 :         26 :         if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
    5872                 :         25 :             || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
    5873                 :         25 :             || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
    5874                 :          4 :           gfc_error ("Return type of BIND(C) function %qs of character "
    5875                 :            :                      "type at %L must have length 1", tmp_sym->name,
    5876                 :            :                          &(tmp_sym->declared_at));
    5877                 :            :     }
    5878                 :            : 
    5879                 :            :   /* See if the symbol has been marked as private.  If it has, make sure
    5880                 :            :      there is no binding label and warn the user if there is one.  */
    5881                 :       1552 :   if (tmp_sym->attr.access == ACCESS_PRIVATE
    5882                 :         10 :       && tmp_sym->binding_label)
    5883                 :            :       /* Use gfc_warning_now because we won't say that the symbol fails
    5884                 :            :          just because of this.  */
    5885                 :          7 :       gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
    5886                 :            :                        "given the binding label %qs", tmp_sym->name,
    5887                 :            :                        &(tmp_sym->declared_at), tmp_sym->binding_label);
    5888                 :            : 
    5889                 :       1552 :   return retval;
    5890                 :            : }
    5891                 :            : 
    5892                 :            : 
    5893                 :            : /* Set the appropriate fields for a symbol that's been declared as
    5894                 :            :    BIND(C) (the is_bind_c flag and the binding label), and verify that
    5895                 :            :    the type is C interoperable.  Errors are reported by the functions
    5896                 :            :    used to set/test these fields.  */
    5897                 :            : 
    5898                 :            : bool
    5899                 :         44 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
    5900                 :            : {
    5901                 :         44 :   bool retval = true;
    5902                 :            : 
    5903                 :            :   /* TODO: Do we need to make sure the vars aren't marked private?  */
    5904                 :            : 
    5905                 :            :   /* Set the is_bind_c bit in symbol_attribute.  */
    5906                 :         44 :   gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
    5907                 :            : 
    5908                 :         44 :   if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
    5909                 :          1 :     return false;
    5910                 :            : 
    5911                 :            :   return retval;
    5912                 :            : }
    5913                 :            : 
    5914                 :            : 
    5915                 :            : /* Set the fields marking the given common block as BIND(C), including
    5916                 :            :    a binding label, and report any errors encountered.  */
    5917                 :            : 
    5918                 :            : bool
    5919                 :         75 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
    5920                 :            : {
    5921                 :         75 :   bool retval = true;
    5922                 :            : 
    5923                 :            :   /* destLabel, common name, typespec (which may have binding label).  */
    5924                 :         75 :   if (!set_binding_label (&com_block->binding_label, com_block->name,
    5925                 :            :                           num_idents))
    5926                 :            :     return false;
    5927                 :            : 
    5928                 :            :   /* Set the given common block (com_block) to being bind(c) (1).  */
    5929                 :         75 :   set_com_block_bind_c (com_block, 1);
    5930                 :            : 
    5931                 :         75 :   return retval;
    5932                 :            : }
    5933                 :            : 
    5934                 :            : 
    5935                 :            : /* Retrieve the list of one or more identifiers that the given bind(c)
    5936                 :            :    attribute applies to.  */
    5937                 :            : 
    5938                 :            : bool
    5939                 :         98 : get_bind_c_idents (void)
    5940                 :            : {
    5941                 :         98 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    5942                 :         98 :   int num_idents = 0;
    5943                 :         98 :   gfc_symbol *tmp_sym = NULL;
    5944                 :         98 :   match found_id;
    5945                 :         98 :   gfc_common_head *com_block = NULL;
    5946                 :            : 
    5947                 :         98 :   if (gfc_match_name (name) == MATCH_YES)
    5948                 :            :     {
    5949                 :         35 :       found_id = MATCH_YES;
    5950                 :         35 :       gfc_get_ha_symbol (name, &tmp_sym);
    5951                 :            :     }
    5952                 :         63 :   else if (match_common_name (name) == MATCH_YES)
    5953                 :            :     {
    5954                 :         63 :       found_id = MATCH_YES;
    5955                 :         63 :       com_block = gfc_get_common (name, 0);
    5956                 :            :     }
    5957                 :            :   else
    5958                 :            :     {
    5959                 :          0 :       gfc_error ("Need either entity or common block name for "
    5960                 :            :                  "attribute specification statement at %C");
    5961                 :          0 :       return false;
    5962                 :            :     }
    5963                 :            : 
    5964                 :            :   /* Save the current identifier and look for more.  */
    5965                 :        119 :   do
    5966                 :            :     {
    5967                 :            :       /* Increment the number of identifiers found for this spec stmt.  */
    5968                 :        119 :       num_idents++;
    5969                 :            : 
    5970                 :            :       /* Make sure we have a sym or com block, and verify that it can
    5971                 :            :          be bind(c).  Set the appropriate field(s) and look for more
    5972                 :            :          identifiers.  */
    5973                 :        119 :       if (tmp_sym != NULL || com_block != NULL)
    5974                 :            :         {
    5975                 :        119 :           if (tmp_sym != NULL)
    5976                 :            :             {
    5977                 :         44 :               if (!set_verify_bind_c_sym (tmp_sym, num_idents))
    5978                 :            :                 return false;
    5979                 :            :             }
    5980                 :            :           else
    5981                 :            :             {
    5982                 :         75 :               if (!set_verify_bind_c_com_block (com_block, num_idents))
    5983                 :            :                 return false;
    5984                 :            :             }
    5985                 :            : 
    5986                 :            :           /* Look to see if we have another identifier.  */
    5987                 :        118 :           tmp_sym = NULL;
    5988                 :        118 :           if (gfc_match_eos () == MATCH_YES)
    5989                 :            :             found_id = MATCH_NO;
    5990                 :         21 :           else if (gfc_match_char (',') != MATCH_YES)
    5991                 :            :             found_id = MATCH_NO;
    5992                 :         21 :           else if (gfc_match_name (name) == MATCH_YES)
    5993                 :            :             {
    5994                 :          9 :               found_id = MATCH_YES;
    5995                 :          9 :               gfc_get_ha_symbol (name, &tmp_sym);
    5996                 :            :             }
    5997                 :         12 :           else if (match_common_name (name) == MATCH_YES)
    5998                 :            :             {
    5999                 :         12 :               found_id = MATCH_YES;
    6000                 :         12 :               com_block = gfc_get_common (name, 0);
    6001                 :            :             }
    6002                 :            :           else
    6003                 :            :             {
    6004                 :          0 :               gfc_error ("Missing entity or common block name for "
    6005                 :            :                          "attribute specification statement at %C");
    6006                 :          0 :               return false;
    6007                 :            :             }
    6008                 :            :         }
    6009                 :            :       else
    6010                 :            :         {
    6011                 :          0 :           gfc_internal_error ("Missing symbol");
    6012                 :            :         }
    6013                 :         21 :     } while (found_id == MATCH_YES);
    6014                 :            : 
    6015                 :            :   /* if we get here we were successful */
    6016                 :            :   return true;
    6017                 :            : }
    6018                 :            : 
    6019                 :            : 
    6020                 :            : /* Try and match a BIND(C) attribute specification statement.  */
    6021                 :            : 
    6022                 :            : match
    6023                 :        126 : gfc_match_bind_c_stmt (void)
    6024                 :            : {
    6025                 :        126 :   match found_match = MATCH_NO;
    6026                 :        126 :   gfc_typespec *ts;
    6027                 :            : 
    6028                 :        126 :   ts = &current_ts;
    6029                 :            : 
    6030                 :            :   /* This may not be necessary.  */
    6031                 :        126 :   gfc_clear_ts (ts);
    6032                 :            :   /* Clear the temporary binding label holder.  */
    6033                 :        126 :   curr_binding_label = NULL;
    6034                 :            : 
    6035                 :            :   /* Look for the bind(c).  */
    6036                 :        126 :   found_match = gfc_match_bind_c (NULL, true);
    6037                 :            : 
    6038                 :        126 :   if (found_match == MATCH_YES)
    6039                 :            :     {
    6040                 :         99 :       if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
    6041                 :            :         return MATCH_ERROR;
    6042                 :            : 
    6043                 :            :       /* Look for the :: now, but it is not required.  */
    6044                 :         98 :       gfc_match (" :: ");
    6045                 :            : 
    6046                 :            :       /* Get the identifier(s) that needs to be updated.  This may need to
    6047                 :            :          change to hand the flag(s) for the attr specified so all identifiers
    6048                 :            :          found can have all appropriate parts updated (assuming that the same
    6049                 :            :          spec stmt can have multiple attrs, such as both bind(c) and
    6050                 :            :          allocatable...).  */
    6051                 :         98 :       if (!get_bind_c_idents ())
    6052                 :            :         /* Error message should have printed already.  */
    6053                 :          1 :         return MATCH_ERROR;
    6054                 :            :     }
    6055                 :            : 
    6056                 :            :   return found_match;
    6057                 :            : }
    6058                 :            : 
    6059                 :            : 
    6060                 :            : /* Match a data declaration statement.  */
    6061                 :            : 
    6062                 :            : match
    6063                 :     661685 : gfc_match_data_decl (void)
    6064                 :            : {
    6065                 :     661685 :   gfc_symbol *sym;
    6066                 :     661685 :   match m;
    6067                 :     661685 :   int elem;
    6068                 :            : 
    6069                 :     661685 :   type_param_spec_list = NULL;
    6070                 :     661685 :   decl_type_param_list = NULL;
    6071                 :            : 
    6072                 :     661685 :   num_idents_on_line = 0;
    6073                 :            : 
    6074                 :     661685 :   m = gfc_match_decl_type_spec (&current_ts, 0);
    6075                 :     661685 :   if (m != MATCH_YES)
    6076                 :            :     return m;
    6077                 :            : 
    6078                 :     139346 :   if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
    6079                 :      21932 :         && !gfc_comp_struct (gfc_current_state ()))
    6080                 :            :     {
    6081                 :      19468 :       sym = gfc_use_derived (current_ts.u.derived);
    6082                 :            : 
    6083                 :      19468 :       if (sym == NULL)
    6084                 :            :         {
    6085                 :         15 :           m = MATCH_ERROR;
    6086                 :         15 :           goto cleanup;
    6087                 :            :         }
    6088                 :            : 
    6089                 :      19453 :       current_ts.u.derived = sym;
    6090                 :            :     }
    6091                 :            : 
    6092                 :     139331 :   m = match_attr_spec ();
    6093                 :     139331 :   if (m == MATCH_ERROR)
    6094                 :            :     {
    6095                 :         63 :       m = MATCH_NO;
    6096                 :         63 :       goto cleanup;
    6097                 :            :     }
    6098                 :            : 
    6099                 :     139268 :   if (current_ts.type == BT_CLASS
    6100                 :       7439 :         && current_ts.u.derived->attr.unlimited_polymorphic)
    6101                 :        826 :     goto ok;
    6102                 :            : 
    6103                 :     138442 :   if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
    6104                 :      21090 :       && current_ts.u.derived->components == NULL
    6105                 :       2073 :       && !current_ts.u.derived->attr.zero_comp)
    6106                 :            :     {
    6107                 :            : 
    6108                 :        175 :       if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
    6109                 :        125 :         goto ok;
    6110                 :            : 
    6111                 :         50 :       if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
    6112                 :         23 :         goto ok;
    6113                 :            : 
    6114                 :         27 :       gfc_find_symbol (current_ts.u.derived->name,
    6115                 :            :                        current_ts.u.derived->ns, 1, &sym);
    6116                 :            : 
    6117                 :            :       /* Any symbol that we find had better be a type definition
    6118                 :            :          which has its components defined, or be a structure definition
    6119                 :            :          actively being parsed.  */
    6120                 :         27 :       if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
    6121                 :         26 :           && (current_ts.u.derived->components != NULL
    6122                 :         26 :               || current_ts.u.derived->attr.zero_comp
    6123                 :         26 :               || current_ts.u.derived == gfc_new_block))
    6124                 :         26 :         goto ok;
    6125                 :            : 
    6126                 :          1 :       gfc_error ("Derived type at %C has not been previously defined "
    6127                 :            :                  "and so cannot appear in a derived type definition");
    6128                 :          1 :       m = MATCH_ERROR;
    6129                 :          1 :       goto cleanup;
    6130                 :            :     }
    6131                 :            : 
    6132                 :     138267 : ok:
    6133                 :            :   /* If we have an old-style character declaration, and no new-style
    6134                 :            :      attribute specifications, then there a comma is optional between
    6135                 :            :      the type specification and the variable list.  */
    6136                 :     139267 :   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
    6137                 :       1421 :     gfc_match_char (',');
    6138                 :            : 
    6139                 :            :   /* Give the types/attributes to symbols that follow. Give the element
    6140                 :            :      a number so that repeat character length expressions can be copied.  */
    6141                 :            :   elem = 1;
    6142                 :     186283 :   for (;;)
    6143                 :            :     {
    6144                 :     186283 :       num_idents_on_line++;
    6145                 :     186283 :       m = variable_decl (elem++);
    6146                 :     186281 :       if (m == MATCH_ERROR)
    6147                 :        274 :         goto cleanup;
    6148                 :     186007 :       if (m == MATCH_NO)
    6149                 :            :         break;
    6150                 :            : 
    6151                 :     185994 :       if (gfc_match_eos () == MATCH_YES)
    6152                 :     138958 :         goto cleanup;
    6153                 :      47036 :       if (gfc_match_char (',') != MATCH_YES)
    6154                 :            :         break;
    6155                 :            :     }
    6156                 :            : 
    6157                 :         33 :   if (!gfc_error_flag_test ())
    6158                 :            :     {
    6159                 :            :       /* An anonymous structure declaration is unambiguous; if we matched one
    6160                 :            :          according to gfc_match_structure_decl, we need to return MATCH_YES
    6161                 :            :          here to avoid confusing the remaining matchers, even if there was an
    6162                 :            :          error during variable_decl.  We must flush any such errors.  Note this
    6163                 :            :          causes the parser to gracefully continue parsing the remaining input
    6164                 :            :          as a structure body, which likely follows.  */
    6165                 :          8 :       if (current_ts.type == BT_DERIVED && current_ts.u.derived
    6166                 :          1 :           && gfc_fl_struct (current_ts.u.derived->attr.flavor))
    6167                 :            :         {
    6168                 :          1 :           gfc_error_now ("Syntax error in anonymous structure declaration"
    6169                 :            :                          " at %C");
    6170                 :            :           /* Skip the bad variable_decl and line up for the start of the
    6171                 :            :              structure body.  */
    6172                 :          1 :           gfc_error_recovery ();
    6173                 :          1 :           m = MATCH_YES;
    6174                 :          1 :           goto cleanup;
    6175                 :            :         }
    6176                 :            : 
    6177                 :          7 :       gfc_error ("Syntax error in data declaration at %C");
    6178                 :            :     }
    6179                 :            : 
    6180                 :         32 :   m = MATCH_ERROR;
    6181                 :            : 
    6182                 :         32 :   gfc_free_data_all (gfc_current_ns);
    6183                 :            : 
    6184                 :     139344 : cleanup:
    6185                 :     139344 :   if (saved_kind_expr)
    6186                 :         87 :     gfc_free_expr (saved_kind_expr);
    6187                 :     139344 :   if (type_param_spec_list)
    6188                 :        428 :     gfc_free_actual_arglist (type_param_spec_list);
    6189                 :     139344 :   if (decl_type_param_list)
    6190                 :        455 :     gfc_free_actual_arglist (decl_type_param_list);
    6191                 :     139344 :   saved_kind_expr = NULL;
    6192                 :     139344 :   gfc_free_array_spec (current_as);
    6193                 :     139344 :   current_as = NULL;
    6194                 :     139344 :   return m;
    6195                 :            : }
    6196                 :            : 
    6197                 :            : static bool
    6198                 :      17569 : in_module_or_interface(void)
    6199                 :            : {
    6200                 :      17569 :   if (gfc_current_state () == COMP_MODULE
    6201                 :      17569 :       || gfc_current_state () == COMP_SUBMODULE
    6202                 :      17569 :       || gfc_current_state () == COMP_INTERFACE)
    6203                 :            :     return true;
    6204                 :            : 
    6205                 :      14703 :   if (gfc_state_stack->state == COMP_CONTAINS
    6206                 :      14703 :       || gfc_state_stack->state == COMP_FUNCTION
    6207                 :      14110 :       || gfc_state_stack->state == COMP_SUBROUTINE)
    6208                 :            :     {
    6209                 :        593 :       gfc_state_data *p;
    6210                 :        628 :       for (p = gfc_state_stack->previous; p ; p = p->previous)
    6211                 :            :         {
    6212                 :        624 :           if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
    6213                 :         90 :               || p->state == COMP_INTERFACE)
    6214                 :            :             return true;
    6215                 :            :         }
    6216                 :            :     }
    6217                 :            :     return false;
    6218                 :            : }
    6219                 :            : 
    6220                 :            : /* Match a prefix associated with a function or subroutine
    6221                 :            :    declaration.  If the typespec pointer is nonnull, then a typespec
    6222                 :            :    can be matched.  Note that if nothing matches, MATCH_YES is
    6223                 :            :    returned (the null string was matched).  */
    6224                 :            : 
    6225                 :            : match
    6226                 :     162674 : gfc_match_prefix (gfc_typespec *ts)
    6227                 :            : {
    6228                 :     162674 :   bool seen_type;
    6229                 :     162674 :   bool seen_impure;
    6230                 :     162674 :   bool found_prefix;
    6231                 :            : 
    6232                 :     162674 :   gfc_clear_attr (&current_attr);
    6233                 :     162674 :   seen_type = false;
    6234                 :     162674 :   seen_impure = false;
    6235                 :            : 
    6236                 :     162674 :   gcc_assert (!gfc_matching_prefix);
    6237                 :     162674 :   gfc_matching_prefix = true;
    6238                 :            : 
    6239                 :     166848 :   do
    6240                 :            :     {
    6241                 :     181624 :       found_prefix = false;
    6242                 :            : 
    6243                 :            :       /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
    6244                 :            :          corresponding attribute seems natural and distinguishes these
    6245                 :            :          procedures from procedure types of PROC_MODULE, which these are
    6246                 :            :          as well.  */
    6247                 :     181624 :       if (gfc_match ("module% ") == MATCH_YES)
    6248                 :            :         {
    6249                 :      17842 :           if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
    6250                 :        273 :             goto error;
    6251                 :            : 
    6252                 :      17569 :           if (!in_module_or_interface ())
    6253                 :            :             {
    6254                 :      14114 :               gfc_error ("MODULE prefix at %C found outside of a module, "
    6255                 :            :                          "submodule, or interface");
    6256                 :      14114 :               goto error;
    6257                 :            :             }
    6258                 :            : 
    6259                 :       3455 :           current_attr.module_procedure = 1;
    6260                 :       3455 :           found_prefix = true;
    6261                 :            :         }
    6262                 :            : 
    6263                 :     167237 :       if (!seen_type && ts != NULL)
    6264                 :            :         {
    6265                 :      90630 :           match m;
    6266                 :      90630 :           m = gfc_match_decl_type_spec (ts, 0);
    6267                 :      90630 :           if (m == MATCH_ERROR)
    6268                 :          9 :             goto error;
    6269                 :      90621 :           if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
    6270                 :            :             {
    6271                 :            :               seen_type = true;
    6272                 :            :               found_prefix = true;
    6273                 :            :             }
    6274                 :            :         }
    6275                 :            : 
    6276                 :     167228 :       if (gfc_match ("elemental% ") == MATCH_YES)
    6277                 :            :         {
    6278                 :       3442 :           if (!gfc_add_elemental (&current_attr, NULL))
    6279                 :          2 :             goto error;
    6280                 :            : 
    6281                 :            :           found_prefix = true;
    6282                 :            :         }
    6283                 :            : 
    6284                 :     167226 :       if (gfc_match ("pure% ") == MATCH_YES)
    6285                 :            :         {
    6286                 :       1868 :           if (!gfc_add_pure (&current_attr, NULL))
    6287                 :          2 :             goto error;
    6288                 :            : 
    6289                 :            :           found_prefix = true;
    6290                 :            :         }
    6291                 :            : 
    6292                 :     167224 :       if (gfc_match ("recursive% ") == MATCH_YES)
    6293                 :            :         {
    6294                 :        408 :           if (!gfc_add_recursive (&current_attr, NULL))
    6295                 :          2 :             goto error;
    6296                 :            : 
    6297                 :            :           found_prefix = true;
    6298                 :            :         }
    6299                 :            : 
    6300                 :            :       /* IMPURE is a somewhat special case, as it needs not set an actual
    6301                 :            :          attribute but rather only prevents ELEMENTAL routines from being
    6302                 :            :          automatically PURE.  */
    6303                 :     167222 :       if (gfc_match ("impure% ") == MATCH_YES)
    6304                 :            :         {
    6305                 :        374 :           if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
    6306                 :          4 :             goto error;
    6307                 :            : 
    6308                 :            :           seen_impure = true;
    6309                 :            :           found_prefix = true;
    6310                 :            :         }
    6311                 :            :     }
    6312                 :            :   while (found_prefix);
    6313                 :            : 
    6314                 :            :   /* IMPURE and PURE must not both appear, of course.  */
    6315                 :     148268 :   if (seen_impure && current_attr.pure)
    6316                 :            :     {
    6317                 :          4 :       gfc_error ("PURE and IMPURE must not appear both at %C");
    6318                 :          4 :       goto error;
    6319                 :            :     }
    6320                 :            : 
    6321                 :            :   /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE.  */
    6322                 :     148264 :   if (!seen_impure && current_attr.elemental && !current_attr.pure)
    6323                 :            :     {
    6324                 :       3065 :       if (!gfc_add_pure (&current_attr, NULL))
    6325                 :          0 :         goto error;
    6326                 :            :     }
    6327                 :            : 
    6328                 :            :   /* At this point, the next item is not a prefix.  */
    6329                 :     148264 :   gcc_assert (gfc_matching_prefix);
    6330                 :            : 
    6331                 :     148264 :   gfc_matching_prefix = false;
    6332                 :     148264 :   return MATCH_YES;
    6333                 :            : 
    6334                 :      14410 : error:
    6335                 :      14410 :   gcc_assert (gfc_matching_prefix);
    6336                 :      14410 :   gfc_matching_prefix = false;
    6337                 :      14410 :   return MATCH_ERROR;
    6338                 :            : }
    6339                 :            : 
    6340                 :            : 
    6341                 :            : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol.  */
    6342                 :            : 
    6343                 :            : static bool
    6344                 :      39295 : copy_prefix (symbol_attribute *dest, locus *where)
    6345                 :            : {
    6346                 :      39295 :   if (dest->module_procedure)
    6347                 :            :     {
    6348                 :        458 :       if (current_attr.elemental)
    6349                 :          4 :         dest->elemental = 1;
    6350                 :            : 
    6351                 :        458 :       if (current_attr.pure)
    6352                 :          9 :         dest->pure = 1;
    6353                 :            : 
    6354                 :        458 :       if (current_attr.recursive)
    6355                 :          8 :         dest->recursive = 1;
    6356                 :            : 
    6357                 :            :       /* Module procedures are unusual in that the 'dest' is copied from
    6358                 :            :          the interface declaration. However, this is an oportunity to
    6359                 :            :          check that the submodule declaration is compliant with the
    6360                 :            :          interface.  */
    6361                 :        458 :       if (dest->elemental && !current_attr.elemental)
    6362                 :            :         {
    6363                 :          1 :           gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
    6364                 :            :                      "missing at %L", where);
    6365                 :          1 :           return false;
    6366                 :            :         }
    6367                 :            : 
    6368                 :        457 :       if (dest->pure && !current_attr.pure)
    6369                 :            :         {
    6370                 :          1 :           gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
    6371                 :            :                      "missing at %L", where);
    6372                 :          1 :           return false;
    6373                 :            :         }
    6374                 :            : 
    6375                 :        456 :       if (dest->recursive && !current_attr.recursive)
    6376                 :            :         {
    6377                 :          1 :           gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
    6378                 :            :                      "missing at %L", where);
    6379                 :          1 :           return false;
    6380                 :            :         }
    6381                 :            : 
    6382                 :            :       return true;
    6383                 :            :     }
    6384                 :            : 
    6385                 :      38837 :   if (current_attr.elemental && !gfc_add_elemental (dest, where))
    6386                 :            :     return false;
    6387                 :            : 
    6388                 :      38835 :   if (current_attr.pure && !gfc_add_pure (dest, where))
    6389                 :            :     return false;
    6390                 :            : 
    6391                 :      38835 :   if (current_attr.recursive && !gfc_add_recursive (dest, where))
    6392                 :          0 :     return false;
    6393                 :            : 
    6394                 :            :   return true;
    6395                 :            : }
    6396                 :            : 
    6397                 :            : 
    6398                 :            : /* Match a formal argument list or, if typeparam is true, a
    6399                 :            :    type_param_name_list.  */
    6400                 :            : 
    6401                 :            : match
    6402                 :     322431 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
    6403                 :            :                           int null_flag, bool typeparam)
    6404                 :            : {
    6405                 :     322431 :   gfc_formal_arglist *head, *tail, *p, *q;
    6406                 :     322431 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    6407                 :     322431 :   gfc_symbol *sym;
    6408                 :     322431 :   match m;
    6409                 :     322431 :   gfc_formal_arglist *formal = NULL;
    6410                 :            : 
    6411                 :     322431 :   head = tail = NULL;
    6412                 :            : 
    6413                 :            :   /* Keep the interface formal argument list and null it so that the
    6414                 :            :      matching for the new declaration can be done.  The numbers and
    6415                 :            :      names of the arguments are checked here. The interface formal
    6416                 :            :      arguments are retained in formal_arglist and the characteristics
    6417                 :            :      are compared in resolve.c(resolve_fl_procedure).  See the remark
    6418                 :            :      in get_proc_name about the eventual need to copy the formal_arglist
    6419                 :            :      and populate the formal namespace of the interface symbol.  */
    6420                 :     322431 :   if (progname->attr.module_procedure
    6421                 :     322431 :       && progname->attr.host_assoc)
    6422                 :            :     {
    6423                 :        146 :       formal = progname->formal;
    6424                 :        146 :       progname->formal = NULL;
    6425                 :            :     }
    6426                 :            : 
    6427                 :     322431 :   if (gfc_match_char ('(') != MATCH_YES)
    6428                 :            :     {
    6429                 :     197143 :       if (null_flag)
    6430                 :       3900 :         goto ok;
    6431                 :            :       return MATCH_NO;
    6432                 :            :     }
    6433                 :            : 
    6434                 :     125288 :   if (gfc_match_char (')') == MATCH_YES)
    6435                 :            :   {
    6436                 :       6054 :     if (typeparam)
    6437                 :            :       {
    6438                 :          1 :         gfc_error_now ("A type parameter list is required at %C");
    6439                 :          1 :         m = MATCH_ERROR;
    6440                 :          1 :         goto cleanup;
    6441                 :            :       }
    6442                 :            :     else
    6443                 :       6053 :       goto ok;
    6444                 :            :   }
    6445                 :            : 
    6446                 :     158407 :   for (;;)
    6447                 :            :     {
    6448                 :     158407 :       if (gfc_match_char ('*') == MATCH_YES)
    6449                 :            :         {
    6450                 :       6750 :           sym = NULL;
    6451                 :       6750 :           if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
    6452                 :            :                              "Alternate-return argument at %C"))
    6453                 :            :             {
    6454                 :          1 :               m = MATCH_ERROR;
    6455                 :          1 :               goto cleanup;
    6456                 :            :             }
    6457                 :       6749 :           else if (typeparam)
    6458                 :          2 :             gfc_error_now ("A parameter name is required at %C");
    6459                 :            :         }
    6460                 :            :       else
    6461                 :            :         {
    6462                 :     151657 :           m = gfc_match_name (name);
    6463                 :     151657 :           if (m != MATCH_YES)
    6464                 :            :             {
    6465                 :      12794 :               if(typeparam)
    6466                 :          1 :                 gfc_error_now ("A parameter name is required at %C");
    6467                 :      12794 :               goto cleanup;
    6468                 :            :             }
    6469                 :            : 
    6470                 :     138863 :           if (!typeparam && gfc_get_symbol (name, NULL, &sym))
    6471                 :          4 :             goto cleanup;
    6472                 :     138859 :           else if (typeparam
    6473                 :     138859 :                    && gfc_get_symbol (name, progname->f2k_derived, &sym))
    6474                 :          0 :             goto cleanup;
    6475                 :            :         }
    6476                 :            : 
    6477                 :     145608 :       p = gfc_get_formal_arglist ();
    6478                 :            : 
    6479                 :     145608 :       if (head == NULL)
    6480                 :            :         head = tail = p;
    6481                 :            :       else
    6482                 :            :         {
    6483                 :      38500 :           tail->next = p;
    6484                 :      38500 :           tail = p;
    6485                 :            :         }
    6486                 :            : 
    6487                 :     145608 :       tail->sym = sym;
    6488                 :            : 
    6489                 :            :       /* We don't add the VARIABLE flavor because the name could be a
    6490                 :            :          dummy procedure.  We don't apply these attributes to formal
    6491                 :            :          arguments of statement functions.  */
    6492                 :     138859 :       if (sym != NULL && !st_flag
    6493                 :     208696 :           && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
    6494                 :      63088 :               || !gfc_missing_attr (&sym->attr, NULL)))
    6495                 :            :         {
    6496                 :          0 :           m = MATCH_ERROR;
    6497                 :          0 :           goto cleanup;
    6498                 :            :         }
    6499                 :            : 
    6500                 :            :       /* The name of a program unit can be in a different namespace,
    6501                 :            :          so check for it explicitly.  After the statement is accepted,
    6502                 :            :          the name is checked for especially in gfc_get_symbol().  */
    6503                 :     145608 :       if (gfc_new_block != NULL && sym != NULL && !typeparam
    6504                 :      62181 :           && strcmp (sym->name, gfc_new_block->name) == 0)
    6505                 :            :         {
    6506                 :          0 :           gfc_error ("Name %qs at %C is the name of the procedure",
    6507                 :            :                      sym->name);
    6508                 :          0 :           m = MATCH_ERROR;
    6509                 :          0 :           goto cleanup;
    6510                 :            :         }
    6511                 :            : 
    6512                 :     145608 :       if (gfc_match_char (')') == MATCH_YES)
    6513                 :      74252 :         goto ok;
    6514                 :            : 
    6515                 :      71356 :       m = gfc_match_char (',');
    6516                 :      71356 :       if (m != MATCH_YES)
    6517                 :            :         {
    6518                 :      32183 :           if (typeparam)
    6519                 :          1 :             gfc_error_now ("Expected parameter list in type declaration "
    6520                 :            :                            "at %C");
    6521                 :            :           else
    6522                 :      32182 :             gfc_error ("Unexpected junk in formal argument list at %C");
    6523                 :      32183 :           goto cleanup;
    6524                 :            :         }
    6525                 :            :     }
    6526                 :            : 
    6527                 :      84205 : ok:
    6528                 :            :   /* Check for duplicate symbols in the formal argument list.  */
    6529                 :      84205 :   if (head != NULL)
    6530                 :            :     {
    6531                 :     111535 :       for (p = head; p->next; p = p->next)
    6532                 :            :         {
    6533                 :      37331 :           if (p->sym == NULL)
    6534                 :        309 :             continue;
    6535                 :            : 
    6536                 :     160700 :           for (q = p->next; q; q = q->next)
    6537                 :     123726 :             if (p->sym == q->sym)
    6538                 :            :               {
    6539                 :         48 :                 if (typeparam)
    6540                 :          1 :                   gfc_error_now ("Duplicate name %qs in parameter "
    6541                 :            :                                  "list at %C", p->sym->name);
    6542                 :            :                 else
    6543                 :         47 :                   gfc_error ("Duplicate symbol %qs in formal argument "
    6544                 :            :                              "list at %C", p->sym->name);
    6545                 :            : 
    6546                 :         48 :                 m = MATCH_ERROR;
    6547                 :         48 :                 goto cleanup;
    6548                 :            :               }
    6549                 :            :         }
    6550                 :            :     }
    6551                 :            : 
    6552                 :      84157 :   if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
    6553                 :            :     {
    6554                 :          1 :       m = MATCH_ERROR;
    6555                 :          1 :       goto cleanup;
    6556                 :            :     }
    6557                 :            : 
    6558                 :            :   /* gfc_error_now used in following and return with MATCH_YES because
    6559                 :            :      doing otherwise results in a cascade of extraneous errors and in
    6560                 :            :      some cases an ICE in symbol.c(gfc_release_symbol).  */
    6561                 :      84156 :   if (progname->attr.module_procedure && progname->attr.host_assoc)
    6562                 :            :     {
    6563                 :        145 :       bool arg_count_mismatch = false;
    6564                 :            : 
    6565                 :        145 :       if (!formal && head)
    6566                 :          1 :         arg_count_mismatch = true;
    6567                 :            : 
    6568                 :            :       /* Abbreviated module procedure declaration is not meant to have any
    6569                 :            :          formal arguments!  */
    6570                 :        145 :       if (!progname->abr_modproc_decl && formal && !head)
    6571                 :          1 :         arg_count_mismatch = true;
    6572                 :            : 
    6573                 :        279 :       for (p = formal, q = head; p && q; p = p->next, q = q->next)
    6574                 :            :         {
    6575                 :        134 :           if ((p->next != NULL && q->next == NULL)
    6576                 :        133 :               || (p->next == NULL && q->next != NULL))
    6577                 :            :             arg_count_mismatch = true;
    6578                 :        132 :           else if ((p->sym == NULL && q->sym == NULL)
    6579                 :        132 :                     || strcmp (p->sym->name, q->sym->name) == 0)
    6580                 :        131 :             continue;
    6581                 :            :           else
    6582                 :          1 :             gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
    6583                 :            :                            "argument names (%s/%s) at %C",
    6584                 :            :                            p->sym->name, q->sym->name);
    6585                 :            :         }
    6586                 :            : 
    6587                 :        145 :       if (arg_count_mismatch)
    6588                 :          4 :         gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
    6589                 :            :                        "formal arguments at %C");
    6590                 :            :     }
    6591                 :            : 
    6592                 :            :   return MATCH_YES;
    6593                 :            : 
    6594                 :      45032 : cleanup:
    6595                 :      45032 :   gfc_free_formal_arglist (head);
    6596                 :      45032 :   return m;
    6597                 :            : }
    6598                 :            : 
    6599                 :            : 
    6600                 :            : /* Match a RESULT specification following a function declaration or
    6601                 :            :    ENTRY statement.  Also matches the end-of-statement.  */
    6602                 :            : 
    6603                 :            : static match
    6604                 :       4264 : match_result (gfc_symbol *function, gfc_symbol **result)
    6605                 :            : {
    6606                 :       4264 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    6607                 :       4264 :   gfc_symbol *r;
    6608                 :       4264 :   match m;
    6609                 :            : 
    6610                 :       4264 :   if (gfc_match (" result (") != MATCH_YES)
    6611                 :            :     return MATCH_NO;
    6612                 :            : 
    6613                 :       3920 :   m = gfc_match_name (name);
    6614                 :       3920 :   if (m != MATCH_YES)
    6615                 :            :     return m;
    6616                 :            : 
    6617                 :            :   /* Get the right paren, and that's it because there could be the
    6618                 :            :      bind(c) attribute after the result clause.  */
    6619                 :       3920 :   if (gfc_match_char (')') != MATCH_YES)
    6620                 :            :     {
    6621                 :            :      /* TODO: should report the missing right paren here.  */
    6622                 :            :       return MATCH_ERROR;
    6623                 :            :     }
    6624                 :            : 
    6625                 :       3920 :   if (strcmp (function->name, name) == 0)
    6626                 :            :     {
    6627                 :          1 :       gfc_error ("RESULT variable at %C must be different than function name");
    6628                 :          1 :       return MATCH_ERROR;
    6629                 :            :     }
    6630                 :            : 
    6631                 :       3919 :   if (gfc_get_symbol (name, NULL, &r))
    6632                 :            :     return MATCH_ERROR;
    6633                 :            : 
    6634                 :       3919 :   if (!gfc_add_result (&r->attr, r->name, NULL))
    6635                 :            :     return MATCH_ERROR;
    6636                 :            : 
    6637                 :       3919 :   *result = r;
    6638                 :            : 
    6639                 :       3919 :   return MATCH_YES;
    6640                 :            : }
    6641                 :            : 
    6642                 :            : 
    6643                 :            : /* Match a function suffix, which could be a combination of a result
    6644                 :            :    clause and BIND(C), either one, or neither.  The draft does not
    6645                 :            :    require them to come in a specific order.  */
    6646                 :            : 
    6647                 :            : match
    6648                 :       4268 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
    6649                 :            : {
    6650                 :       4268 :   match is_bind_c;   /* Found bind(c).  */
    6651                 :       4268 :   match is_result;   /* Found result clause.  */
    6652                 :       4268 :   match found_match; /* Status of whether we've found a good match.  */
    6653                 :       4268 :   char peek_char;    /* Character we're going to peek at.  */
    6654                 :       4268 :   bool allow_binding_name;
    6655                 :            : 
    6656                 :            :   /* Initialize to having found nothing.  */
    6657                 :       4268 :   found_match = MATCH_NO;
    6658                 :       4268 :   is_bind_c = MATCH_NO;
    6659                 :       4268 :   is_result = MATCH_NO;
    6660                 :            : 
    6661                 :            :   /* Get the next char to narrow between result and bind(c).  */
    6662                 :       4268 :   gfc_gobble_whitespace ();
    6663                 :       4268 :   peek_char = gfc_peek_ascii_char ();
    6664                 :            : 
    6665                 :            :   /* C binding names are not allowed for internal procedures.  */
    6666                 :       4268 :   if (gfc_current_state () == COMP_CONTAINS
    6667                 :       2923 :       && sym->ns->proc_name->attr.flavor != FL_MODULE)
    6668                 :            :     allow_binding_name = false;
    6669                 :            :   else
    6670                 :       3085 :     allow_binding_name = true;
    6671                 :            : 
    6672                 :       4268 :   switch (peek_char)
    6673                 :            :     {
    6674                 :       3834 :     case 'r':
    6675                 :            :       /* Look for result clause.  */
    6676                 :       3834 :       is_result = match_result (sym, result);
    6677                 :       3834 :       if (is_result == MATCH_YES)
    6678                 :            :         {
    6679                 :            :           /* Now see if there is a bind(c) after it.  */
    6680                 :       3833 :           is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
    6681                 :            :           /* We've found the result clause and possibly bind(c).  */
    6682                 :       3833 :           found_match = MATCH_YES;
    6683                 :            :         }
    6684                 :            :       else
    6685                 :            :         /* This should only be MATCH_ERROR.  */
    6686                 :            :         found_match = is_result;
    6687                 :            :       break;
    6688                 :        434 :     case 'b':
    6689                 :            :       /* Look for bind(c) first.  */
    6690                 :        434 :       is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
    6691                 :        434 :       if (is_bind_c == MATCH_YES)
    6692                 :            :         {
    6693                 :            :           /* Now see if a result clause followed it.  */
    6694                 :        430 :           is_result = match_result (sym, result);
    6695                 :        430 :           found_match = MATCH_YES;
    6696                 :            :         }
    6697                 :            :       else
    6698                 :            :         {
    6699                 :            :           /* Should only be a MATCH_ERROR if we get here after seeing 'b'.  */
    6700                 :            :           found_match = MATCH_ERROR;
    6701                 :            :         }
    6702                 :            :       break;
    6703                 :          0 :     default:
    6704                 :          0 :       gfc_error ("Unexpected junk after function declaration at %C");
    6705                 :          0 :       found_match = MATCH_ERROR;
    6706                 :          0 :       break;
    6707                 :            :     }
    6708                 :            : 
    6709                 :       4267 :   if (is_bind_c == MATCH_YES)
    6710                 :            :     {
    6711                 :            :       /* Fortran 2008 draft allows BIND(C) for internal procedures.  */
    6712                 :        462 :       if (gfc_current_state () == COMP_CONTAINS
    6713                 :        108 :           && sym->ns->proc_name->attr.flavor != FL_MODULE
    6714                 :        474 :           && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
    6715                 :            :                               "at %L may not be specified for an internal "
    6716                 :            :                               "procedure", &gfc_current_locus))
    6717                 :            :         return MATCH_ERROR;
    6718                 :            : 
    6719                 :        459 :       if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
    6720                 :          0 :         return MATCH_ERROR;
    6721                 :            :     }
    6722                 :            : 
    6723                 :            :   return found_match;
    6724                 :            : }
    6725                 :            : 
    6726                 :            : 
    6727                 :            : /* Procedure pointer return value without RESULT statement:
    6728                 :            :    Add "hidden" result variable named "ppr@".  */
    6729                 :            : 
    6730                 :            : static bool
    6731                 :      47432 : add_hidden_procptr_result (gfc_symbol *sym)
    6732                 :            : {
    6733                 :      47432 :   bool case1,case2;
    6734                 :            : 
    6735                 :      47432 :   if (gfc_notification_std (GFC_STD_F2003) == ERROR)
    6736                 :            :     return false;
    6737                 :            : 
    6738                 :            :   /* First usage case: PROCEDURE and EXTERNAL statements.  */
    6739                 :        407 :   case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
    6740                 :        407 :           && strcmp (gfc_current_block ()->name, sym->name) == 0
    6741                 :      47454 :           && sym->attr.external;
    6742                 :            :   /* Second usage case: INTERFACE statements.  */
    6743                 :       7980 :   case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
    6744                 :       7980 :           && gfc_state_stack->previous->state == COMP_FUNCTION
    6745                 :      47449 :           && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
    6746                 :            : 
    6747                 :      47281 :   if (case1 || case2)
    6748                 :            :     {
    6749                 :        118 :       gfc_symtree *stree;
    6750                 :        118 :       if (case1)
    6751                 :         91 :         gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
    6752                 :            :       else
    6753                 :            :         {
    6754                 :         27 :           gfc_symtree *st2;
    6755                 :         27 :           gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
    6756                 :         27 :           st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
    6757                 :         27 :           st2->n.sym = stree->n.sym;
    6758                 :         27 :           stree->n.sym->refs++;
    6759                 :            :         }
    6760                 :        118 :       sym->result = stree->n.sym;
    6761                 :            : 
    6762                 :        118 :       sym->result->attr.proc_pointer = sym->attr.proc_pointer;
    6763                 :        118 :       sym->result->attr.pointer = sym->attr.pointer;
    6764                 :        118 :       sym->result->attr.external = sym->attr.external;
    6765                 :        118 :       sym->result->attr.referenced = sym->attr.referenced;
    6766                 :        118 :       sym->result->ts = sym->ts;
    6767                 :        118 :       sym->attr.proc_pointer = 0;
    6768                 :        118 :       sym->attr.pointer = 0;
    6769                 :        118 :       sym->attr.external = 0;
    6770                 :        118 :       if (sym->result->attr.external && sym->result->attr.pointer)
    6771                 :            :         {
    6772                 :          3 :           sym->result->attr.pointer = 0;
    6773                 :          3 :           sym->result->attr.proc_pointer = 1;
    6774                 :            :         }
    6775                 :            : 
    6776                 :        118 :       return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
    6777                 :            :     }
    6778                 :            :   /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement.  */
    6779                 :      47163 :   else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
    6780                 :         64 :            && sym->result && sym->result != sym && sym->result->attr.external
    6781                 :         26 :            && sym == gfc_current_ns->proc_name
    6782                 :         26 :            && sym == sym->result->ns->proc_name
    6783                 :         26 :            && strcmp ("ppr@", sym->result->name) == 0)
    6784                 :            :     {
    6785                 :         26 :       sym->result->attr.proc_pointer = 1;
    6786                 :         26 :       sym->attr.pointer = 0;
    6787                 :         26 :       return true;
    6788                 :            :     }
    6789                 :            :   else
    6790                 :            :     return false;
    6791                 :            : }
    6792                 :            : 
    6793                 :            : 
    6794                 :            : /* Match the interface for a PROCEDURE declaration,
    6795                 :            :    including brackets (R1212).  */
    6796                 :            : 
    6797                 :            : static match
    6798                 :       1340 : match_procedure_interface (gfc_symbol **proc_if)
    6799                 :            : {
    6800                 :       1340 :   match m;
    6801                 :       1340 :   gfc_symtree *st;
    6802                 :       1340 :   locus old_loc, entry_loc;
    6803                 :       1340 :   gfc_namespace *old_ns = gfc_current_ns;
    6804                 :       1340 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    6805                 :            : 
    6806                 :       1340 :   old_loc = entry_loc = gfc_current_locus;
    6807                 :       1340 :   gfc_clear_ts (&current_ts);
    6808                 :            : 
    6809                 :       1340 :   if (gfc_match (" (") != MATCH_YES)
    6810                 :            :     {
    6811                 :          1 :       gfc_current_locus = entry_loc;
    6812                 :          1 :       return MATCH_NO;
    6813                 :            :     }
    6814                 :            : 
    6815                 :            :   /* Get the type spec. for the procedure interface.  */
    6816                 :       1339 :   old_loc = gfc_current_locus;
    6817                 :       1339 :   m = gfc_match_decl_type_spec (&current_ts, 0);
    6818                 :       1339 :   gfc_gobble_whitespace ();
    6819                 :       1339 :   if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
    6820                 :        366 :     goto got_ts;
    6821                 :            : 
    6822                 :        973 :   if (m == MATCH_ERROR)
    6823                 :            :     return m;
    6824                 :            : 
    6825                 :            :   /* Procedure interface is itself a procedure.  */
    6826                 :        973 :   gfc_current_locus = old_loc;
    6827                 :        973 :   m = gfc_match_name (name);
    6828                 :            : 
    6829                 :            :   /* First look to see if it is already accessible in the current
    6830                 :            :      namespace because it is use associated or contained.  */
    6831                 :        973 :   st = NULL;
    6832                 :        973 :   if (gfc_find_sym_tree (name, NULL, 0, &st))
    6833                 :            :     return MATCH_ERROR;
    6834                 :            : 
    6835                 :            :   /* If it is still not found, then try the parent namespace, if it
    6836                 :            :      exists and create the symbol there if it is still not found.  */
    6837                 :        973 :   if (gfc_current_ns->parent)
    6838                 :        286 :     gfc_current_ns = gfc_current_ns->parent;
    6839                 :        973 :   if (st == NULL && gfc_get_ha_sym_tree (name, &st))
    6840                 :            :     return MATCH_ERROR;
    6841                 :            : 
    6842                 :        973 :   gfc_current_ns = old_ns;
    6843                 :        973 :   *proc_if = st->n.sym;
    6844                 :            : 
    6845                 :        973 :   if (*proc_if)
    6846                 :            :     {
    6847                 :        973 :       (*proc_if)->refs++;
    6848                 :            :       /* Resolve interface if possible. That way, attr.procedure is only set
    6849                 :            :          if it is declared by a later procedure-declaration-stmt, which is
    6850                 :            :          invalid per F08:C1216 (cf. resolve_procedure_interface).  */
    6851                 :        980 :       while ((*proc_if)->ts.interface
    6852                 :        980 :              && *proc_if != (*proc_if)->ts.interface)
    6853                 :          7 :         *proc_if = (*proc_if)->ts.interface;
    6854                 :            : 
    6855                 :        973 :       if ((*proc_if)->attr.flavor == FL_UNKNOWN
    6856                 :        366 :           && (*proc_if)->ts.type == BT_UNKNOWN
    6857                 :       1339 :           && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
    6858                 :            :                               (*proc_if)->name, NULL))
    6859                 :            :         return MATCH_ERROR;
    6860                 :            :     }
    6861                 :            : 
    6862                 :          0 : got_ts:
    6863                 :       1339 :   if (gfc_match (" )") != MATCH_YES)
    6864                 :            :     {
    6865                 :          0 :       gfc_current_locus = entry_loc;
    6866                 :          0 :       return MATCH_NO;
    6867                 :            :     }
    6868                 :            : 
    6869                 :            :   return MATCH_YES;
    6870                 :            : }
    6871                 :            : 
    6872                 :            : 
    6873                 :            : /* Match a PROCEDURE declaration (R1211).  */
    6874                 :            : 
    6875                 :            : static match
    6876                 :        962 : match_procedure_decl (void)
    6877                 :            : {
    6878                 :        962 :   match m;
    6879                 :        962 :   gfc_symbol *sym, *proc_if = NULL;
    6880                 :        962 :   int num;
    6881                 :        962 :   gfc_expr *initializer = NULL;
    6882                 :            : 
    6883                 :            :   /* Parse interface (with brackets).  */
    6884                 :        962 :   m = match_procedure_interface (&proc_if);
    6885                 :        962 :   if (m != MATCH_YES)
    6886                 :            :     return m;
    6887                 :            : 
    6888                 :            :   /* Parse attributes (with colons).  */
    6889                 :        962 :   m = match_attr_spec();
    6890                 :        962 :   if (m == MATCH_ERROR)
    6891                 :            :     return MATCH_ERROR;
    6892                 :            : 
    6893                 :        961 :   if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
    6894                 :            :     {
    6895                 :         16 :       current_attr.is_bind_c = 1;
    6896                 :         16 :       has_name_equals = 0;
    6897                 :         16 :       curr_binding_label = NULL;
    6898                 :            :     }
    6899                 :            : 
    6900                 :            :   /* Get procedure symbols.  */
    6901                 :         67 :   for(num=1;;num++)
    6902                 :            :     {
    6903                 :       1028 :       m = gfc_match_symbol (&sym, 0);
    6904                 :       1028 :       if (m == MATCH_NO)
    6905                 :          1 :         goto syntax;
    6906                 :       1027 :       else if (m == MATCH_ERROR)
    6907                 :            :         return m;
    6908                 :            : 
    6909                 :            :       /* Add current_attr to the symbol attributes.  */
    6910                 :       1027 :       if (!gfc_copy_attr (&sym->attr, &current_attr, NULL))
    6911                 :            :         return MATCH_ERROR;
    6912                 :            : 
    6913                 :       1026 :       if (sym->attr.is_bind_c)
    6914                 :            :         {
    6915                 :            :           /* Check for C1218.  */
    6916                 :         52 :           if (!proc_if || !proc_if->attr.is_bind_c)
    6917                 :            :             {
    6918                 :          1 :               gfc_error ("BIND(C) attribute at %C requires "
    6919                 :            :                         "an interface with BIND(C)");
    6920                 :          1 :               return MATCH_ERROR;
    6921                 :            :             }
    6922                 :            :           /* Check for C1217.  */
    6923                 :         51 :           if (has_name_equals && sym->attr.pointer)
    6924                 :            :             {
    6925                 :          1 :               gfc_error ("BIND(C) procedure with NAME may not have "
    6926                 :            :                         "POINTER attribute at %C");
    6927                 :          1 :               return MATCH_ERROR;
    6928                 :            :             }
    6929                 :         50 :           if (has_name_equals && sym->attr.dummy)
    6930                 :            :             {
    6931                 :          1 :               gfc_error ("Dummy procedure at %C may not have "
    6932                 :            :                         "BIND(C) attribute with NAME");
    6933                 :          1 :               return MATCH_ERROR;
    6934                 :            :             }
    6935                 :            :           /* Set binding label for BIND(C).  */
    6936                 :         49 :           if (!set_binding_label (&sym->binding_label, sym->name, num))
    6937                 :            :             return MATCH_ERROR;
    6938                 :            :         }
    6939                 :            : 
    6940                 :       1022 :       if (!gfc_add_external (&sym->attr, NULL))
    6941                 :            :         return MATCH_ERROR;
    6942                 :            : 
    6943                 :       1018 :       if (add_hidden_procptr_result (sym))
    6944                 :         64 :         sym = sym->result;
    6945                 :            : 
    6946                 :       1018 :       if (!gfc_add_proc (&sym->attr, sym->name, NULL))
    6947                 :            :         return MATCH_ERROR;
    6948                 :            : 
    6949                 :            :       /* Set interface.  */
    6950                 :       1017 :       if (proc_if != NULL)
    6951                 :            :         {
    6952                 :        686 :           if (sym->ts.type != BT_UNKNOWN)
    6953                 :            :             {
    6954                 :          1 :               gfc_error ("Procedure %qs at %L already has basic type of %s",
    6955                 :            :                          sym->name, &gfc_current_locus,
    6956                 :            :                          gfc_basic_typename (sym->ts.type));
    6957                 :          1 :               return MATCH_ERROR;
    6958                 :            :             }
    6959                 :        685 :           sym->ts.interface = proc_if;
    6960                 :        685 :           sym->attr.untyped = 1;
    6961                 :        685 :           sym->attr.if_source = IFSRC_IFBODY;
    6962                 :            :         }
    6963                 :        331 :       else if (current_ts.type != BT_UNKNOWN)
    6964                 :            :         {
    6965                 :        195 :           if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
    6966                 :            :             return MATCH_ERROR;
    6967                 :        194 :           sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
    6968                 :        194 :           sym->ts.interface->ts = current_ts;
    6969                 :        194 :           sym->ts.interface->attr.flavor = FL_PROCEDURE;
    6970                 :        194 :           sym->ts.interface->attr.function = 1;
    6971                 :        194 :           sym->attr.function = 1;
    6972                 :        194 :           sym->attr.if_source = IFSRC_UNKNOWN;
    6973                 :            :         }
    6974                 :            : 
    6975                 :       1015 :       if (gfc_match (" =>") == MATCH_YES)
    6976                 :            :         {
    6977                 :         78 :           if (!current_attr.pointer)
    6978                 :            :             {
    6979                 :          0 :               gfc_error ("Initialization at %C isn't for a pointer variable");
    6980                 :          0 :               m = MATCH_ERROR;
    6981                 :          0 :               goto cleanup;
    6982                 :            :             }
    6983                 :            : 
    6984                 :         78 :           m = match_pointer_init (&initializer, 1);
    6985                 :         78 :           if (m != MATCH_YES)
    6986                 :          1 :             goto cleanup;
    6987                 :            : 
    6988                 :         77 :           if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
    6989                 :          0 :             goto cleanup;
    6990                 :            : 
    6991                 :            :         }
    6992                 :            : 
    6993                 :       1014 :       if (gfc_match_eos () == MATCH_YES)
    6994                 :            :         return MATCH_YES;
    6995                 :         67 :       if (gfc_match_char (',') != MATCH_YES)
    6996                 :          0 :         goto syntax;
    6997                 :            :     }
    6998                 :            : 
    6999                 :          1 : syntax:
    7000                 :          1 :   gfc_error ("Syntax error in PROCEDURE statement at %C");
    7001                 :          1 :   return MATCH_ERROR;
    7002                 :            : 
    7003                 :          1 : cleanup:
    7004                 :            :   /* Free stuff up and return.  */
    7005                 :          1 :   gfc_free_expr (initializer);
    7006                 :          1 :   return m;
    7007                 :            : }
    7008                 :            : 
    7009                 :            : 
    7010                 :            : static match
    7011                 :            : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
    7012                 :            : 
    7013                 :            : 
    7014                 :            : /* Match a procedure pointer component declaration (R445).  */
    7015                 :            : 
    7016                 :            : static match
    7017                 :        378 : match_ppc_decl (void)
    7018                 :            : {
    7019                 :        378 :   match m;
    7020                 :        378 :   gfc_symbol *proc_if = NULL;
    7021                 :        378 :   gfc_typespec ts;
    7022                 :        378 :   int num;
    7023                 :        378 :   gfc_component *c;
    7024                 :        378 :   gfc_expr *initializer = NULL;
    7025                 :        378 :   gfc_typebound_proc* tb;
    7026                 :        378 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    7027                 :            : 
    7028                 :            :   /* Parse interface (with brackets).  */
    7029                 :        378 :   m = match_procedure_interface (&proc_if);
    7030                 :        378 :   if (m != MATCH_YES)
    7031                 :          1 :     goto syntax;
    7032                 :            : 
    7033                 :            :   /* Parse attributes.  */
    7034                 :        377 :   tb = XCNEW (gfc_typebound_proc);
    7035                 :        377 :   tb->where = gfc_current_locus;
    7036                 :        377 :   m = match_binding_attributes (tb, false, true);
    7037                 :        377 :   if (m == MATCH_ERROR)
    7038                 :            :     return m;
    7039                 :            : 
    7040                 :        374 :   gfc_clear_attr (&current_attr);
    7041                 :        374 :   current_attr.procedure = 1;
    7042                 :        374 :   current_attr.proc_pointer = 1;
    7043                 :        374 :   current_attr.access = tb->access;
    7044                 :        374 :   current_attr.flavor = FL_PROCEDURE;
    7045                 :            : 
    7046                 :            :   /* Match the colons (required).  */
    7047                 :        374 :   if (gfc_match (" ::") != MATCH_YES)
    7048                 :            :     {
    7049                 :          1 :       gfc_error ("Expected %<::%> after binding-attributes at %C");
    7050                 :          1 :       return MATCH_ERROR;
    7051                 :            :     }
    7052                 :            : 
    7053                 :            :   /* Check for C450.  */
    7054                 :        373 :   if (!tb->nopass && proc_if == NULL)
    7055                 :            :     {
    7056                 :          2 :       gfc_error("NOPASS or explicit interface required at %C");
    7057                 :          2 :       return MATCH_ERROR;
    7058                 :            :     }
    7059                 :            : 
    7060                 :        371 :   if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
    7061                 :            :     return MATCH_ERROR;
    7062                 :            : 
    7063                 :            :   /* Match PPC names.  */
    7064                 :        370 :   ts = current_ts;
    7065                 :        370 :   for(num=1;;num++)
    7066                 :            :     {
    7067                 :        371 :       m = gfc_match_name (name);
    7068                 :        371 :       if (m == MATCH_NO)
    7069                 :          0 :         goto syntax;
    7070                 :        371 :       else if (m == MATCH_ERROR)
    7071                 :            :         return m;
    7072                 :            : 
    7073                 :        371 :       if (!gfc_add_component (gfc_current_block(), name, &c))
    7074                 :            :         return MATCH_ERROR;
    7075                 :            : 
    7076                 :            :       /* Add current_attr to the symbol attributes.  */
    7077                 :        371 :       if (!gfc_copy_attr (&c->attr, &current_attr, NULL))
    7078                 :            :         return MATCH_ERROR;
    7079                 :            : 
    7080                 :        371 :       if (!gfc_add_external (&c->attr, NULL))
    7081                 :            :         return MATCH_ERROR;
    7082                 :            : 
    7083                 :        371 :       if (!gfc_add_proc (&c->attr, name, NULL))
    7084                 :            :         return MATCH_ERROR;
    7085                 :            : 
    7086                 :        371 :       if (num == 1)
    7087                 :        370 :         c->tb = tb;
    7088                 :            :       else
    7089                 :            :         {
    7090                 :          1 :           c->tb = XCNEW (gfc_typebound_proc);
    7091                 :          1 :           c->tb->where = gfc_current_locus;
    7092                 :          1 :           *c->tb = *tb;
    7093                 :            :         }
    7094                 :            : 
    7095                 :            :       /* Set interface.  */
    7096                 :        371 :       if (proc_if != NULL)
    7097                 :            :         {
    7098                 :        321 :           c->ts.interface = proc_if;
    7099                 :        321 :           c->attr.untyped = 1;
    7100                 :        321 :           c->attr.if_source = IFSRC_IFBODY;
    7101                 :            :         }
    7102                 :         50 :       else if (ts.type != BT_UNKNOWN)
    7103                 :            :         {
    7104                 :         23 :           c->ts = ts;
    7105                 :         23 :           c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
    7106                 :         23 :           c->ts.interface->result = c->ts.interface;
    7107                 :         23 :           c->ts.interface->ts = ts;
    7108                 :         23 :           c->ts.interface->attr.flavor = FL_PROCEDURE;
    7109                 :         23 :           c->ts.interface->attr.function = 1;
    7110                 :         23 :           c->attr.function = 1;
    7111                 :         23 :           c->attr.if_source = IFSRC_UNKNOWN;
    7112                 :            :         }
    7113                 :            : 
    7114                 :        371 :       if (gfc_match (" =>") == MATCH_YES)
    7115                 :            :         {
    7116                 :         53 :           m = match_pointer_init (&initializer, 1);
    7117                 :         53 :           if (m != MATCH_YES)
    7118                 :            :             {
    7119                 :          0 :               gfc_free_expr (initializer);
    7120                 :          0 :               return m;
    7121                 :            :             }
    7122                 :         53 :           c->initializer = initializer;
    7123                 :            :         }
    7124                 :            : 
    7125                 :        371 :       if (gfc_match_eos () == MATCH_YES)
    7126                 :            :         return MATCH_YES;
    7127                 :          1 :       if (gfc_match_char (',') != MATCH_YES)
    7128                 :          0 :         goto syntax;
    7129                 :            :     }
    7130                 :            : 
    7131                 :          1 : syntax:
    7132                 :          1 :   gfc_error ("Syntax error in procedure pointer component at %C");
    7133                 :          1 :   return MATCH_ERROR;
    7134                 :            : }
    7135                 :            : 
    7136                 :            : 
    7137                 :            : /* Match a PROCEDURE declaration inside an interface (R1206).  */
    7138                 :            : 
    7139                 :            : static match
    7140                 :       1353 : match_procedure_in_interface (void)
    7141                 :            : {
    7142                 :       1353 :   match m;
    7143                 :       1353 :   gfc_symbol *sym;
    7144                 :       1353 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    7145                 :       1353 :   locus old_locus;
    7146                 :            : 
    7147                 :       1353 :   if (current_interface.type == INTERFACE_NAMELESS
    7148                 :       1353 :       || current_interface.type == INTERFACE_ABSTRACT)
    7149                 :            :     {
    7150                 :          1 :       gfc_error ("PROCEDURE at %C must be in a generic interface");
    7151                 :          1 :       return MATCH_ERROR;
    7152                 :            :     }
    7153                 :            : 
    7154                 :            :   /* Check if the F2008 optional double colon appears.  */
    7155                 :       1352 :   gfc_gobble_whitespace ();
    7156                 :       1352 :   old_locus = gfc_current_locus;
    7157                 :       1352 :   if (gfc_match ("::") == MATCH_YES)
    7158                 :            :     {
    7159                 :        799 :       if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
    7160                 :            :                            "MODULE PROCEDURE statement at %L", &old_locus))
    7161                 :            :         return MATCH_ERROR;
    7162                 :            :     }
    7163                 :            :   else
    7164                 :        553 :     gfc_current_locus = old_locus;
    7165                 :            : 
    7166                 :       1789 :   for(;;)
    7167                 :            :     {
    7168                 :       1789 :       m = gfc_match_name (name);
    7169                 :       1789 :       if (m == MATCH_NO)
    7170                 :          0 :         goto syntax;
    7171                 :       1789 :       else if (m == MATCH_ERROR)
    7172                 :            :         return m;
    7173                 :       1789 :       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
    7174                 :            :         return MATCH_ERROR;
    7175                 :            : 
    7176                 :       1789 :       if (!gfc_add_interface (sym))
    7177                 :            :         return MATCH_ERROR;
    7178                 :            : 
    7179                 :       1788 :       if (gfc_match_eos () == MATCH_YES)
    7180                 :            :         break;
    7181                 :        438 :       if (gfc_match_char (',') != MATCH_YES)
    7182                 :          0 :         goto syntax;
    7183                 :            :     }
    7184                 :            : 
    7185                 :            :   return MATCH_YES;
    7186                 :            : 
    7187                 :          0 : syntax:
    7188                 :          0 :   gfc_error ("Syntax error in PROCEDURE statement at %C");
    7189                 :          0 :   return MATCH_ERROR;
    7190                 :            : }
    7191                 :            : 
    7192                 :            : 
    7193                 :            : /* General matcher for PROCEDURE declarations.  */
    7194                 :            : 
    7195                 :            : static match match_procedure_in_type (void);
    7196                 :            : 
    7197                 :            : match
    7198                 :       5306 : gfc_match_procedure (void)
    7199                 :            : {
    7200                 :       5306 :   match m;
    7201                 :            : 
    7202                 :       5306 :   switch (gfc_current_state ())
    7203                 :            :     {
    7204                 :        962 :     case COMP_NONE:
    7205                 :        962 :     case COMP_PROGRAM:
    7206                 :        962 :     case COMP_MODULE:
    7207                 :        962 :     case COMP_SUBMODULE:
    7208                 :        962 :     case COMP_SUBROUTINE:
    7209                 :        962 :     case COMP_FUNCTION:
    7210                 :        962 :     case COMP_BLOCK:
    7211                 :        962 :       m = match_procedure_decl ();
    7212                 :        962 :       break;
    7213                 :       1353 :     case COMP_INTERFACE:
    7214                 :       1353 :       m = match_procedure_in_interface ();
    7215                 :       1353 :       break;
    7216                 :        378 :     case COMP_DERIVED:
    7217                 :        378 :       m = match_ppc_decl ();
    7218                 :        378 :       break;
    7219                 :       2613 :     case COMP_DERIVED_CONTAINS:
    7220                 :       2613 :       m = match_procedure_in_type ();
    7221                 :       2613 :       break;
    7222                 :            :     default:
    7223                 :            :       return MATCH_NO;
    7224                 :            :     }
    7225                 :            : 
    7226                 :       5306 :   if (m != MATCH_YES)
    7227                 :            :     return m;
    7228                 :            : 
    7229                 :       5251 :   if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
    7230                 :          3 :     return MATCH_ERROR;
    7231                 :            : 
    7232                 :            :   return m;
    7233                 :            : }
    7234                 :            : 
    7235                 :            : 
    7236                 :            : /* Warn if a matched procedure has the same name as an intrinsic; this is
    7237                 :            :    simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
    7238                 :            :    parser-state-stack to find out whether we're in a module.  */
    7239                 :            : 
    7240                 :            : static void
    7241                 :      39292 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
    7242                 :            : {
    7243                 :      39292 :   bool in_module;
    7244                 :            : 
    7245                 :      78584 :   in_module = (gfc_state_stack->previous
    7246                 :      39292 :                && (gfc_state_stack->previous->state == COMP_MODULE
    7247                 :      29919 :                    || gfc_state_stack->previous->state == COMP_SUBMODULE));
    7248                 :            : 
    7249                 :      39292 :   gfc_warn_intrinsic_shadow (sym, in_module, func);
    7250                 :      39292 : }
    7251                 :            : 
    7252                 :            : 
    7253                 :            : /* Match a function declaration.  */
    7254                 :            : 
    7255                 :            : match
    7256                 :      87297 : gfc_match_function_decl (void)
    7257                 :            : {
    7258                 :      87297 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    7259                 :      87297 :   gfc_symbol *sym, *result;
    7260                 :      87297 :   locus old_loc;
    7261                 :      87297 :   match m;
    7262                 :      87297 :   match suffix_match;
    7263                 :      87297 :   match found_match; /* Status returned by match func.  */
    7264                 :            : 
    7265                 :      87297 :   if (gfc_current_state () != COMP_NONE
    7266                 :      49804 :       && gfc_current_state () != COMP_INTERFACE
    7267                 :      33058 :       && gfc_current_state () != COMP_CONTAINS)
    7268                 :            :     return MATCH_NO;
    7269                 :            : 
    7270                 :      87297 :   gfc_clear_ts (&current_ts);
    7271                 :            : 
    7272                 :      87297 :   old_loc = gfc_current_locus;
    7273                 :            : 
    7274                 :      87297 :   m = gfc_match_prefix (&current_ts);
    7275                 :      87297 :   if (m != MATCH_YES)
    7276                 :            :     {
    7277                 :       7207 :       gfc_current_locus = old_loc;
    7278                 :       7207 :       return m;
    7279                 :            :     }
    7280                 :            : 
    7281                 :      80090 :   if (gfc_match ("function% %n", name) != MATCH_YES)
    7282                 :            :     {
    7283                 :      67223 :       gfc_current_locus = old_loc;
    7284                 :      67223 :       return MATCH_NO;
    7285                 :            :     }
    7286                 :            : 
    7287                 :      12867 :   if (get_proc_name (name, &sym, false))
    7288                 :            :     return MATCH_ERROR;
    7289                 :            : 
    7290                 :      12864 :   if (add_hidden_procptr_result (sym))
    7291                 :         19 :     sym = sym->result;
    7292                 :            : 
    7293                 :      12864 :   if (current_attr.module_procedure)
    7294                 :        182 :     sym->attr.module_procedure = 1;
    7295                 :            : 
    7296                 :      12864 :   gfc_new_block = sym;
    7297                 :            : 
    7298                 :      12864 :   m = gfc_match_formal_arglist (sym, 0, 0);
    7299                 :      12864 :   if (m == MATCH_NO)
    7300                 :            :     {
    7301                 :          6 :       gfc_error ("Expected formal argument list in function "
    7302                 :            :                  "definition at %C");
    7303                 :          6 :       m = MATCH_ERROR;
    7304                 :          6 :       goto cleanup;
    7305                 :            :     }
    7306                 :      12858 :   else if (m == MATCH_ERROR)
    7307                 :          1 :     goto cleanup;
    7308                 :            : 
    7309                 :      12857 :   result = NULL;
    7310                 :            : 
    7311                 :            :   /* According to the draft, the bind(c) and result clause can
    7312                 :            :      come in either order after the formal_arg_list (i.e., either
    7313                 :            :      can be first, both can exist together or by themselves or neither
    7314                 :            :      one).  Therefore, the match_result can't match the end of the
    7315                 :            :      string, and check for the bind(c) or result clause in either order.  */
    7316                 :      12857 :   found_match = gfc_match_eos ();
    7317                 :            : 
    7318                 :            :   /* Make sure that it isn't already declared as BIND(C).  If it is, it
    7319                 :            :      must have been marked BIND(C) with a BIND(C) attribute and that is
    7320                 :            :      not allowed for procedures.  */
    7321                 :      12857 :   if (sym->attr.is_bind_c == 1)
    7322                 :            :     {
    7323                 :          3 :       sym->attr.is_bind_c = 0;
    7324                 :            : 
    7325                 :          3 :       if (gfc_state_stack->previous
    7326                 :          3 :           && gfc_state_stack->previous->state != COMP_SUBMODULE)
    7327                 :            :         {
    7328                 :          1 :           locus loc;
    7329                 :          2 :           loc = sym->old_symbol != NULL
    7330                 :          1 :             ? sym->old_symbol->declared_at : gfc_current_locus;
    7331                 :          1 :           gfc_error_now ("BIND(C) attribute at %L can only be used for "
    7332                 :            :                          "variables or common blocks", &loc);
    7333                 :            :         }
    7334                 :            :     }
    7335                 :            : 
    7336                 :      12857 :   if (found_match != MATCH_YES)
    7337                 :            :     {
    7338                 :            :       /* If we haven't found the end-of-statement, look for a suffix.  */
    7339                 :       4037 :       suffix_match = gfc_match_suffix (sym, &result);
    7340                 :       4037 :       if (suffix_match == MATCH_YES)
    7341                 :            :         /* Need to get the eos now.  */
    7342                 :       4029 :         found_match = gfc_match_eos ();
    7343                 :            :       else
    7344                 :            :         found_match = suffix_match;
    7345                 :            :     }
    7346                 :            : 
    7347                 :            :   /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
    7348                 :            :      subprogram and a binding label is specified, it shall be the
    7349                 :            :      same as the binding label specified in the corresponding module
    7350                 :            :      procedure interface body.  */
    7351                 :      12857 :     if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
    7352                 :          2 :         && strcmp (sym->name, sym->old_symbol->name) == 0
    7353                 :          2 :         && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
    7354                 :            :       {
    7355                 :          1 :           const char *null = "NULL", *s1, *s2;
    7356                 :          1 :           s1 = sym->binding_label;
    7357                 :          1 :           if (!s1) s1 = null;
    7358                 :          1 :           s2 = sym->old_symbol->binding_label;
    7359                 :          1 :           if (!s2) s2 = null;
    7360                 :          1 :           gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
    7361                 :          1 :           sym->refs++;       /* Needed to avoid an ICE in gfc_release_symbol */
    7362                 :          1 :           return MATCH_ERROR;
    7363                 :            :       }
    7364                 :            : 
    7365                 :      12856 :   if(found_match != MATCH_YES)
    7366                 :            :     m = MATCH_ERROR;
    7367                 :            :   else
    7368                 :            :     {
    7369                 :            :       /* Make changes to the symbol.  */
    7370                 :      12848 :       m = MATCH_ERROR;
    7371                 :            : 
    7372                 :      12848 :       if (!gfc_add_function (&sym->attr, sym->name, NULL))
    7373                 :          0 :         goto cleanup;
    7374                 :            : 
    7375                 :      12848 :       if (!gfc_missing_attr (&sym->attr, NULL))
    7376                 :          0 :         goto cleanup;
    7377                 :            : 
    7378                 :      12848 :       if (!copy_prefix (&sym->attr, &sym->declared_at))
    7379                 :            :         {
    7380                 :          1 :           if(!sym->attr.module_procedure)
    7381                 :          1 :         goto cleanup;
    7382                 :            :           else
    7383                 :          0 :             gfc_error_check ();
    7384                 :            :         }
    7385                 :            : 
    7386                 :            :       /* Delay matching the function characteristics until after the
    7387                 :            :          specification block by signalling kind=-1.  */
    7388                 :      12847 :       sym->declared_at = old_loc;
    7389                 :      12847 :       if (current_ts.type != BT_UNKNOWN)
    7390                 :       3763 :         current_ts.kind = -1;
    7391                 :            :       else
    7392                 :       9084 :         current_ts.kind = 0;
    7393                 :            : 
    7394                 :      12847 :       if (result == NULL)
    7395                 :            :         {
    7396                 :       9140 :           if (current_ts.type != BT_UNKNOWN
    7397                 :       9140 :               && !gfc_add_type (sym, &current_ts, &gfc_current_locus))
    7398                 :          1 :             goto cleanup;
    7399                 :       9139 :           sym->result = sym;
    7400                 :            :         }
    7401                 :            :       else
    7402                 :            :         {
    7403                 :       3707 :           if (current_ts.type != BT_UNKNOWN
    7404                 :       3707 :               && !gfc_add_type (result, &current_ts, &gfc_current_locus))
    7405                 :          0 :             goto cleanup;
    7406                 :       3707 :           sym->result = result;
    7407                 :            :         }
    7408                 :            : 
    7409                 :            :       /* Warn if this procedure has the same name as an intrinsic.  */
    7410                 :      12846 :       do_warn_intrinsic_shadow (sym, true);
    7411                 :            : 
    7412                 :      12846 :       return MATCH_YES;
    7413                 :            :     }
    7414                 :            : 
    7415                 :         17 : cleanup:
    7416                 :         17 :   gfc_current_locus = old_loc;
    7417                 :         17 :   return m;
    7418                 :            : }
    7419                 :            : 
    7420                 :            : 
    7421                 :            : /* This is mostly a copy of parse.c(add_global_procedure) but modified to
    7422                 :            :    pass the name of the entry, rather than the gfc_current_block name, and
    7423                 :            :    to return false upon finding an existing global entry.  */
    7424                 :            : 
    7425                 :            : static bool
    7426                 :        491 : add_global_entry (const char *name, const char *binding_label, bool sub,
    7427                 :            :                   locus *where)
    7428                 :            : {
    7429                 :        491 :   gfc_gsymbol *s;
    7430                 :        491 :   enum gfc_symbol_type type;
    7431                 :            : 
    7432                 :        491 :   type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
    7433                 :            : 
    7434                 :            :   /* Only in Fortran 2003: For procedures with a binding label also the Fortran
    7435                 :            :      name is a global identifier.  */
    7436                 :        491 :   if (!binding_label || gfc_notification_std (GFC_STD_F2008))
    7437                 :            :     {
    7438                 :        486 :       s = gfc_get_gsymbol (name, false);
    7439                 :            : 
    7440                 :        486 :       if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
    7441                 :            :         {
    7442                 :          2 :           gfc_global_used (s, where);
    7443                 :          2 :           return false;
    7444                 :            :         }
    7445                 :            :       else
    7446                 :            :         {
    7447                 :        484 :           s->type = type;
    7448                 :        484 :           s->sym_name = name;
    7449                 :        484 :           s->where = *where;
    7450                 :        484 :           s->defined = 1;
    7451                 :        484 :           s->ns = gfc_current_ns;
    7452                 :            :         }
    7453                 :            :     }
    7454                 :            : 
    7455                 :            :   /* Don't add the symbol multiple times.  */
    7456                 :        489 :   if (binding_label
    7457                 :        489 :       && (!gfc_notification_std (GFC_STD_F2008)
    7458                 :          0 :           || strcmp (name, binding_label) != 0))
    7459                 :            :     {
    7460                 :          5 :       s = gfc_get_gsymbol (binding_label, true);
    7461                 :            : 
    7462                 :          5 :       if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
    7463                 :            :         {
    7464                 :          1 :           gfc_global_used (s, where);
    7465                 :          1 :           return false;
    7466                 :            :         }
    7467                 :            :       else
    7468                 :            :         {
    7469                 :          4 :           s->type = type;
    7470                 :          4 :           s->sym_name = name;
    7471                 :          4 :           s->binding_label = binding_label;
    7472                 :          4 :           s->where = *where;
    7473                 :          4 :           s->defined = 1;
    7474                 :          4 :           s->ns = gfc_current_ns;
    7475                 :            :         }
    7476                 :            :     }
    7477                 :            : 
    7478                 :            :   return true;
    7479                 :            : }
    7480                 :            : 
    7481                 :            : 
    7482                 :            : /* Match an ENTRY statement.  */
    7483                 :            : 
    7484                 :            : match
    7485                 :        706 : gfc_match_entry (void)
    7486                 :            : {
    7487                 :        706 :   gfc_symbol *proc;
    7488                 :        706 :   gfc_symbol *result;
    7489                 :        706 :   gfc_symbol *entry;
    7490                 :        706 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    7491                 :        706 :   gfc_compile_state state;
    7492                 :        706 :   match m;
    7493                 :        706 :   gfc_entry_list *el;
    7494                 :        706 :   locus old_loc;
    7495                 :        706 :   bool module_procedure;
    7496                 :        706 :   char peek_char;
    7497                 :        706 :   match is_bind_c;
    7498                 :            : 
    7499                 :        706 :   m = gfc_match_name (name);
    7500                 :        706 :   if (m != MATCH_YES)
    7501                 :            :     return m;
    7502                 :            : 
    7503                 :        706 :   if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
    7504                 :            :     return MATCH_ERROR;
    7505                 :            : 
    7506                 :        706 :   state = gfc_current_state ();
    7507                 :        706 :   if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
    7508                 :            :     {
    7509                 :          3 :       switch (state)
    7510                 :            :         {
    7511                 :          0 :           case COMP_PROGRAM:
    7512                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
    7513                 :          0 :             break;
    7514                 :          0 :           case COMP_MODULE:
    7515                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
    7516                 :          0 :             break;
    7517                 :          0 :           case COMP_SUBMODULE:
    7518                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
    7519                 :          0 :             break;
    7520                 :          0 :           case COMP_BLOCK_DATA:
    7521                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7522                 :            :                        "a BLOCK DATA");
    7523                 :          0 :             break;
    7524                 :          0 :           case COMP_INTERFACE:
    7525                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7526                 :            :                        "an INTERFACE");
    7527                 :          0 :             break;
    7528                 :          1 :           case COMP_STRUCTURE:
    7529                 :          1 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7530                 :            :                        "a STRUCTURE block");
    7531                 :          1 :             break;
    7532                 :          0 :           case COMP_DERIVED:
    7533                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7534                 :            :                        "a DERIVED TYPE block");
    7535                 :          0 :             break;
    7536                 :          0 :           case COMP_IF:
    7537                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7538                 :            :                        "an IF-THEN block");
    7539                 :          0 :             break;
    7540                 :          0 :           case COMP_DO:
    7541                 :          0 :           case COMP_DO_CONCURRENT:
    7542                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7543                 :            :                        "a DO block");
    7544                 :          0 :             break;
    7545                 :          0 :           case COMP_SELECT:
    7546                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7547                 :            :                        "a SELECT block");
    7548                 :          0 :             break;
    7549                 :          0 :           case COMP_FORALL:
    7550                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7551                 :            :                        "a FORALL block");
    7552                 :          0 :             break;
    7553                 :          0 :           case COMP_WHERE:
    7554                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7555                 :            :                        "a WHERE block");
    7556                 :          0 :             break;
    7557                 :          0 :           case COMP_CONTAINS:
    7558                 :          0 :             gfc_error ("ENTRY statement at %C cannot appear within "
    7559                 :            :                        "a contained subprogram");
    7560                 :          0 :             break;
    7561                 :          2 :           default:
    7562                 :          2 :             gfc_error ("Unexpected ENTRY statement at %C");
    7563                 :            :         }
    7564                 :          3 :       return MATCH_ERROR;
    7565                 :            :     }
    7566                 :            : 
    7567                 :        703 :   if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
    7568                 :        703 :       && gfc_state_stack->previous->state == COMP_INTERFACE)
    7569                 :            :     {
    7570                 :          1 :       gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
    7571                 :          1 :       return MATCH_ERROR;
    7572                 :            :     }
    7573                 :            : 
    7574                 :       1404 :   module_procedure = gfc_current_ns->parent != NULL
    7575                 :        209 :                    && gfc_current_ns->parent->proc_name
    7576                 :        702 :                    && gfc_current_ns->parent->proc_name->attr.flavor
    7577                 :        209 :                       == FL_MODULE;
    7578                 :            : 
    7579                 :        702 :   if (gfc_current_ns->parent != NULL
    7580                 :        209 :       && gfc_current_ns->parent->proc_name
    7581                 :        209 :       && !module_procedure)
    7582                 :            :     {
    7583                 :          0 :       gfc_error("ENTRY statement at %C cannot appear in a "
    7584                 :            :                 "contained procedure");
    7585                 :          0 :       return MATCH_ERROR;
    7586                 :            :     }
    7587                 :            : 
    7588                 :            :   /* Module function entries need special care in get_proc_name
    7589                 :            :      because previous references within the function will have
    7590                 :            :      created symbols attached to the current namespace.  */
    7591                 :        702 :   if (get_proc_name (name, &entry,
    7592                 :            :                      gfc_current_ns->parent != NULL
    7593                 :        702 :                      && module_procedure))
    7594                 :            :     return MATCH_ERROR;
    7595                 :            : 
    7596                 :        700 :   proc = gfc_current_block ();
    7597                 :            : 
    7598                 :            :   /* Make sure that it isn't already declared as BIND(C).  If it is, it
    7599                 :            :      must have been marked BIND(C) with a BIND(C) attribute and that is
    7600                 :            :      not allowed for procedures.  */
    7601                 :        700 :   if (entry->attr.is_bind_c == 1)
    7602                 :            :     {
    7603                 :          0 :       locus loc;
    7604                 :            : 
    7605                 :          0 :       entry->attr.is_bind_c = 0;
    7606                 :            : 
    7607                 :          0 :       loc = entry->old_symbol != NULL
    7608                 :          0 :         ? entry->old_symbol->declared_at : gfc_current_locus;
    7609                 :          0 :       gfc_error_now ("BIND(C) attribute at %L can only be used for "
    7610                 :            :                      "variables or common blocks", &loc);
    7611                 :            :      }
    7612                 :            : 
    7613                 :            :   /* Check what next non-whitespace character is so we can tell if there
    7614                 :            :      is the required parens if we have a BIND(C).  */
    7615                 :        700 :   old_loc = gfc_current_locus;
    7616                 :        700 :   gfc_gobble_whitespace ();
    7617                 :        700 :   peek_char = gfc_peek_ascii_char ();
    7618                 :            : 
    7619                 :        700 :   if (state == COMP_SUBROUTINE)
    7620                 :            :     {
    7621                 :        124 :       m = gfc_match_formal_arglist (entry, 0, 1);
    7622                 :        124 :       if (m != MATCH_YES)
    7623                 :            :         return MATCH_ERROR;
    7624                 :            : 
    7625                 :            :       /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
    7626                 :            :          never be an internal procedure.  */
    7627                 :        124 :       is_bind_c = gfc_match_bind_c (entry, true);
    7628                 :        124 :       if (is_bind_c == MATCH_ERROR)
    7629                 :            :         return MATCH_ERROR;
    7630                 :        124 :       if (is_bind_c == MATCH_YES)
    7631                 :            :         {
    7632                 :         22 :           if (peek_char != '(')
    7633                 :            :             {
    7634                 :          0 :               gfc_error ("Missing required parentheses before BIND(C) at %C");
    7635                 :          0 :               return MATCH_ERROR;
    7636                 :            :             }
    7637                 :            : 
    7638                 :         22 :           if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
    7639                 :         22 :                                   &(entry->declared_at), 1))
    7640                 :            :             return MATCH_ERROR;
    7641                 :            : 
    7642                 :            :         }
    7643                 :            : 
    7644                 :        124 :       if (!gfc_current_ns->parent
    7645                 :        124 :           && !add_global_entry (name, entry->binding_label, true,
    7646                 :            :                                 &old_loc))
    7647                 :            :         return MATCH_ERROR;
    7648                 :            : 
    7649                 :            :       /* An entry in a subroutine.  */
    7650                 :        121 :       if (!gfc_add_entry (&entry->attr, entry->name, NULL)
    7651                 :        121 :           || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
    7652                 :          3 :         return MATCH_ERROR;
    7653                 :            :     }
    7654                 :            :   else
    7655                 :            :     {
    7656                 :            :       /* An entry in a function.
    7657                 :            :          We need to take special care because writing
    7658                 :            :             ENTRY f()
    7659                 :            :          as
    7660                 :            :             ENTRY f
    7661                 :            :          is allowed, whereas
    7662                 :            :             ENTRY f() RESULT (r)
    7663                 :            :          can't be written as
    7664                 :            :             ENTRY f RESULT (r).  */
    7665                 :        576 :       if (gfc_match_eos () == MATCH_YES)
    7666                 :            :         {
    7667                 :         24 :           gfc_current_locus = old_loc;
    7668                 :            :           /* Match the empty argument list, and add the interface to
    7669                 :            :              the symbol.  */
    7670                 :         24 :           m = gfc_match_formal_arglist (entry, 0, 1);
    7671                 :            :         }
    7672                 :            :       else
    7673                 :        552 :         m = gfc_match_formal_arglist (entry, 0, 0);
    7674                 :            : 
    7675                 :        576 :       if (m != MATCH_YES)
    7676                 :            :         return MATCH_ERROR;
    7677                 :            : 
    7678                 :        575 :       result = NULL;
    7679                 :            : 
    7680                 :        575 :       if (gfc_match_eos () == MATCH_YES)
    7681                 :            :         {
    7682                 :        344 :           if (!gfc_add_entry (&entry->attr, entry->name, NULL)
    7683                 :        344 :               || !gfc_add_function (&entry->attr, entry->name, NULL))
    7684                 :          2 :             return MATCH_ERROR;
    7685                 :            : 
    7686                 :        342 :           entry->result = entry;
    7687                 :            :         }
    7688                 :            :       else
    7689                 :            :         {
    7690                 :        231 :           m = gfc_match_suffix (entry, &result);
    7691                 :        231 :           if (m == MATCH_NO)
    7692                 :          0 :             gfc_syntax_error (ST_ENTRY);
    7693                 :        231 :           if (m != MATCH_YES)
    7694                 :            :             return MATCH_ERROR;
    7695                 :            : 
    7696                 :        231 :           if (result)
    7697                 :            :             {
    7698                 :        212 :               if (!gfc_add_result (&result->attr, result->name, NULL)
    7699                 :        212 :                   || !gfc_add_entry (&entry->attr, result->name, NULL)
    7700                 :        424 :                   || !gfc_add_function (&entry->attr, result->name, NULL))
    7701                 :          0 :                 return MATCH_ERROR;
    7702                 :        212 :               entry->result = result;
    7703                 :            :             }
    7704                 :            :           else
    7705                 :            :             {
    7706                 :         19 :               if (!gfc_add_entry (&entry->attr, entry->name, NULL)
    7707                 :         19 :                   || !gfc_add_function (&entry->attr, entry->name, NULL))
    7708                 :          0 :                 return MATCH_ERROR;
    7709                 :         19 :               entry->result = entry;
    7710                 :            :             }
    7711                 :            :         }
    7712                 :            : 
    7713                 :        573 :       if (!gfc_current_ns->parent
    7714                 :        573 :           && !add_global_entry (name, entry->binding_label, false,
    7715                 :            :                                 &old_loc))
    7716                 :            :         return MATCH_ERROR;
    7717                 :            :     }
    7718                 :            : 
    7719                 :        691 :   if (gfc_match_eos () != MATCH_YES)
    7720                 :            :     {
    7721                 :          0 :       gfc_syntax_error (ST_ENTRY);
    7722                 :          0 :       return MATCH_ERROR;
    7723                 :            :     }
    7724                 :            : 
    7725                 :            :   /* F2018:C1546 An elemental procedure shall not have the BIND attribute.  */
    7726                 :        691 :   if (proc->attr.elemental && entry->attr.is_bind_c)
    7727                 :            :     {
    7728                 :          2 :       gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
    7729                 :            :                  "elemental procedure", &entry->declared_at);
    7730                 :          2 :       return MATCH_ERROR;
    7731                 :            :     }
    7732                 :            : 
    7733                 :        689 :   entry->attr.recursive = proc->attr.recursive;
    7734                 :        689 :   entry->attr.elemental = proc->attr.elemental;
    7735                 :        689 :   entry->attr.pure = proc->attr.pure;
    7736                 :            : 
    7737                 :        689 :   el = gfc_get_entry_list ();
    7738                 :        689 :   el->sym = entry;
    7739                 :        689 :   el->next = gfc_current_ns->entries;
    7740                 :        689 :   gfc_current_ns->entries = el;
    7741                 :        689 :   if (el->next)
    7742                 :         84 :     el->id = el->next->id + 1;
    7743                 :            :   else
    7744                 :        605 :     el->id = 1;
    7745                 :            : 
    7746                 :        689 :   new_st.op = EXEC_ENTRY;
    7747                 :        689 :   new_st.ext.entry = el;
    7748                 :            : 
    7749                 :        689 :   return MATCH_YES;
    7750                 :            : }
    7751                 :            : 
    7752                 :            : 
    7753                 :            : /* Match a subroutine statement, including optional prefixes.  */
    7754                 :            : 
    7755                 :            : match
    7756                 :     522218 : gfc_match_subroutine (void)
    7757                 :            : {
    7758                 :     522218 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    7759                 :     522218 :   gfc_symbol *sym;
    7760                 :     522218 :   match m;
    7761                 :     522218 :   match is_bind_c;
    7762                 :     522218 :   char peek_char;
    7763                 :     522218 :   bool allow_binding_name;
    7764                 :     522218 :   locus loc;
    7765                 :            : 
    7766                 :     522218 :   if (gfc_current_state () != COMP_NONE
    7767                 :     490110 :       && gfc_current_state () != COMP_INTERFACE
    7768                 :     476295 :       && gfc_current_state () != COMP_CONTAINS)
    7769                 :            :     return MATCH_NO;
    7770                 :            : 
    7771                 :      71616 :   m = gfc_match_prefix (NULL);
    7772                 :      71616 :   if (m != MATCH_YES)
    7773                 :            :     return m;
    7774                 :            : 
    7775                 :      64416 :   m = gfc_match ("subroutine% %n", name);
    7776                 :      64416 :   if (m != MATCH_YES)
    7777                 :            :     return m;
    7778                 :            : 
    7779                 :      26477 :   if (get_proc_name (name, &sym, false))
    7780                 :            :     return MATCH_ERROR;
    7781                 :            : 
    7782                 :            :   /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
    7783                 :            :      the symbol existed before.  */
    7784                 :      26466 :   sym->declared_at = gfc_current_locus;
    7785                 :            : 
    7786                 :      26466 :   if (current_attr.module_procedure)
    7787                 :        269 :     sym->attr.module_procedure = 1;
    7788                 :            : 
    7789                 :      26466 :   if (add_hidden_procptr_result (sym))
    7790                 :          7 :     sym = sym->result;
    7791                 :            : 
    7792                 :      26466 :   gfc_new_block = sym;
    7793                 :            : 
    7794                 :            :   /* Check what next non-whitespace character is so we can tell if there
    7795                 :            :      is the required parens if we have a BIND(C).  */
    7796                 :      26466 :   gfc_gobble_whitespace ();
    7797                 :      26466 :   peek_char = gfc_peek_ascii_char ();
    7798                 :            : 
    7799                 :      26466 :   if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
    7800                 :            :     return MATCH_ERROR;
    7801                 :            : 
    7802                 :      26465 :   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
    7803                 :            :     return MATCH_ERROR;
    7804                 :            : 
    7805                 :            :   /* Make sure that it isn't already declared as BIND(C).  If it is, it
    7806                 :            :      must have been marked BIND(C) with a BIND(C) attribute and that is
    7807                 :            :      not allowed for procedures.  */
    7808                 :      26465 :   if (sym->attr.is_bind_c == 1)
    7809                 :            :     {
    7810                 :          4 :       sym->attr.is_bind_c = 0;
    7811                 :            : 
    7812                 :          4 :       if (gfc_state_stack->previous
    7813                 :          4 :           && gfc_state_stack->previous->state != COMP_SUBMODULE)
    7814                 :            :         {
    7815                 :          2 :           locus loc;
    7816                 :          4 :           loc = sym->old_symbol != NULL
    7817                 :          2 :             ? sym->old_symbol->declared_at : gfc_current_locus;
    7818                 :          2 :           gfc_error_now ("BIND(C) attribute at %L can only be used for "
    7819                 :            :                          "variables or common blocks", &loc);
    7820                 :            :         }
    7821                 :            :     }
    7822                 :            : 
    7823                 :            :   /* C binding names are not allowed for internal procedures.  */
    7824                 :      26465 :   if (gfc_current_state () == COMP_CONTAINS
    7825                 :      14597 :       && sym->ns->proc_name->attr.flavor != FL_MODULE)</