1 /*
2  * Copyright (c) 1994-2019, NVIDIA CORPORATION.  All rights reserved.
3  *
4  * Licensed under the Apache License, Version 2.0 (the "License");
5  * you may not use this file except in compliance with the License.
6  * You may obtain a copy of the License at
7  *
8  *     http://www.apache.org/licenses/LICENSE-2.0
9  *
10  * Unless required by applicable law or agreed to in writing, software
11  * distributed under the License is distributed on an "AS IS" BASIS,
12  * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13  * See the License for the specific language governing permissions and
14  * limitations under the License.
15  *
16  */
17 
18 /**
19     \file
20     \brief This file contains part 1 of the compiler's semantic actions
21     (also known as the semant1 phase).
22 */
23 
24 #include "gbldefs.h"
25 #include "gramsm.h"
26 #include "gramtk.h"
27 #include "error.h"
28 #include "global.h"
29 #include "symtab.h"
30 #include "symutl.h"
31 #include "dtypeutl.h"
32 #include "semant.h"
33 #include "scan.h"
34 #include "dinit.h"
35 #include "semstk.h"
36 #include "ast.h"
37 #include "pragma.h"
38 #include "rte.h"
39 #include "pd.h"
40 #include "interf.h"
41 #include "direct.h"
42 #include "fih.h"
43 
44 #include "atomic_common.h"
45 
46 
47 static void gen_dinit(int, SST *);
48 static void pop_subprogram(void);
49 
50 static void fix_proc_ptr_dummy_args();
51 static void set_len_attributes(SST *, int);
52 static void set_char_attributes(int, int *);
53 static void set_aclen(SST *, int, int);
54 static void copy_type_to_entry(int);
55 static void save_host(INTERF *);
56 static void restore_host(INTERF *, LOGICAL);
57 static void do_end_subprogram(SST *, RU_TYPE);
58 static void check_end_subprogram(RU_TYPE, int);
59 static const char *name_of_rutype(RU_TYPE);
60 static void convert_intrinsics_to_idents(void);
61 static int chk_intrinsic(int, LOGICAL, LOGICAL);
62 static int create_func_entry(int);
63 static int create_func_entry_result(int);
64 static int create_var(int);
65 static int chk_func_entry_result(int);
66 static void get_param_alias_const(SST *, int, int);
67 static void set_string_type_from_init(int, ACL *);
68 static void fixup_param_vars(SST *, SST *);
69 static void save_typedef_init(int, int);
70 static void symatterr(int, int, char *);
71 static void fixup_function_return_type(int, int);
72 static void get_retval_KIND_value();
73 static void get_retval_LEN_value();
74 static void get_retval_derived_type();
75 static void init_allocatable_typedef_components(int);
76 static int mystrcasecmp(char *, char *);
77 
78 static int chk_kind_parm(SST *);
79 static int get_kind_parm(int, int);
80 static int get_kind_parm_strict(int, int);
81 static int get_len_parm(int, int);
82 static int has_kind_parm_expr(int, int, int);
83 static void chk_initialization_with_kind_parm(int);
84 static void check_kind_type_param(int dtype);
85 static void defer_put_kind_type_param(int, int, char *, int, int, int);
86 static void replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i);
87 static int replace_sdsc_in_ast(int sdsc, int ast);
88 static void chk_new_param_dt(int, int);
89 static int get_vtoff(int, DTYPE);
90 static int has_length_type_parameter(int);
91 static int get_highest_param_offset(int);
92 static ACL *dup_acl(ACL *src, int sptr);
93 static int match_memname(int sptr, int list);
94 static LOGICAL is_pdt_dtype(DTYPE dtype);
95 static int chk_asz_deferlen(int, int);
96 
97 static int ident_host_sub = 0;
98 static void defer_ident_list(int ident, int proc);
99 static void clear_ident_list();
100 static void decr_ident_use(int ident, int proc);
101 static void check_duplicate(bool checker, const char * op);
102 #ifdef GSCOPEP
103 static void fixup_ident_bounds(int);
104 #endif
105 
106 static int decl_procedure_sym(int sptr, int proc_interf_sptr, int attr);
107 static int setup_procedure_sym(int sptr, int proc_interf_sptr, int attr,
108                                char access);
109 static LOGICAL ignore_common_decl(void);
110 static void record_func_result(int func_sptr, int func_result_sptr,
111                                LOGICAL in_ENTRY);
112 static bool bindingNameRequiresOverloading(SPTR sptr);
113 static void clear_iface(int i, SPTR iface);
114 static bool do_fixup_param_vars_for_derived_arrays(bool, SPTR, int);
115 
116 static IFACE *iface_base;
117 static int iface_avail;
118 static int iface_size;
119 
120 static IDENT_LIST *ident_base[HASHSIZE];
121 static LOGICAL dirty_ident_base = FALSE;
122 
123 static STSK *stsk; /* gen_dinit() defines, semant1() uses */
124 static LOGICAL seen_implicit;
125 static LOGICAL seen_parameter;
126 static LOGICAL craft_intrinsics;
127 static LOGICAL is_entry;
128 static LOGICAL is_exe_stmt;
129 static LOGICAL entry_seen;
130 static LOGICAL seen_options;
131 static int adjlen;   /* ast of adjustable length specifier */
132 static int assumlen; /* non-zero if '*' present */
133 static struct {
134   int kind;
135   INT len;
136   int propagated;
137 } lenspec[2];
138 
139 #define _LEN_CONST 1
140 #define _LEN_ASSUM 2
141 #define _LEN_ZERO 3
142 #define _LEN_ADJ 4
143 #define _LEN_DEFER 5
144 
145 /** \brief Subprogram prefix struct defintions for RECURESIVE, PURE,
146            IMPURE, ELEMENTAL, and MODULE.
147  */
148 static struct subp_prefix_t {
149   bool recursive;  /** processing RECURSIVE attribute */
150   bool pure;       /** processing PURE attribute */
151   bool impure;     /** processing IMPURE attribute */
152   bool elemental;  /** processing ELEMENTAL attribute */
153   bool module;     /** processing MODULE attribute */
154 } subp_prefix;
155 
156 static void clear_subp_prefix_settings(struct subp_prefix_t *);
157 static void check_module_prefix();
158 
159 static int generic_rutype;
160 static int mscall;
161 static int cref;
162 static int nomixedstrlen;
163 static int next_enum;
164 
165 /* for non array parameters, default set by attributes of the function
166  */
167 #define BYVALDEFAULT(ffunc) \
168   (!(PASSBYREFG(ffunc)) &&  \
169    (PASSBYVALG(ffunc) | STDCALLG(ffunc) | CFUNCG(ffunc)))
170 
171 /* flag indicating the presence of a 'host' for contained subprograms. Values
172  * are selected so that they can be used as a mask to determine when an
173  * IMPLICIT NONE statement has already been specified:
174  *
175  * 0x02 - no host present (module or top level subprogram)
176  * 0x04 - host present (within a module CONTAINed subprogram)
177  * 0x08 - host present (within a CONTAINed subprogram in another subprogram)
178  */
179 static int host_present;
180 static INTERF host_state;
181 static int end_of_host;
182 
183 #define ERR310(s1, s2) error(310, 3, gbl.lineno, s1, s2)
184 /*
185  * Declarations for processing the attributes specified in an entity type
186  * declaration.  Note that some of the ET_ manifest constants, as well as
187  * the entity_attr struct, are used in other processing, such as for PROCEDURE
188  * attributes;  likewise, there are a few ET_ entries that aren't used
189  * for declarations, but are for PROCEDURE attributes such as PASS/NOPASS.
190  */
191 #define ET_ACCESS 0
192 #define ET_ALLOCATABLE 1
193 #define ET_DIMENSION 2
194 #define ET_EXTERNAL 3
195 #define ET_INTENT 4
196 #define ET_INTRINSIC 5
197 #define ET_OPTIONAL 6
198 #define ET_PARAMETER 7
199 #define ET_POINTER 8
200 #define ET_SAVE 9
201 #define ET_TARGET 10
202 #define ET_AUTOMATIC 11
203 #define ET_STATIC 12
204 #define ET_BIND 13
205 #define ET_VALUE 14
206 #define ET_VOLATILE 15
207 #define ET_PASS 16
208 #define ET_NOPASS 17
209 #define ET_DEVICE 18
210 #define ET_PINNED 19
211 #define ET_SHARED 20
212 #define ET_CONSTANT 21
213 #define ET_PROTECTED 22
214 #define ET_ASYNCHRONOUS 23
215 #define ET_TEXTURE 24
216 #define ET_KIND 25
217 #define ET_LEN 26
218 #define ET_CONTIGUOUS 27
219 #define ET_MANAGED 28
220 #define ET_IMPL_MANAGED 29
221 #define ET_MAX 30
222 
223 /* derive bit mask for each entity type */
224 
225 #define ET_B(e) (1 << e)
226 
227 #define SYMI_SPTR(i) aux.symi_base[i].sptr
228 #define SYMI_NEXT(i) aux.symi_base[i].next
229 
230 /*
231  * structure to record which attributes occurred for an entity type
232  * declaration.
233  */
234 static LOGICAL in_entity_typdcl; /* TRUE if processing an entity type decl */
235 static struct {
236   int exist;     /* bit vector indicating which attributes exist */
237   int dimension; /* TY_ARRAY DT record */
238   char access;   /* 'u' => access public ; 'v' => access private */
239   char intent;   /* bit vector formed from INTENT_... */
240   char bounds[sizeof(sem.bounds)]; /* copy of sem.bounds[...] */
241   char arrdim[sizeof(sem.arrdim)]; /* copy of sem.arrdim */
242   int pass_arg;                    /* sptr of the ident in PASS ( <ident> ) */
243 } entity_attr;
244 
245 static struct {
246   char *name;
247   int no; /* bit vector of attributes which do not coexist */
248 } et[ET_MAX] = {
249     {"access",
250      ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) |
251        ET_B(ET_INTRINSIC) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) |
252        ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_BIND) | ET_B(ET_VALUE) |
253        ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) |
254        ET_B(ET_DEVICE) | ET_B(ET_CONSTANT) | ET_B(ET_PINNED) |
255        ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED) | ET_B(ET_CONTIGUOUS))},
256     {"allocatable",
257      ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_SAVE) | ET_B(ET_TARGET) |
258        ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_VOLATILE) |
259        ET_B(ET_DEVICE) | ET_B(ET_PINNED) | ET_B(ET_ASYNCHRONOUS) |
260        ET_B(ET_PROTECTED) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED) |
261        ET_B(ET_CONTIGUOUS))},
262     {"dimension",
263      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_INTENT) |
264        ET_B(ET_OPTIONAL) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) |
265        ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_BIND) | ET_B(ET_VALUE) |
266        ET_B(ET_VOLATILE) | ET_B(ET_DEVICE) | ET_B(ET_SHARED) | ET_B(ET_PINNED) |
267        ET_B(ET_CONSTANT) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) |
268        ET_B(ET_TEXTURE) | ET_B(ET_CONTIGUOUS) | ET_B(ET_MANAGED) |
269        ET_B(ET_IMPL_MANAGED))},
270     {"external",
271      ~(ET_B(ET_ACCESS) | ET_B(ET_OPTIONAL) | ET_B(ET_BIND) | ET_B(ET_VALUE) |
272        ET_B(ET_POINTER))},
273     {"intent",
274      ~(ET_B(ET_DIMENSION) | ET_B(ET_OPTIONAL) | ET_B(ET_TARGET) |
275        ET_B(ET_ALLOCATABLE) | ET_B(ET_BIND) | ET_B(ET_VALUE) |
276        ET_B(ET_POINTER) | ET_B(ET_VOLATILE) | ET_B(ET_DEVICE) |
277        ET_B(ET_CONSTANT) | ET_B(ET_PINNED) |
278        ET_B(ET_SHARED | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED)) |
279        ET_B(ET_CONTIGUOUS) | ET_B(ET_TEXTURE) | ET_B(ET_MANAGED) |
280        ET_B(ET_IMPL_MANAGED))},
281     {"intrinsic", ~(ET_B(ET_ACCESS))},
282     {"optional",
283      ~(ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTENT) |
284        ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) |
285        ET_B(ET_ALLOCATABLE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) |
286        ET_B(ET_PROTECTED) | ET_B(ET_CONTIGUOUS) | ET_B(ET_MANAGED) |
287        ET_B(ET_VALUE) | ET_B(ET_IMPL_MANAGED) | ET_B(ET_DEVICE))},
288     {"parameter",
289      ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_SAVE) | ET_B(ET_VALUE) |
290        ET_B(ET_ASYNCHRONOUS) | ET_B(ET_CONSTANT))},
291     {"pointer",
292      ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_OPTIONAL) |
293        ET_B(ET_SAVE) | ET_B(ET_VALUE) | ET_B(ET_BIND) | ET_B(ET_INTENT) |
294        ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) |
295        ET_B(ET_TEXTURE) | ET_B(ET_DEVICE) | ET_B(ET_CONTIGUOUS) |
296        ET_B(ET_MANAGED) | ET_B(ET_EXTERNAL))},
297     {"save",
298      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) |
299        ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_TARGET) |
300        ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_SHARED) |
301        ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_PINNED) |
302        ET_B(ET_TEXTURE) | ET_B(ET_DEVICE) | ET_B(ET_MANAGED) |
303        ET_B(ET_IMPL_MANAGED))},
304     {"target",
305      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) |
306        ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_SAVE) | ET_B(ET_VALUE) |
307        ET_B(ET_BIND) | ET_B(ET_PINNED) | ET_B(ET_VOLATILE) |
308        ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_CONTIGUOUS) |
309        ET_B(ET_DEVICE) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED))},
310     {"automatic",
311      ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_POINTER) |
312        ET_B(ET_TARGET) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) |
313        ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED))},
314     {"static",
315      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) |
316        ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_BIND) |
317        ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) |
318        ET_B(ET_PROTECTED))},
319     {"bind",
320      ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) |
321        ET_B(ET_INTENT) | ET_B(ET_POINTER) | ET_B(ET_TARGET) | ET_B(ET_STATIC) |
322        ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) |
323        ET_B(ET_CONTIGUOUS))},
324     {"value",
325      ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) |
326        ET_B(ET_INTENT) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_SAVE) |
327        ET_B(ET_TARGET) | ET_B(ET_STATIC) | ET_B(ET_ASYNCHRONOUS) |
328        ET_B(ET_OPTIONAL) | ET_B(ET_PROTECTED) | ET_B(ET_CONTIGUOUS))},
329     {"volatile",
330      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) |
331        ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_SAVE) |
332        ET_B(ET_TARGET) | ET_B(ET_AUTOMATIC) | ET_B(ET_STATIC) | ET_B(ET_BIND) |
333        ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_DEVICE) |
334        ET_B(ET_SHARED) | ET_B(ET_CONTIGUOUS))},
335     {"pass", ~(0)},
336     {"nopass", ~(0)},
337     {"device",
338      ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) |
339        ET_B(ET_VOLATILE) | ET_B(ET_ACCESS) | ET_B(ET_TARGET) |
340        ET_B(ET_POINTER) | ET_B(ET_TEXTURE) | ET_B(ET_CONTIGUOUS) |
341        ET_B(ET_OPTIONAL) | ET_B(ET_SAVE) | ET_B(ET_IMPL_MANAGED))},
342     {"pinned",
343      ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) |
344        ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_ACCESS) | ET_B(ET_CONTIGUOUS) |
345        ET_B(ET_IMPL_MANAGED))},
346     {"shared",
347      ~(ET_B(ET_DIMENSION) | ET_B(ET_SAVE) | ET_B(ET_INTENT) |
348        ET_B(ET_VOLATILE))},
349     {"constant", ~(ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_ACCESS) |
350        ET_B(ET_PARAMETER))},
351     {"protected",
352      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) |
353        ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_SAVE) |
354        ET_B(ET_TARGET) | ET_B(ET_AUTOMATIC) | ET_B(ET_STATIC) | ET_B(ET_BIND) |
355        ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) |
356        ET_B(ET_CONTIGUOUS) | ET_B(ET_IMPL_MANAGED))},
357     {"asynchronous",
358      ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) |
359        ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_PARAMETER) |
360        ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_AUTOMATIC) |
361        ET_B(ET_STATIC) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) |
362        ET_B(ET_PROTECTED) | ET_B(ET_IMPL_MANAGED))},
363     {"texture",
364      ~(ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_POINTER) |
365        ET_B(ET_DEVICE) | ET_B(ET_SAVE))},
366     {"kind", 0},       /* 'no' field not used, so make it 0 */
367     {"len", 0},        /* 'no' field not used, so make it 0 */
368     {"contiguous", 0}, /* 'no' field not used, so make it 0 */
369     {"managed",
370      ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) |
371        ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_ACCESS) | ET_B(ET_CONTIGUOUS) |
372        ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_IMPL_MANAGED))},
373     {"implicit-managed", 0}, /* 'no' field not used */
374 };
375 /*
376  * Declarations for processing the attributes specified in a DEC ATTRIBUTES
377  * declaration.
378  */
379 #define DA_ALIAS 0
380 #define DA_C 1
381 #define DA_STDCALL 2
382 #define DA_DLLEXPORT 3
383 #define DA_DLLIMPORT 4
384 #define DA_VALUE 5
385 #define DA_REFERENCE 6
386 #define DA_DECORATE 7
387 #define DA_NOMIXEDSLA 8
388 #define DA_MAX 9
389 
390 /* derive bit mask for each attribute type */
391 
392 #define DA_B(e) (1 << e)
393 
394 /*
395  * structure to record which attributes occurred for a DEC ATTRIBUTES
396  * and BIND declaration.
397  */
398 struct dec_attr_t {
399   int exist;   /* bit vector indicating which attributes exist */
400   int altname; /* sptr to a character constant representing alias */
401 };
402 
403 static struct dec_attr_t dec_attr;
404 static struct dec_attr_t bind_attr;
405 
406 static struct {
407   char *name;
408   int no; /* bit vector of attributes which do not coexist */
409           /* unlike the et[...].no values, it's easier to explicitly
410            * specify those which do not coexist as opposed to the
411            * negation of those which can coexist.
412            */
413 } da[DA_MAX] = {
414     {"alias", 0},
415     {"c", (DA_B(DA_STDCALL))},
416     {"stdcall", (DA_B(DA_C))},
417     {"dllexport", (0)},
418     {"dllimport", (0)},
419     {"value", (DA_B(DA_REFERENCE))},
420     {"reference", (DA_B(DA_VALUE))},
421     {"decorate", 0},
422     {"nomixed_str_len_arg", 0},
423 };
424 
425 static void process_bind(int);
426 
427 static void defer_iface(int, int, int, int);
428 static void do_iface(int);
429 static void do_iface_module(void);
430 static void _do_iface(int, int);
431 static void fix_iface(int);
432 static void fix_iface0();
433 
434 /** \brief Initialize semantic analyzer for new user subprogram unit.
435  */
436 void
semant_init(int noparse)437 semant_init(int noparse)
438 {
439   if (!noparse) {
440     if (sem.doif_base == NULL) {
441       sem.doif_size = 12;
442       NEW(sem.doif_base, DOIF, sem.doif_size);
443     }
444     sem.doif_depth = 0;
445     DI_ID(0) = -1;
446     DI_NEST(0) = 0;
447     DI_LINENO(0) = 0;
448     if (sem.stsk_base == NULL) {
449       sem.stsk_size = 12;
450       NEW(sem.stsk_base, STSK, sem.stsk_size);
451     }
452     sem.doconcurrent_symavl = SPTR_NULL;
453     sem.doconcurrent_dtype = DT_NONE;
454     sem.stsk_depth = 0;
455     scopestack_init();
456     sem.eqvlist = 0;
457     sem.eqv_avail = 1;
458     if (sem.eqv_size == 0) {
459       sem.eqv_size = 20;
460       NEW(sem.eqv_base, EQVV, sem.eqv_size);
461     }
462     sem.eqv_ss_avail = 1;
463     if (sem.eqv_ss_size == 0) {
464       sem.eqv_ss_size = 50;
465       NEW(sem.eqv_ss_base, int, sem.eqv_ss_size);
466     }
467     EQV_NUMSS(0) = 0;
468     sem.non_private_avail = 0;
469     if (sem.non_private_size == 0) {
470       sem.non_private_size = 50;
471       NEW(sem.non_private_base, int, sem.non_private_size);
472     }
473     if (sem.typroc_base == NULL) {
474       sem.typroc_size = 50;
475       NEW(sem.typroc_base, int, sem.typroc_size);
476     }
477     sem.typroc_avail = 0;
478     if (sem.iface_base == NULL) {
479       sem.iface_size = 50;
480       NEW(sem.iface_base, IFACE, sem.iface_size);
481     }
482     sem.iface_avail = 0;
483     sem.pgphase = PHASE_INIT;
484     sem.flabels = 0; /* not NOSYM - a sym's SYMLK is init'd to NOSYM. if
485                       * its SYMLK is NOSYM, then it hasn't been added */
486     sem.nml = NOSYM;
487     sem.atemps = 0;
488     sem.itemps = 0;
489     sem.ptemps = 0;
490     sem.savall = flg.save;
491     sem.savloc = FALSE;
492     sem.autoloc = FALSE;
493     sem.psfunc = FALSE;
494     sem.in_stfunc = FALSE;
495     sem.dinit_error = FALSE;
496     sem.dinit_data = FALSE;
497     sem.dinit_nbr_inits = 0;
498     sem.contiguous = XBIT(125, 0x80000); /* xbit is set for -Mcontiguous */
499     seen_implicit = FALSE;
500     symutl.none_implicit = sem.none_implicit = flg.dclchk;
501     seen_parameter = FALSE;
502   }
503 
504   flg.sequence = TRUE;
505   flg.hpf = FALSE;
506 
507   if (!noparse) {
508     sem.ignore_stmt = FALSE;
509     sem.switch_avl = 0;
510     if (switch_base == NULL) {
511       sem.switch_size = 400;
512       NEW(switch_base, SWEL, sem.switch_size);
513     }
514     sem.temps_reset = FALSE;
515     seen_options = FALSE;
516     sem.gdtype = -1;
517     lenspec[0].kind = 0;
518     sem.seql.type = 0;    /* [NO]SEQUENCE not yet seen */
519     sem.seql.next = NULL; /* sequence list is empty */
520     sem.dtemps = 0;
521     sem.interface = 0;
522     if (sem.interf_base == NULL) {
523       sem.interf_size = 2;
524       NEW(sem.interf_base, INTERF, sem.interf_size);
525     }
526     sem.p_dealloc = NULL;
527     sem.p_dealloc_delete = NULL;
528     sem.alloc_std = 0;
529     clear_subp_prefix_settings(&subp_prefix);
530     sem.accl.type = 0;    /* PUBLIC/PRIVATE statement not yet seen */
531     sem.accl.next = NULL; /* access list is empty */
532     sem.in_struct_constr = 0;
533     sem.atomic[0] = sem.atomic[1] = sem.atomic[2] = FALSE;
534     sem.master.cnt = 0;
535     sem.critical.cnt = 0;
536     sem.intent_list = NULL;
537     sem.symmetric = FALSE;
538     sem.mpaccatomic.seen = sem.mpaccatomic.pending = sem.mpaccatomic.apply =
539         sem.mpaccatomic.is_acc = FALSE;
540     sem.mpaccatomic.ast = 0;
541     sem.mpaccatomic.action_type = ATOMIC_UNDEF;
542     sem.mpaccatomic.mem_order = MO_UNDEF;
543     sem.mpaccatomic.rmw_op = AOP_UNDEF;
544     sem.mpaccatomic.accassignc = 0;
545     sem.parallel = 0;
546     sem.task = 0;
547     sem.orph = 0;
548     sem.target = 0;
549     sem.teams = 0;
550     sem.expect_do = FALSE;
551     sem.expect_simd_do = FALSE;
552     sem.expect_dist_do = FALSE;
553     sem.expect_acc_do = 0;
554     sem.collapsed_acc_do = 0;
555     sem.seq_acc_do = 0;
556     sem.expect_cuf_do = 0;
557     sem.close_pdo = FALSE;
558     sem.is_hpf = FALSE;
559     sem.hpfdcl = 0;
560     sem.ssa_area = 0;
561     sem.use_etmps = FALSE;
562     sem.etmp_list = NULL;
563     sem.auto_dealloc = NULL;
564     sem.blksymnum = 0;
565     sem.ignore_default_none = FALSE;
566     sem.in_enum = FALSE;
567     sem.type_mode = 0;
568     sem.seen_import = FALSE;
569     sem.seen_end_module = FALSE;
570     sem.tbp_arg = 0;
571     sem.tbp_arg_cnt = 0;
572     sem.tbp_access_stmt = 0;
573     sem.generic_tbp = 0;
574     sem.auto_finalize = NULL;
575     sem.type_initialize = NULL;
576     sem.alloc_mem_initialize = NULL;
577     sem.select_type_seen = 0;
578     sem.param_offset = 0;
579     sem.kind_type_param = 0;
580     sem.len_type_param = 0;
581     sem.type_param_candidate = 0;
582     sem.len_candidate = 0;
583     sem.kind_candidate = 0;
584     sem.type_param_sptr = 0;
585     sem.param_struct_constr = 0;
586     sem.new_param_dt = 0;
587     sem.extends = 0;
588     sem.param_assume_sz = 0;
589     sem.param_defer_len = 0;
590     sem.save_aconst = 0;
591     sem.defined_io_type = 0;
592     sem.defined_io_seen = 0;
593     sem.use_seen = 0;
594     sem.ieee_features = FALSE;
595     sem.collapse = sem.collapse_depth = 0;
596     sem.stats.allocs = 0;
597     sem.stats.nodes = 0;
598     sem.modhost_proc = 0;
599     sem.modhost_entry = 0;
600     sem.in_array_const = false;
601     sem.parsing_operator = false;
602 
603     mscall = 0;
604     cref = 0;
605     nomixedstrlen = 0;
606 #if defined(TARGET_WIN)
607     if (WINNT_CALL)
608       mscall = 1;
609     if (WINNT_CREF)
610       cref = 1;
611     if (WINNT_NOMIXEDSTRLEN)
612       nomixedstrlen = 1;
613 #endif
614   } else {
615     /*
616      * Needed for handling the 03 allocatable semantics in semutil2.c via
617      * transform which might occur during the IPA recompile.
618      */
619     sem.p_dealloc = NULL;
620     sem.p_dealloc_delete = NULL;
621   }
622 
623   sem.sc = SC_LOCAL;
624   stb.curr_scope = 0;
625   ast_init();           /* ast.c */
626   init_intrinsic_opr(); /* semgnr.c */
627   import_init();        /* interf.c */
628   if (!noparse) {
629     if (IN_MODULE) {
630       mod_init();
631       host_present = 0x04;
632       restore_implicit();
633       save_implicit(TRUE);
634     } else if (gbl.internal) { /* hasn't been incremented yet */
635       host_present = 0x08;
636       restore_implicit();
637       save_implicit(TRUE);
638     } else {
639       host_present = 0x02;
640     }
641   }
642   clean_struct_default_init(stb.stg_avail);
643   use_init();    /* module.c */
644   bblock_init(); /* bblock.c */
645 
646   if (!noparse) {
647     craft_intrinsics = FALSE;
648 
649     if (XBIT(49, 0x1040000))
650       /* T3D/T3E or C90 Cray targets */
651       change_predefineds(ST_CRAY, FALSE);
652 
653     end_of_host = 0;
654     if (gbl.internal && sem.which_pass)
655       restore_host_state(2);
656   } else {
657     if (gbl.internal)
658       restore_host_state(4);
659   }
660 }
661 
662 /* for each SC_DUMMY parameter that is passed by value,
663    copy it to a local (reference ) of the same name.
664    all lookups will subsequently find this local
665  */
666 static void
reloc_byvalue_parameters()667 reloc_byvalue_parameters()
668 {
669   INT dpdsc;
670   INT psptr, sptr1;
671   INT iarg;
672   INT newsptr;
673   INT vv;
674   ITEM *itemp; /* Pointers to items */
675   char *name;
676   int name_len;
677   int byval_default = 0;
678   int tmp_nmptr;
679   int thesub;
680 
681   if (STYPEG(gbl.currsub) == ST_MODULE)
682     return;
683 
684   for (thesub = gbl.currsub; thesub > NOSYM; thesub = SYMLKG(thesub)) {
685     dpdsc = DPDSCG(thesub);
686     for (iarg = PARAMCTG(thesub); iarg > 0; dpdsc++, iarg--) {
687       psptr = *(aux.dpdsc_base + dpdsc);
688 
689       /* copy all parameters passed by value to local stack.
690          arrays are always passed by reference  unless specifically
691          marked by value
692        */
693       /* disable array and struct parameters passed by value */
694       if (((DTY(DTYPEG(psptr))) == TY_ARRAY) ||
695           ((DTY(DTYPEG(psptr))) == TY_STRUCT)) {
696         if (PASSBYVALG(thesub) || PASSBYVALG(psptr))
697           error(84, 3, gbl.lineno, SYMNAME(psptr),
698                 "- VALUE derived types and arrays not yet supported");
699       } else
700         byval_default = BYVALDEFAULT(thesub);
701       if (PASSBYVALG(psptr) && OPTARGG(psptr)) {
702         /* an address is passed for optional value arguments as if call by
703          * reference, but the address is of a temp
704          */
705         continue;
706       }
707       if ((byval_default || PASSBYVALG(psptr)) && (!PASSBYREFG(psptr)) &&
708           (DTY(DTYPEG(psptr)) != TY_ARRAY) &&
709           /* don't redo what we've already done */
710           (strncmp(SYMNAME(psptr), "_V_", 3) != 0)) {
711 
712         /* declare a new variable _V_<orig_name> which subsumes the
713          * original by value parameter.  The original variable becomes
714          * SC_LOCAL and all further user code references will be to this
715          * SC_LOCAL var.
716          * The copy of the by-value _V_<name> parameter to this local
717          * is done at expand time.
718          */
719         newsptr = lookupsymf("_V_%s", SYMNAME(psptr));
720         if (newsptr > NOSYM) {
721           /* already exists */
722           *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */
723           return;
724         }
725         newsptr = getsymf("_V_%s", SYMNAME(psptr));
726         dup_sym(newsptr, stb.stg_base + psptr); /* also _V_... is the dummy*/
727         DCLDP(newsptr, TRUE);                 /* so DCLCHK is quiet */
728         REFP(newsptr, TRUE);
729         SCP(psptr, SC_LOCAL); /* make the original a local*/
730         /* the byval flag on the original arg (psptr) is cleared in semfin */
731         MIDNUMP(newsptr, psptr); /* link from new symbol to original symbol */
732         *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */
733         for (itemp = sem.intent_list; itemp != NULL; itemp = itemp->next) {
734           if (psptr == itemp->t.sptr) {
735             itemp->t.sptr = newsptr;
736             break;
737           }
738         }
739         /*
740          * The original symbol may not yet be classified as an object.
741          * Take care of that here for the original symbol; semfin will
742          * take of new symbol.
743          */
744         switch (STYPEG(psptr)) {
745         case ST_UNKNOWN:
746         case ST_IDENT:
747           STYPEP(psptr, ST_VAR);
748           break;
749         default:;
750         }
751         if (sem.which_pass) {
752           /* the back-end will always copy _V_<orig_name> to
753            * <orig_name>; make sure that <orig_name> is referenced.
754            */
755           sym_is_refd(psptr);
756         }
757 
758       } /* if pass by val */
759 
760       else if (thesub != gbl.currsub && SCG(psptr) == SC_LOCAL) {
761         /* presumably, thesub is an ST_ENTRY and the parameter has
762          * already been processed; make sure to fix the DPDSC entry.
763          */
764         newsptr = lookupsymf("_V_%s", SYMNAME(psptr));
765         if (newsptr) {
766           *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */
767         }
768       }
769 
770     } /* for  all parameters */
771   }
772 }
773 
774 static void
end_subprogram_checks()775 end_subprogram_checks()
776 {
777   if (sem.master.cnt)
778     error(155, 3, sem.master.lineno, "Unterminated MASTER", CNULL);
779   if (sem.critical.cnt)
780     error(155, 3, sem.critical.lineno, "Unterminated CRITICAL", CNULL);
781   sem_err104(sem.doif_depth, DI_LINENO(sem.doif_depth), "unterminated");
782 } /* end_subprogram_checks */
783 
784 static int restored = 0;
785 
786 /** \brief Semantic actions - part 1.
787     \param rednum reduction number
788     \param top    top of stack after reduction
789  */
790 void
semant1(int rednum,SST * top)791 semant1(int rednum, SST *top)
792 {
793   int sptr, sptr1, sptr2, dtype, dtypeset, ss, numss, sptr_temp;
794   int stype, stype1, i;
795   int begin, end, count;
796   int opc;
797   INT rhstop, rhsptr;
798   LOGICAL inited;
799   ITEM *itemp, /* Pointers to items */
800       *itemp1;
801   INT conval;
802   int doif;
803   int evp;
804   ADSC *ad;
805   char *np, *np2; /* char ptrs to symbol names area */
806   int name_prefix_char;
807   char *nmptr;
808   VAR *ivl;        /* Initializer Variable List */
809   ACL *ict, *ict1; /* Initializer Constant Tree */
810   int ast, alias;
811   static int et_type; /* one of ET_...; '<attr>::=' passes up */
812   int et_bitv;
813   LOGICAL no_init; /* init not allowed for entity decl */
814   int func_result; /* sptr of ident in result ( ident ) */
815   ACL *aclp;
816   ACL *tmpaclp;
817   ACCL *accessp;
818   int gnr;
819   LOGICAL is_array;
820   LOGICAL is_member;
821   INT val[2];
822   int mndsc;
823   LOGICAL is_first;
824   int constarraysize; /* set to 1 if array bounds are constant */
825   ISZ_T arraysize;    /* the actual array size; check for < 0 */
826   static int da_type; /* one of DA_...; '<msattr>::=' passes up */
827   PHASE_TYPE prevphase;
828   INT id_name;
829   INT result_name;
830   int dpdsc;
831   SST *e1;
832   static int proc_interf_sptr; /* <proc interf ::= <id> passed up */
833   /* for deepcopy */
834   bool is_duplicate_decl;
835   int bfind;
836   int newpolicymemid;
837   int newpolicyidx;
838   int newshapeid;
839   int idptemp, newsubidx;
840   int symi;
841 
842   switch (rednum) {
843 
844   /* ------------------------------------------------------------------ */
845   /*
846    *      <SYSTEM GOAL SYMBOL> ::=
847    */
848   case SYSTEM_GOAL_SYMBOL1:
849     break;
850 
851   /* ------------------------------------------------------------------ */
852   /*
853    *	<stmt> ::= <stbeg> <statement> <stend>
854    */
855   case STMT1:
856     break;
857 
858   /* ------------------------------------------------------------------ */
859   /*
860    *	<stbeg> ::=
861    */
862   case STBEG1:
863     if (sem.in_enum) {
864       switch (scn.stmtyp) {
865       case TK_ENUMERATOR:
866       case TK_ENDENUM:
867         break;
868       default:
869         error(155, 3, gbl.lineno, "ENUMERATOR statement expected", CNULL);
870         sem.ignore_stmt = TRUE;
871         break;
872       }
873     }
874     sem.is_hpf = scn.is_hpf;
875     sem.alloc_std = 0;
876     sem.p_dealloc_delete = NULL;
877     if (sem.pgphase == PHASE_USE) {
878       switch (scn.stmtyp) {
879       case TK_USE:
880       case TK_INCLUDE:
881         break;
882       default:
883         apply_use_stmts();
884         if (sem.deferred_func_kind) {
885           get_retval_KIND_value();
886         }
887         if (sem.deferred_func_len) {
888           get_retval_LEN_value();
889         }
890         if (sem.deferred_dertype) {
891           get_retval_derived_type();
892         }
893         break;
894       }
895     }
896     if (sem.pgphase == 0 && sem.interface && gbl.currsub == 0) {
897       if (scn.stmtyp == TK_USE) {
898         error(155, 3, gbl.lineno, "USE", "is not in a correct position.");
899         sem.ignore_stmt = TRUE;
900       }
901     }
902     if (sem.deferred_func_kind && (sem.pgphase > PHASE_USE || is_exe_stmt)) {
903       get_retval_KIND_value();
904     }
905     if (sem.deferred_func_len && (sem.pgphase > PHASE_USE || is_exe_stmt)) {
906       get_retval_LEN_value();
907     }
908     if (sem.deferred_dertype && (sem.pgphase > PHASE_USE || is_exe_stmt)) {
909       get_retval_derived_type();
910     }
911 
912     if (!sem.interface && sem.pgphase < PHASE_EXEC &&
913         (is_exe_stmt = is_executable(sem.tkntyp))) {
914 
915       if (!IN_MODULE)
916         do_iface(0);
917       else
918         do_iface_module();
919 
920       reloc_byvalue_parameters();
921       if (sem.which_pass == 1 && restored == 0) {
922         restore_internal_subprograms();
923         restored = 1;
924       }
925     }
926     if (sem.expect_do || sem.expect_acc_do || sem.expect_simd_do ||
927         sem.expect_dist_do || (sem.expect_cuf_do && XBIT(137, 0x20000))) {
928       int stt;
929       stt = sem.tkntyp;
930       if (stt == TK_NAMED_CONSTRUCT)
931         stt = get_named_stmtyp();
932       if (stt != TK_DO) {
933         char *p;
934         switch (DI_ID(sem.doif_depth)) {
935         case DI_ACCDO:
936           sem.doif_depth--; /* remove from stack */
937           p = "ACC DO";
938           break;
939         case DI_ACCLOOP:
940           sem.doif_depth--; /* remove from stack */
941           p = "ACC LOOP";
942           break;
943         case DI_ACCREGDO:
944           sem.doif_depth--; /* remove from stack */
945           p = "ACC REGION DO";
946           break;
947         case DI_ACCREGLOOP:
948           sem.doif_depth--; /* remove from stack */
949           p = "ACC REGION LOOP";
950           break;
951         case DI_ACCKERNELSDO:
952           sem.doif_depth--; /* remove from stack */
953           p = "ACC KERNELS DO";
954           break;
955         case DI_ACCKERNELSLOOP:
956           sem.doif_depth--; /* remove from stack */
957           p = "ACC KERNELS LOOP";
958           break;
959         case DI_ACCPARALLELDO:
960           sem.doif_depth--; /* remove from stack */
961           p = "ACC PARALLEL DO";
962           break;
963         case DI_ACCPARALLELLOOP:
964           sem.doif_depth--; /* remove from stack */
965           p = "ACC PARALLEL LOOP";
966           break;
967         case DI_ACCSERIALLOOP:
968           sem.doif_depth--; /* remove from stack */
969           p = "ACC SERIAL LOOP";
970           break;
971         case DI_CUFKERNEL:
972           sem.doif_depth--; /* remove from stack */
973           p = "CUDA KERNEL DO";
974           break;
975         case DI_PDO:
976           if (DI_ISSIMD(sem.doif_depth))
977             p = "OMP DO SIMD";
978           else
979             p = "OMP DO";
980           sem.doif_depth--; /* remove PDO from stack */
981           par_pop_scope();
982           break;
983         case DI_TARGETSIMD:
984           sem.doif_depth--; /* remove from TARGET SIMD stack */
985           p = "OMP TARGET SIMD";
986           par_pop_scope();
987           break;
988         case DI_SIMD:
989           sem.doif_depth--; /* remove from SIMD stack */
990           p = "OMP SIMD";
991           par_pop_scope();
992           break;
993 
994         case DI_DISTRIBUTE:
995           sem.doif_depth--; /* remove from DISTRIBUTE stack */
996           p = "OMP DISTRIBUTE";
997           par_pop_scope();
998           break;
999         case DI_TARGPARDO:
1000           sem.doif_depth--; /* remove from TARGET PARALLEL DO stack */
1001           p = "OMP TARGET PARALLEL DO";
1002           par_pop_scope();
1003           break;
1004         case DI_DISTPARDO:
1005           sem.doif_depth--; /* remove from stack */
1006           p = "OMP DISTRIBUTE PARALLEL DO";
1007           par_pop_scope();
1008 
1009           if (scn.stmtyp == TK_MP_ENDTEAMS) {
1010             /* distribute parallel do */
1011             break;
1012           } else if (scn.stmtyp == TK_MP_ENDTARGET) {
1013             /* teams distribute parallel do */
1014             par_pop_scope();
1015           } else if (DI_ID(sem.doif_depth) == DI_TEAMS) {
1016             /* if the previous stack id is DI_TEAMS
1017              * and scn.stmtyp != TK_MP_ENDTEAMS, then
1018              * this is target teams distribute parallel do
1019              * construct: pop teams and target as we manually
1020              * add stack for those.
1021              */
1022             par_pop_scope();
1023             par_pop_scope();
1024           }
1025 
1026           break;
1027         case DI_DOACROSS:
1028           p = "DOACROSS";
1029           goto reset_st;
1030         case DI_PARDO:
1031           if (DI_ISSIMD(sem.doif_depth))
1032             p = "PARALLEL DO SIMD";
1033           else
1034             p = "PARALLEL DO";
1035         reset_st:
1036           sem.doif_depth--; /* remove from stack */
1037           /* restore symbol table state */
1038           par_pop_scope();
1039           break;
1040         case DI_TASKLOOP:
1041           sem.doif_depth--; /* remove from stack */
1042           p = "OMP TASKLOOP";
1043           par_pop_scope();
1044           break;
1045         default:
1046           p = "???";
1047           break;
1048         }
1049         error(155, 3, gbl.lineno, "DO loop expected after", p);
1050         sem.expect_do = FALSE;
1051         sem.expect_simd_do = FALSE;
1052         sem.expect_dist_do = FALSE;
1053         sem.expect_acc_do = 0;
1054         sem.collapsed_acc_do = 0;
1055         sem.seq_acc_do = 0;
1056         sem.expect_cuf_do = 0;
1057         sem.collapse = sem.collapse_depth = 0;
1058       }
1059     } else if (sem.collapse_depth) {
1060       int stt;
1061       stt = sem.tkntyp;
1062       if (stt == TK_NAMED_CONSTRUCT)
1063         stt = get_named_stmtyp();
1064       if (stt != TK_DO) {
1065         /*
1066          * The collapse value is larger than the number of loops;
1067          * this needs to be a fatal error since the DOIF stack
1068          * is probably inconsistent wrt matching ENDDOs etc.
1069          */
1070         error(155, 4, gbl.lineno, "DO loop expected after", "COLLAPSE");
1071         sem.collapse = sem.collapse_depth = 0;
1072       }
1073     }
1074     if (sem.close_pdo) {
1075       sem.close_pdo = FALSE;
1076       switch (DI_ID(sem.doif_depth)) {
1077       case DI_PDO:
1078         if (scn.stmtyp != TK_MP_ENDPDO) {
1079           if (A_TYPEG(STD_AST(STD_PREV(0))) != A_MP_BARRIER)
1080             (void)add_stmt(mk_stmt(A_MP_BARRIER, 0));
1081           sem.doif_depth--; /* pop DOIF stack */
1082         }
1083         /* else ENDPDO pops the stack */
1084         break;
1085       case DI_DISTRIBUTE:
1086         if (scn.stmtyp != TK_MP_ENDDISTRIBUTE) {
1087           sem.doif_depth--; /* pop DOIF stack */
1088         }
1089         /* else ENDDISTRIBUTE pops the stack */
1090         break;
1091       case DI_TEAMSDIST:
1092         if (scn.stmtyp != TK_MP_ENDTEAMSDIST) {
1093           sem.doif_depth--; /* pop DOIF stack */
1094           end_teams();
1095         }
1096         /* else ENDTEAMSDIST pops the stack */
1097         break;
1098       case DI_TARGTEAMSDIST:
1099         if (scn.stmtyp != TK_MP_ENDTARGTEAMSDIST) {
1100           sem.doif_depth--; /* pop DOIF stack */
1101           end_teams();
1102           end_target();
1103         }
1104         /* else ENDTEAMSDIST pops the stack */
1105         break;
1106       case DI_TARGPARDO:
1107         if (scn.stmtyp != TK_MP_ENDTARGPARDO) {
1108           (void)add_stmt(mk_stmt(A_MP_BARRIER, 0));
1109           sem.doif_depth--; /* pop DOIF stack */
1110           end_target();
1111         }
1112         /* else ENDTARGPARDO[SIMD] pops the stack */
1113         break;
1114 
1115       case DI_TEAMSDISTPARDO:
1116         if (scn.stmtyp != TK_MP_ENDTEAMSDISTPARDO &&
1117             scn.stmtyp != TK_MP_ENDTEAMSDISTPARDOSIMD) {
1118           sem.doif_depth--; /* pop DOIF stack */
1119           end_teams();
1120         }
1121         /* else ENDTEAMSDISTPARDO[SIMD] pops the stack */
1122         break;
1123       case DI_TARGTEAMSDISTPARDO:
1124         if (scn.stmtyp != TK_MP_ENDTARGTEAMSDISTPARDO &&
1125             scn.stmtyp != TK_MP_ENDTARGTEAMSDISTPARDOSIMD) {
1126           sem.doif_depth--; /* pop DOIF stack */
1127           end_teams();
1128           end_target();
1129         }
1130         /* else ENDTARGTEAMSDISTPARDO[SIMD] pops the stack */
1131         break;
1132       case DI_DISTPARDO:
1133         if (scn.stmtyp != TK_MP_ENDDISTPARDO &&
1134             scn.stmtyp != TK_MP_ENDDISTPARDOSIMD) {
1135           sem.doif_depth--; /* pop DOIF stack */
1136         }
1137         break;
1138       case DI_TARGETSIMD:
1139         if (scn.stmtyp != TK_MP_ENDTARGSIMD) {
1140           sem.doif_depth--; /* pop DOIF stack */
1141           end_target();
1142         }
1143         /* else ENDTARGETSIMD pops the stack */
1144         break;
1145       case DI_SIMD:
1146         if (scn.stmtyp != TK_MP_ENDSIMD) {
1147           sem.doif_depth--; /* pop DOIF stack */
1148         }
1149         /* else ENDSIMD pops the stack */
1150         break;
1151       case DI_DOACROSS:
1152         /* the DOIF stack could have been popped when the
1153          * DO loop was closed, but it's done here with
1154          * the other DO directives.  */
1155         sem.doif_depth--; /* pop DOIF stack */
1156         break;
1157       case DI_PARDO:
1158         if (scn.stmtyp != TK_MP_ENDPARDO) {
1159           sem.doif_depth--; /* pop DOIF stack */
1160           /* else ENDPARDO pops the stack */
1161         }
1162         break;
1163       case DI_TASKLOOP:
1164         if (scn.stmtyp != TK_MP_ENDTASKLOOP) {
1165           sem.doif_depth--; /* pop DOIF stack */
1166           /* else ENDTASKLOOP pops the stack */
1167         }
1168         break;
1169       default:
1170         break;
1171       }
1172     }
1173     break;
1174 
1175   /* ------------------------------------------------------------------ */
1176   /*
1177    *	<stend> ::=
1178    */
1179   case STEND1:
1180     if (sem.pgphase >= PHASE_EXEC) {
1181      if (sem.atomic[0]) {
1182         sem.atomic[0] = sem.atomic[1] = sem.atomic[2] = FALSE;
1183         error(155, 3, gbl.lineno,
1184               "Statement after ATOMIC UPDATE is not an assignment", CNULL);
1185       } else {
1186         sem.atomic[0] = sem.atomic[1];
1187         sem.atomic[1] = FALSE;
1188       }
1189       if (sem.mpaccatomic.pending &&
1190           sem.mpaccatomic.action_type != ATOMIC_CAPTURE) {
1191         error(155, 3, gbl.lineno,
1192               "Statement after ATOMIC UPDATE is not an assignment", CNULL);
1193       }
1194       if (sem.mpaccatomic.seen &&
1195           sem.mpaccatomic.action_type != ATOMIC_CAPTURE) {
1196         if ((!sem.mpaccatomic.is_acc && use_opt_atomic(sem.doif_depth))) {
1197          ;
1198         } else {
1199           if (sem.mpaccatomic.is_acc)
1200             sem.mpaccatomic.seen = FALSE;
1201           sem.mpaccatomic.pending = TRUE;
1202         }
1203       }
1204     }
1205     freearea(0); /* free ITEM list areas */
1206     sem.new_param_dt = 0;
1207     sem.param_offset = 0;
1208     sem.kind_type_param = 0;
1209     sem.len_type_param = 0;
1210     sem.type_param_candidate = 0;
1211     sem.len_candidate = 0;
1212     sem.kind_candidate = 0;
1213     sem.type_param_sptr = 0;
1214     sem.param_struct_constr = 0;
1215     sem.save_aconst = 0;
1216     sem.tbp_arg = 0;
1217     sem.tbp_arg_cnt = 0;
1218     sem.extends = 0;
1219     if (sem.select_type_seen > 1) {
1220       error(155, 3, gbl.lineno,
1221             "Only a CLASS IS, TYPE IS, CLASS DEFAULT, or END SELECT"
1222             " statement may follow a SELECT TYPE statement",
1223             CNULL);
1224     } else if (sem.select_type_seen == 1) {
1225       sem.select_type_seen = 2;
1226     } else {
1227       sem.select_type_seen = 0;
1228     }
1229     if (flg.smp && sem.doif_base && sem.doif_depth &&
1230         DI_ID(sem.doif_depth) != DI_SELECT_TYPE)
1231       check_no_scope_sptr();
1232     entity_attr.access = ' '; /* Need to reset entity access */
1233     sem.parsing_operator = false;
1234     break;
1235 
1236   /* ------------------------------------------------------------------ */
1237   /*
1238    *      <statement> ::= <prog title>  |
1239    */
1240   case STATEMENT1:
1241     prevphase = sem.pgphase;
1242     sem.gdtype = -1;
1243     lenspec[0].kind = 0;
1244     /*if( sem.which_pass == 1 )
1245         restore_internal_subprograms();*/
1246     restored = 0;
1247     goto statement_shared;
1248   /*
1249    *      <statement> ::= <nii> <nim> <entry statement> |
1250    */
1251   case STATEMENT2:
1252     prevphase = sem.pgphase;
1253     SST_ASTP(LHS, SST_ASTG(RHS(3)));
1254     goto statement_shared;
1255   /*
1256    *      <statement> ::= <declaration> |
1257    */
1258   case STATEMENT3:
1259     sem.class = 0;
1260     prevphase = sem.pgphase;
1261     if (scn.stmtyp == TK_IMPLICIT) {
1262       if (sem.pgphase > PHASE_IMPLICIT)
1263         errsev(70);
1264       else
1265         sem.pgphase = PHASE_IMPLICIT;
1266     } else if (scn.stmtyp == TK_DATA || scn.stmtyp == TK_NAMELIST) {
1267       if (sem.pgphase > PHASE_EXEC)
1268         errsev(70);
1269       else if (sem.pgphase < PHASE_SPEC)
1270         sem.pgphase = PHASE_SPEC;
1271     } else if (scn.stmtyp == TK_INTERFACE || scn.stmtyp == TK_ABSTRACT) {
1272       sem.pgphase = PHASE_INIT;
1273       prevphase = PHASE_INIT;
1274     } else if (scn.stmtyp == TK_PARAMETER) {
1275       if (sem.pgphase > PHASE_SPEC)
1276         errsev(70);
1277       else if (sem.pgphase < PHASE_IMPLICIT)
1278         sem.pgphase = PHASE_IMPLICIT;
1279     } else if (scn.stmtyp == TK_USE) {
1280       if (sem.pgphase > PHASE_USE)
1281         errsev(70);
1282       else if (sem.pgphase < PHASE_USE)
1283         sem.pgphase = PHASE_USE;
1284     } else if (scn.stmtyp == TK_IMPORT) {
1285       if (sem.pgphase > PHASE_IMPORT)
1286         errsev(70);
1287       else if (sem.pgphase < PHASE_IMPORT)
1288         sem.pgphase = PHASE_IMPORT;
1289     } else {
1290       if (sem.pgphase > PHASE_SPEC)
1291         errsev(70);
1292 /* allow for routine before a use statement */
1293       /* allow for attributes before a use statement */
1294       else if (scn.stmtyp != TK_ATTRIBUTES && scn.stmtyp != TK_MP_DECLARESIMD)
1295         sem.pgphase = PHASE_SPEC;
1296     }
1297     sem.gdtype = -1;
1298     lenspec[0].kind = 0;
1299     goto statement_shared;
1300   /*
1301    *      <statement> ::= <nii> <nim> <simple stmt> |
1302    */
1303   case STATEMENT4:
1304     prevphase = sem.pgphase;
1305     SST_ASTP(LHS, SST_ASTG(RHS(3)));
1306     goto statement_shared;
1307   /*
1308    *      <statement> ::= <nii> <nim> <GOTO stmt>   |
1309    */
1310   case STATEMENT5:
1311     prevphase = sem.pgphase;
1312     SST_ASTP(LHS, SST_ASTG(RHS(3)));
1313     goto executable_shared;
1314   /*
1315    *      <statement> ::= <nii> <nim> <control stmt> |
1316    */
1317   case STATEMENT6:
1318     prevphase = sem.pgphase;
1319     SST_ASTP(LHS, SST_ASTG(RHS(3)));
1320     goto executable_shared;
1321   /*
1322    *      <statement> ::= <nii> <nim> <format stmt>  |
1323    */
1324   case STATEMENT7:
1325     prevphase = sem.pgphase;
1326     if (sem.pgphase == PHASE_INIT)
1327       sem.pgphase = PHASE_HEADER;
1328     /*
1329      * Allow semant ccsym vars allocated by get_temp to be re-used for
1330      * the next statement, if necessary:
1331      */
1332     sem.temps_reset = FALSE;
1333     SST_ASTP(LHS, SST_ASTG(RHS(3)));
1334     if (SST_ASTG(LHS)) /* TBD: delete this and next stmt */
1335       (void)add_stmt((int)SST_ASTG(LHS));
1336     goto statement_end;
1337   /*
1338    *	<statement> ::= <null stmt> |
1339    */
1340   case STATEMENT8:
1341     prevphase = sem.pgphase;
1342     if (scn.currlab) {
1343       errlabel(18, 3, gbl.lineno, SYMNAME(scn.currlab),
1344                "- must be followed by a keyword or an identifier");
1345       ast = mk_stmt(A_CONTINUE, 0);
1346       SST_ASTP(LHS, ast);
1347       DEFDP(scn.currlab, 1);
1348       goto executable_shared;
1349     }
1350     SST_ASTP(LHS, 0); /* don't change sem.pgphase */
1351     break;
1352   /*
1353    *      <statement> ::= <end> <end stmt>     |
1354    */
1355   case STATEMENT9:
1356     /*
1357      * Initialize AST field since an A_END is not generated for the end
1358      * of a host subprogram containing internal procedures
1359      */
1360     prevphase = sem.pgphase;
1361     if (!sem.interface && sem.pgphase < PHASE_EXEC) {
1362       reloc_byvalue_parameters();
1363       if (sem.which_pass == 1 && restored == 0) {
1364         restore_internal_subprograms();
1365         restored = 1;
1366       }
1367     }
1368     SST_ASTP(LHS, 0);
1369     if (sem.interface) {
1370       if ((gnr = sem.interf_base[sem.interface - 1].generic)) {
1371         if (GTYPEG(gnr) && gbl.rutype == RU_SUBR) {
1372           error(155, 3, gbl.lineno, "Generic INTERFACE with the same name as a "
1373                                     "derived type may only contain functions -",
1374                 SYMNAME(gbl.currsub));
1375           GTYPEP(gnr, 0);
1376         }
1377         if (GNCNTG(gnr) == 0)
1378           sem.interf_base[sem.interface - 1].gnr_rutype = gbl.rutype;
1379         else if (sem.interf_base[sem.interface - 1].gnr_rutype &&
1380                  sem.interf_base[sem.interface - 1].gnr_rutype != gbl.rutype) {
1381 
1382            errWithSrc(155, 3, SST_LINENOG(RHS(2)),
1383                    "Generic INTERFACE may not mix functions and subroutines",
1384                    CNULL, SST_COLUMNG(RHS(2)), 0, false, CNULL);
1385         }
1386 
1387         if (gbl.currsub)
1388           add_overload(gnr, gbl.currsub);
1389       } else if ((gnr = sem.interf_base[sem.interface - 1].operator)) {
1390         if (sem.interf_base[sem.interface - 1].opval == OP_ST) {
1391           if (gbl.rutype != RU_SUBR)
1392             error(155, 3, gbl.lineno,
1393                   "Assignment INTERFACE requires subroutines -",
1394                   SYMNAME(gbl.currsub));
1395           else if (PARAMCTG(gbl.currsub) != 2)
1396             error(155, 3, gbl.lineno,
1397                   "Assignment INTERFACE requires subroutines 2 arguments -",
1398                   SYMNAME(gbl.currsub));
1399         } else {
1400           if (gbl.rutype != RU_FUNC)
1401             error(155, 3, gbl.lineno, "Operator INTERFACE requires functions -",
1402                   SYMNAME(gbl.currsub));
1403           else if (PARAMCTG(gbl.currsub) != 1 && PARAMCTG(gbl.currsub) != 2)
1404             error(
1405                 155, 3, gbl.lineno,
1406                 "Operator INTERFACE requires functions with 1 or 2 arguments -",
1407                 SYMNAME(gbl.currsub));
1408         }
1409         add_overload(gnr, gbl.currsub);
1410       }
1411       if (gbl.currsub)
1412         pop_subprogram();
1413       break;
1414     }
1415 
1416     if (gbl.rutype == RU_BDATA) {
1417       /* error if executable statements in block data: */
1418       if (sem.pgphase > PHASE_SPEC)
1419         errsev(71);
1420     } else if (!end_of_host && SST_IDG(RHS(2))) {
1421       chk_adjarr(); /* any extra code for adjustable arrays */
1422       end_subprogram_checks();
1423     }
1424     /*
1425      * The END statement may be for a module or subprogram.  If a
1426      * subprogram, the end AST is generated and semfin() is called.
1427      * If the end of a module, there are two cases:
1428      * 1.  only specifications were seen (i.e., no contained subprograms);
1429      *     since the module blockdata will be output, the end AST needs
1430      *     to be generated, however, semfin() can't be called.
1431      * 2.  module subprograms were present; the module blockdata was
1432      *     already written when the CONTAINS was seen; no END ast is
1433      *     necessary; semfin() still can't be called.
1434      */
1435     if (gbl.currsub || gbl.rutype == RU_PROG)
1436       SST_ASTP(LHS, mk_stmt(A_END, 0));
1437     if (SST_IDG(RHS(2))) /* end of subprogram */
1438       sem.pgphase = PHASE_END;
1439     else
1440       sem.pgphase = PHASE_END_MODULE; /* end of module */
1441     goto statement_shared;
1442   /*
1443    *      <statement> ::= <empty file>
1444    */
1445   case STATEMENT10:
1446     prevphase = sem.pgphase;
1447     goto statement_end;
1448   /*
1449    *	<statement> ::= INCLUDE <quoted string>
1450    */
1451   case STATEMENT11:
1452     prevphase = sem.pgphase;
1453     sptr = SST_SYMG(RHS(2));
1454     scan_include(stb.n_base + CONVAL1G(sptr));
1455     goto statement_end;
1456   /*
1457    *	<statement> ::= <nii> <nim> OPTIONS |
1458    *           [stuff that follows OPTIONS is not parsed - hidden by scanner]
1459    */
1460   case STATEMENT12:
1461     prevphase = sem.pgphase;
1462     if (flg.standard)
1463       error(171, 2, gbl.lineno, "OPTIONS", CNULL);
1464     if (sem.pgphase != PHASE_INIT || seen_options)
1465       errsev(70);
1466     else {
1467       scan_options();
1468       seen_options = TRUE;
1469     }
1470     goto statement_end;
1471   /*
1472    *	<statement> ::= <nis> <nii> CONTAINS |
1473    */
1474   case STATEMENT13:
1475     prevphase = sem.pgphase;
1476     SST_ASTP(LHS, 0);
1477     /*do_iface(0);*/
1478     reloc_byvalue_parameters();
1479     if (sem.pgphase >= PHASE_CONTAIN)
1480       errsev(70);
1481     sem.pgphase = PHASE_CONTAIN;
1482     if (gbl.currsub) {
1483       /* internal subprogram context */
1484       if (gbl.rutype == RU_BDATA) {
1485         errsev(70);
1486         goto executable_shared;
1487       }
1488       if (gbl.internal) {
1489         error(155, 3, gbl.lineno, "Internal subprograms may not be nested",
1490               CNULL);
1491         goto executable_shared;
1492       }
1493       convert_intrinsics_to_idents();
1494       save_host(&host_state);
1495       gbl.internal = 1;
1496       if (sem.which_pass == 0)
1497         gbl.empty_contains = FALSE;
1498       restore_host(&host_state, TRUE);
1499       if (sem.which_pass == 0) {
1500         /*
1501          * when first processing an internal procedure within a module
1502          * subprogram, need to save the state of the host which will be
1503          * restored for subsequent internal procedures within the same
1504          * module subprogram.  Note that the scanner ensures that the
1505          * end statement of the internal procedure in this context
1506          * (processing a module the first time) does not terminate
1507          * compilation (scn.end_program_unit is FALSE).
1508          */
1509         save_host_state(0x3);
1510         sem.pgphase = PHASE_INIT;
1511         SST_ASTP(LHS, 0);
1512       } else {
1513         chk_adjarr(); /* any extra code for adjustable arrays */
1514         end_subprogram_checks();
1515         fix_class_args(gbl.currsub);
1516         save_host_state(0x11);
1517         /*
1518          * When the CONTAINS is seen, ensure that an END ast is
1519          * generated for the host subprogram.
1520          * Note that scan has set 'scn.end_program_unit to TRUE'.
1521          */
1522         if (sem.end_host_labno && sem.which_pass) {
1523           int labsym = getsymf(".L%05ld", (long)sem.end_host_labno);
1524           /*
1525            * If a label was present on the end statement of the
1526            * host subprogram, need to define & emit the label now.
1527            */
1528           int lab = declref(labsym, ST_LABEL, 'd');
1529           if (DEFDG(lab))
1530             errlabel(97, 3, 0, SYMNAME(labsym), CNULL);
1531           else
1532             scn.currlab = lab;
1533           L3FP(lab, 1); /* HACK - disable errorcheck in scan.c*/
1534         }
1535         SST_ASTP(LHS, mk_stmt(A_END, 0));
1536       }
1537       sem.end_host_labno = 0;
1538       goto statement_shared;
1539     }
1540     if (IN_MODULE) {
1541       if (ANCESTORG(gbl.currmod) && !HAS_SMP_DECG(ANCESTORG(gbl.currmod)))
1542         error(1210, ERR_Severe, gbl.lineno,
1543               SYMNAME(ANCESTORG(gbl.currmod)), CNULL);
1544       fe_save_state();
1545       begin_contains();
1546       sem.pgphase = PHASE_INIT;
1547       /*
1548        * When the CONTAINS is seen, emit a blockdata just in case any
1549        * data statements are seen; ensure that an END ast is generated.
1550        * Note that scan has set 'scn.end_program_unit to TRUE'.
1551        */
1552       SST_ASTP(LHS, mk_stmt(A_END, 0));
1553       goto statement_shared;
1554     }
1555     errsev(70);
1556     goto executable_shared;
1557   /*
1558    *	<statement> ::= <directive>
1559    */
1560   case STATEMENT14:
1561     prevphase = sem.pgphase;
1562     if (sem.interface == 0) {
1563       ast = mk_comstr(scn.directive);
1564       (void)add_stmt(ast);
1565     }
1566     goto statement_end;
1567 
1568   executable_shared:
1569     sem.pgphase = PHASE_EXEC;
1570     sem.temps_reset = FALSE;
1571   /* fall thru to 'statement_shared' */
1572 
1573   statement_shared:
1574 
1575     if ((ast = SST_ASTG(LHS))) {
1576       (void)add_stmt(ast);
1577       SST_ASTG(LHS) = 0;
1578     }
1579     sem.dinit_error = FALSE;
1580     gen_deallocate_arrays();
1581 
1582    if (sem.atomic[2]) {
1583       ast = mk_stmt(A_ENDATOMIC, 0);
1584       (void)add_stmt(ast);
1585       sem.atomic[0] = sem.atomic[2] = FALSE;
1586     }
1587     if (sem.mpaccatomic.apply &&
1588         sem.mpaccatomic.action_type != ATOMIC_CAPTURE) {
1589       int ecs;
1590       sem.mpaccatomic.apply = FALSE;
1591       if (!sem.mpaccatomic.is_acc) {
1592         if (use_opt_atomic(sem.doif_depth)) {
1593           ecs = mk_stmt(A_MP_ENDATOMIC, 0);
1594           add_stmt(ecs);
1595         } else {
1596           ecs = emit_bcs_ecs(A_MP_ENDCRITICAL);
1597           /* point to each other */
1598           A_LOPP(ecs, sem.mpaccatomic.ast);
1599           A_LOPP(sem.mpaccatomic.ast, ecs);
1600         }
1601         sem.mpaccatomic.ast = 0;
1602       } else {
1603         int ast_atomic;
1604         ast_atomic = mk_stmt(A_ENDATOMIC, 0);
1605         add_stmt(ast_atomic);
1606         A_LOPP(ast_atomic, sem.mpaccatomic.ast);
1607         A_LOPP(sem.mpaccatomic.ast, ast_atomic);
1608         sem.mpaccatomic.ast = 0;
1609       }
1610     }
1611     /*
1612      * If the current statement is labeled and we are inside a DO [WHILE|
1613      * CONCURRENT] loop, search to see if this statement ends the loop.
1614      *
1615      * OpenMP ARB interpretations version 1.0:
1616      * If a do loop nest which shares the same termination statement is
1617      * followed by an ENDDO or ENDPARALLEL, the DO or PARALLEL DO can
1618      * only be specified for the outermost DO.
1619      */
1620     if (scn.currlab != 0 && sem.doif_depth > 0) {
1621       int par_type = 0; /* nonzero => par do needs to be closed */
1622       for (doif = sem.doif_depth; doif > 0; --doif) {
1623         if ((DI_ID(doif) == DI_DO || DI_ID(doif) == DI_DOWHILE ||
1624              DI_ID(doif) == DI_DOCONCURRENT) &&
1625              DI_DO_LABEL(doif) == scn.currlab) {
1626           switch (par_type) {
1627           /*
1628            * If a parallel do appears between two do loops sharing the
1629            * same termination statement, close the parallel do now.
1630            * (The innermost do loop is the parallel do.)
1631            */
1632           case DI_PDO:
1633           case DI_TARGETSIMD:
1634           case DI_SIMD:
1635           case DI_DISTRIBUTE:
1636           case DI_DISTPARDO:
1637           case DI_DOACROSS:
1638           case DI_PARDO:
1639           case DI_TASKLOOP:
1640           case DI_ACCDO:
1641           case DI_ACCLOOP:
1642           case DI_CUFKERNEL:
1643             sem.close_pdo = FALSE;
1644             --sem.doif_depth;
1645             par_type = 0;
1646           }
1647           do_end(DI_DOINFO(doif));
1648           if (sem.which_pass)
1649             direct_loop_end(DI_LINENO(doif), gbl.lineno);
1650           par_type = DI_ID(sem.doif_depth);
1651         }
1652       }
1653     }
1654 
1655     /* For END statements clean up end of program unit. */
1656     if (sem.pgphase == PHASE_END) {
1657       if (!end_of_host) {
1658         semfin();
1659         if (IN_MODULE && sem.interface == 0)
1660           mod_end_subprogram_two();
1661         if (sem.which_pass != 0 || gbl.internal == 0)
1662           semfin_free_memory();
1663         if (sem.which_pass == 0) {
1664           /* CONTAINS clause has an empty body without any internal subprograms */
1665           if (gbl.internal == 1) {
1666             /* even if it CONTAINS no internal routine, still need to change
1667                the entry points of the containing */
1668             if (STYPEG(gbl.currsub) == ST_ENTRY)
1669               STYPEP(gbl.currsub, ST_PROC);
1670 
1671             gbl.currsub = 0;
1672             gbl.internal = 0;
1673             gbl.empty_contains = TRUE;
1674             gbl.p_adjarr = NOSYM;
1675             gbl.p_adjstr = NOSYM;
1676           } else if (gbl.internal > 1) {
1677             /*
1678              * we're at the end of an internal procedure within a
1679              * a module during the first pass over the module.
1680              * The scanner does not set scn.end_program_unit to TRUE
1681              * in this context.  So now, need to reinitialize for the
1682              * next internal subprogram if it appears.
1683              */
1684             restore_host_state(1);
1685             restore_host(&host_state, TRUE);
1686             gbl.currsub = 0;
1687             sem.pgphase = PHASE_INIT;
1688             gbl.p_adjarr = NOSYM;
1689             gbl.p_adjstr = NOSYM;
1690           }
1691         }
1692     } else {
1693         if (IN_MODULE && sem.interface == 0) {
1694           gbl.currsub = end_of_host;
1695           mod_end_subprogram_two();
1696           gbl.currsub = 0;
1697         }
1698         semfin_free_memory();
1699       }
1700     } else if (sem.pgphase == PHASE_END_MODULE) { /* end of module */
1701       sem.pgphase = PHASE_INIT;
1702       /*
1703        * For a module containing just specifications, end_module() calls
1704        * semfin() in which case sem.doif_base is NULL.
1705        * For a module with contained subprograms, semfin() isn't called
1706        * after the last END statement.
1707        */
1708       semfin_free_memory();
1709       if (sem.which_pass) {
1710         gbl.currmod = 0;
1711       }
1712     } else if (sem.pgphase == PHASE_CONTAIN && gbl.internal && sem.which_pass) {
1713       /* end of host subprogram*/
1714       semfin();
1715       if (sem.mod_sym && sem.interface == 0)
1716         mod_end_subprogram_two();
1717       if (sem.which_pass != 0 || gbl.internal == 0)
1718         semfin_free_memory();
1719     }
1720     /*
1721      * Allow semant ccsym vars allocated by get_temp to be re-used for
1722      * the next statement, if necessary:
1723      */
1724     sem.temps_reset = FALSE;
1725   /* fall thru to 'statement_end' */
1726 
1727   statement_end: /* Processing for all <statement>s terminates here */
1728     if (STYPEG(gbl.currsub) == ST_ENTRY && FVALG(gbl.currsub) &&
1729         prevphase <= PHASE_USE && sem.pgphase > PHASE_USE) {
1730       int retdtype = DTYPEG(FVALG(gbl.currsub));
1731       int dtsptr = DTY(retdtype + 3);
1732       if (DTY(retdtype) == TY_DERIVED && dtsptr > NOSYM && !DCLDG(dtsptr)) {
1733         fixup_function_return_type(retdtype, dtsptr);
1734       }
1735     }
1736 
1737     sem.last_std = STD_PREV(0);
1738     break;
1739 
1740   /* ------------------------------------------------------------------ */
1741   /*
1742    *	<iii> ::=
1743    */
1744   case III1:
1745     if (sem.interface) {
1746       error(155, 1, gbl.lineno, "Statement is redundant in an INTERFACE block",
1747             CNULL);
1748       sem.ignore_stmt = TRUE;
1749     }
1750     /* check whether we have entered a program as yet */
1751     if (sem.scope_level == 0) {
1752       dummy_program();
1753       restored = 0;
1754     }
1755     break;
1756 
1757   /* ------------------------------------------------------------------ */
1758   /*
1759    *	<nii> ::=
1760    */
1761   case NII1:
1762     if (sem.interface) {
1763       errsev(195);
1764       sem.ignore_stmt = TRUE;
1765     }
1766     /* check whether we have entered a program as yet */
1767     if (sem.scope_level == 0) {
1768       dummy_program();
1769       restored = 0;
1770     }
1771     break;
1772 
1773   /* ------------------------------------------------------------------ */
1774   /*
1775    *	<nim> ::=
1776    */
1777   case NIM1:
1778     if (IN_MODULE_SPEC) {
1779       ERR310("Illegal statement in the specification part of a MODULE", CNULL);
1780       sem.ignore_stmt = TRUE;
1781     }
1782     break;
1783 
1784   /* ------------------------------------------------------------------ */
1785   /*
1786    *	<pgm> ::=
1787    */
1788   case PGM1:
1789     /* check that we have entered a program as yet */
1790     if (sem.scope_level == 0)
1791       dummy_program();
1792     break;
1793 
1794   /* ------------------------------------------------------------------ */
1795   /*
1796    *	<end> ::=
1797    */
1798   case END1:
1799     if (!sem.interface && sem.pgphase < PHASE_EXEC) {
1800       if (gbl.currsub && !sem.which_pass) {
1801         do_iface(0);
1802       }
1803       if (!IN_MODULE)
1804         do_iface(1);
1805       else
1806         do_iface_module();
1807     } else if (sem.which_pass && !IN_MODULE && gbl.internal <= 1) {
1808         do_iface(1);
1809     }
1810     break;
1811 
1812   /* ------------------------------------------------------------------ */
1813   /*
1814    *      <prog title> ::= <routine id>    |
1815    */
1816   case PROG_TITLE1:
1817     itemp = ITEM_END;
1818     func_result = 0;
1819     goto prog_title;
1820   /*
1821    *      <prog title> ::= <routine id> ( ) <func suffix> |
1822    */
1823   case PROG_TITLE2:
1824     itemp = ITEM_END;
1825     func_result = SST_SYMG(RHS(4));
1826     goto prog_title;
1827   /*
1828    *      <prog title> ::= <routine id> ( <formal list> ) <func suffix>  |
1829    */
1830   case PROG_TITLE3:
1831     itemp = SST_BEGG(RHS(3));
1832     func_result = SST_SYMG(RHS(5));
1833   prog_title:
1834     /* no parameters allowed for programs */
1835     if (gbl.rutype == RU_PROG && itemp != ITEM_END)
1836       errsev(41);
1837     if (!sem.interface)
1838       gbl.funcline = gbl.lineno;
1839 
1840     if (gbl.rutype == RU_FUNC) {
1841       /* reserve one extra space in case this a function requires an
1842        * extra argument - a new argument may be inserted at the
1843        * beginning of the list.
1844        */
1845       NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
1846            aux.dpdsc_size + 100);
1847       *(aux.dpdsc_base + (aux.dpdsc_avl++)) = 0;
1848     }
1849 
1850     DPDSCP(gbl.currsub, aux.dpdsc_avl);
1851     NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
1852          aux.dpdsc_size + 100);
1853     *(aux.dpdsc_base + (aux.dpdsc_avl)) = 0;
1854     count = 0;
1855     for (; itemp != ITEM_END; itemp = itemp->next) {
1856       sptr = itemp->t.sptr;
1857       if (sptr == 0) { /* alternate return designator (i.e. *) */
1858         if (gbl.rutype != RU_SUBR)
1859           errsev(49);
1860         else if (!sem.interface)
1861           gbl.arets = TRUE;
1862       } else {
1863         if ((sptr < gbl.currsub) && IN_MODULE) {
1864           sptr = insert_sym(sptr);
1865         }
1866         sptr = declsym(sptr, ST_IDENT, TRUE);
1867         if (SCG(sptr) != SC_NONE)
1868           error(42, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1869         SCP(sptr, SC_DUMMY);
1870         if (sem.interface) {
1871           NODESCP(sptr, 1);
1872           IGNOREP(sptr, TRUE);
1873         }
1874       }
1875       count++;
1876       NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
1877            aux.dpdsc_size + 100);
1878       *(aux.dpdsc_base + (aux.dpdsc_avl++)) = sptr;
1879     }
1880     /* Set parameter count
1881      *
1882      * For procedure pointer symbols it should go into dtype, for old style
1883      * procedure symbols use PARAMCT attribute.
1884      *
1885      * FIXME this might need to go into a function
1886      */
1887     if (is_procedure_ptr(gbl.currsub)) {
1888       set_proc_ptr_param_count_dtype(DTYPEG(gbl.currsub), count);
1889     } else {
1890       PARAMCTP(gbl.currsub, count);
1891     }
1892     SST_ASTP(LHS, 0);
1893 
1894     if (IN_MODULE && sem.interface == 0)
1895       gbl.currsub = mod_add_subprogram(gbl.currsub);
1896     record_func_result(gbl.currsub, func_result, FALSE /* not in ENTRY */);
1897     if (bind_attr.exist != -1) {
1898       process_bind(gbl.currsub);
1899       bind_attr.exist = -1;
1900       bind_attr.altname = 0;
1901     }
1902     break;
1903 
1904   /*
1905    *      <prog title> ::= BLOCKDATA   |
1906    */
1907   case PROG_TITLE4:
1908     rhstop = 1;
1909     gbl.rutype = RU_BDATA;
1910     sem.module_procedure = false;
1911     SST_SYMP(RHS(rhstop), getsymbol(".blockdata."));
1912     CCSYMP(SST_SYMG(RHS(rhstop)), 1);
1913     if (IN_MODULE)
1914       ERR310("BLOCKDATA may not appear in a MODULE", CNULL);
1915     goto routine_id;
1916   /*
1917    *      <prog title> ::= BLOCKDATA <id> |
1918    */
1919   case PROG_TITLE5:
1920     rhstop = 2;
1921     gbl.rutype = RU_BDATA;
1922     sem.module_procedure = false;
1923     if (IN_MODULE)
1924       ERR310("BLOCKDATA may not appear in a MODULE", CNULL);
1925     goto routine_id;
1926   /*
1927    *	<prog title> ::= MODULE <id> |
1928    */
1929   case PROG_TITLE6:
1930     sem.submod_sym = 0;
1931     sptr = begin_module(SST_SYMG(RHS(2)));
1932     sptr1 = NOSYM;
1933     goto module_shared;
1934   /*
1935    *	<prog title> ::= SUBMODULE ( <id> ) <id> |
1936    */
1937   case PROG_TITLE7:
1938     sem.submod_sym = SST_SYMG(RHS(5));
1939     sptr = begin_submodule(sem.submod_sym, SST_SYMG(RHS(3)), NOSYM, &sptr1);
1940     STYPEP(sem.submod_sym, ST_MODULE);
1941     goto module_shared;
1942   /*
1943    *	<prog title> ::= SUBMODULE ( <id> : <id> ) <id> |
1944    */
1945   case PROG_TITLE8:
1946     sem.submod_sym = SST_SYMG(RHS(7));
1947     sptr = begin_submodule(sem.submod_sym, SST_SYMG(RHS(3)), SST_SYMG(RHS(5)),
1948                            &sptr1);
1949     goto module_shared;
1950   /*
1951    *   <prog title> ::= <module procedure stmt>
1952    */
1953   case PROG_TITLE9:
1954     break;
1955   module_shared:
1956     gbl.prog_file_name = (char *)getitem(15, strlen(gbl.curr_file) + 1);
1957     strcpy(gbl.prog_file_name, gbl.curr_file);
1958     if (sem.pgphase != PHASE_INIT) {
1959       errsev(70);
1960       break;
1961     }
1962     if (sem.mod_sym) {
1963       if (sem.mod_cnt == 1)
1964         /* issue error during first pass */
1965         ERR310("MODULEs may not be nested", CNULL);
1966       break;
1967     }
1968     sem.mod_cnt++;
1969     sem.pgphase = PHASE_HEADER;
1970     sem.mod_sym = sptr;
1971     setfile(1, SYMNAME(sem.mod_sym), 0);
1972     gbl.currmod = sem.mod_sym;
1973     push_scope_level(sem.mod_sym, SCOPE_NORMAL);
1974     push_scope_level(sem.mod_sym, SCOPE_MODULE);
1975     SST_ASTP(LHS, 0);
1976     clear_subp_prefix_settings(&subp_prefix);
1977 
1978     /* SUBMODULEs work as if they are hosted within their immediate parents. */
1979     if (sptr1 > NOSYM) {
1980       sem.use_seen = TRUE;
1981       sem.pgphase = PHASE_USE;
1982       init_use_stmts();
1983       open_module(sptr1);
1984       add_submodule_use();
1985       close_module();
1986     }
1987     break;
1988 
1989   /* ------------------------------------------------------------------ */
1990   /*
1991    *	<ident> ::= <id>
1992    */
1993   case IDENT1:
1994     sptr = SST_SYMG(RHS(1));
1995     if (STYPEG(sptr) == ST_ALIAS) {
1996       /*SST_SYMP(LHS, SYMLKG(sptr));*/
1997       SST_ALIASP(LHS, 1);
1998     } else
1999       SST_ALIASP(LHS, 0);
2000     SST_IDP(LHS, S_IDENT);
2001     break;
2002 
2003   /* ------------------------------------------------------------------ */
2004   /*
2005    *	<id> ::= <id name>
2006    */
2007   case ID1:
2008     np = scn.id.name + SST_CVALG(RHS(1));
2009     sptr = getsymbol(np);
2010     if (sem.in_dim && sem.type_mode && !KINDG(sptr) &&
2011         STYPEG(sptr) != ST_MEMBER) {
2012       /* possible use of a type parameter in the dimension field
2013        * of an array type component declaration
2014        */
2015       KINDP(sptr, -1);
2016     }
2017     SST_SYMP(LHS, sptr);
2018     SST_ACLP(LHS, 0);
2019 #ifdef GSCOPEP
2020     if (!sem.which_pass && gbl.internal <= 1 && gbl.currsub) {
2021       ident_host_sub = gbl.currsub;
2022     } else if (!sem.which_pass && gbl.internal > 1 && gbl.currsub
2023                /* && STYPEG(sptr)*/) {
2024       defer_ident_list(sptr, ident_host_sub);
2025     } else if (sem.which_pass && gbl.internal <= 1 &&
2026                internal_proc_has_ident(sptr, gbl.currsub)) {
2027       if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) {
2028         if (FVALG(sptr))
2029           GSCOPEP(FVALG(sptr), 1);
2030       } else if (STYPEG(sptr) == ST_UNKNOWN || STYPEG(sptr) == ST_IDENT ||
2031                  ST_ISVAR(STYPEG(sptr))) {
2032         GSCOPEP(sptr, 1);
2033       }
2034     }
2035 #endif
2036     break;
2037 
2038   /* ------------------------------------------------------------------ */
2039   /*
2040    *	<func suffix> ::=  |
2041    */
2042   case FUNC_SUFFIX1:
2043     SST_SYMP(LHS, 0);
2044     break;
2045   /*
2046    *      <func suffix> ::= BIND  <bind attr> <id name> ( <id name> ) |
2047    */
2048   case FUNC_SUFFIX2:
2049     result_name = SST_CVALG(RHS(3));
2050     id_name = SST_CVALG(RHS(5));
2051     goto result_shared;
2052   /*
2053    *      <func suffix> ::= BIND <bind attr> |
2054    */
2055   case FUNC_SUFFIX3:
2056 
2057     /* pass nothing */
2058     SST_SYMP(LHS, 0);
2059     break;
2060 
2061   /*
2062    *      <func suffix> ::= <id name> ( <id name> )  BIND <bind attr>
2063    */
2064   case FUNC_SUFFIX4:
2065   /* do nothing */
2066   /* fall through */
2067   /*
2068    *	<func suffix> ::= <id name> ( <id name> )
2069    */
2070   case FUNC_SUFFIX5:
2071 
2072     result_name = SST_CVALG(RHS(1));
2073     id_name = SST_CVALG(RHS(3));
2074   result_shared:
2075     sptr = 0;
2076     np = scn.id.name + result_name;
2077     if (sem_strcmp(np, "result") == 0) {
2078       np2 = scn.id.name + id_name;
2079       sptr2 = getsymbol(np2);
2080 
2081       sptr = chk_intrinsic(sptr2, FALSE, FALSE);
2082       if (scn.stmtyp == TK_ENTRY && gbl.rutype == RU_FUNC) {
2083         /* have a function entry - create its result variable */
2084         sptr = create_func_entry_result(sptr);
2085       } else {
2086         sptr = declsym(sptr, ST_IDENT, TRUE);
2087         SCP(sptr, SC_DUMMY);
2088       }
2089       if (sem.interface) {
2090         NODESCP(sptr, 1);
2091         IGNOREP(sptr, TRUE);
2092       }
2093     } else
2094       error(34, 3, gbl.lineno, np, CNULL);
2095     SST_SYMP(LHS, sptr);
2096     break;
2097 
2098   /* ------------------------------------------------------------------ */
2099   /*
2100    *      <entry statement> ::= <entry id> |
2101    */
2102   case ENTRY_STATEMENT1:
2103     itemp = ITEM_END;
2104     func_result = 0;
2105     goto entry_statement;
2106   /*
2107    *      <entry statement> ::= <entry id> ( ) <func suffix> |
2108    */
2109   case ENTRY_STATEMENT2:
2110     itemp = ITEM_END;
2111     func_result = SST_SYMG(RHS(4));
2112     goto entry_statement;
2113   /*
2114    *      <entry statement> ::= <entry id> ( <formal list> ) <func suffix>
2115    */
2116   case ENTRY_STATEMENT3:
2117     itemp = SST_BEGG(RHS(3));
2118     func_result = SST_SYMG(RHS(5));
2119   entry_statement:
2120     if (flg.standard) {
2121       error(535, 2, gbl.lineno, "ENTRY statement", "FORTRAN 2008");
2122     }
2123 
2124     entry_seen = TRUE;
2125     sptr2 = SST_SYMG(RHS(1));
2126     if (sptr2 == 0) {
2127       /* an error was detected in <entry id> */
2128       SST_ASTP(LHS, 0);
2129       break;
2130     }
2131 
2132     /* write out ENTRY */
2133     sptr1 = getlab();
2134     RFCNTP(sptr1, 1);
2135 
2136     /* reserve one extra space in case this is an array-valued function -
2137      * a new argument may be inserted at the beginning of the list.
2138      */
2139     if (gbl.rutype == RU_FUNC) {
2140       NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
2141            aux.dpdsc_size + 100);
2142       *(aux.dpdsc_base + (aux.dpdsc_avl++)) = 0;
2143     } else
2144       DTYPEP(sptr2, 0);
2145     DPDSCP(sptr2, aux.dpdsc_avl);
2146     NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
2147          aux.dpdsc_size + 100);
2148     *(aux.dpdsc_base + (aux.dpdsc_avl)) = 0;
2149     count = 0;
2150     for (; itemp != ITEM_END; itemp = itemp->next) {
2151       sptr = itemp->t.sptr;
2152       if (sptr == 0) { /* alternate return designator (i.e. *) */
2153         if (gbl.rutype != RU_SUBR)
2154           errsev(49);
2155         else
2156           gbl.arets = TRUE;
2157       } else {
2158         sptr = ref_ident(sptr);
2159         stype = STYPEG(sptr);
2160         if (stype == ST_ENTRY) {
2161           error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
2162           sptr = insert_sym(sptr);
2163           SCP(sptr, SC_DUMMY);
2164         } else if (SCG(sptr) == SC_NONE) {
2165           if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_ARRAY &&
2166               stype != ST_STRUCT && stype != ST_PROC && stype != ST_VAR) {
2167             error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
2168           }
2169           SCP(sptr, SC_DUMMY);
2170         } else if (SCG(sptr) == SC_LOCAL && !SAVEG(sptr))
2171           /*
2172            * watch out for the case where an <ident> is seen
2173            * as a use in a declaration (e.g., in an adj. array
2174            * expression).  NOTE that if it's dinit'd, dinit will
2175            * issue error.
2176            */
2177           SCP(sptr, SC_DUMMY);
2178         else if (SCG(sptr) != SC_DUMMY)
2179           error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
2180       }
2181       NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
2182            aux.dpdsc_size + 100);
2183       *(aux.dpdsc_base + (aux.dpdsc_avl++)) = sptr;
2184       count++;
2185     }
2186 
2187     PARAMCTP(sptr2, count);
2188     ast = mk_stmt(A_ENTRY, 0);
2189     A_SPTRP(ast, sptr2);
2190     SST_ASTP(LHS, ast);
2191     record_func_result(sptr2, func_result, TRUE /* in ENTRY */);
2192     break;
2193 
2194   /* ------------------------------------------------------------------ */
2195   /*
2196    *      <routine id> ::= <subr prefix> SUBROUTINE <id>   |
2197    */
2198   case ROUTINE_ID1:
2199     rhstop = 3;
2200     gbl.rutype = RU_SUBR;
2201     sem.module_procedure = false;
2202     goto routine_id;
2203   /*
2204    *      <routine id> ::= <subr prefix> FUNCTION <id>  |
2205    */
2206   case ROUTINE_ID2:
2207     rhstop = 3;
2208     gbl.rutype = RU_FUNC;
2209     sem.module_procedure = false;
2210     /* data type of function not specified */
2211     lenspec[1].len = sem.gdtype = -1;
2212     lenspec[1].propagated = 0;
2213     goto routine_id;
2214   /*
2215    *      <routine id> ::= <func prefix> FUNCTION <fcn name> |
2216    */
2217   case ROUTINE_ID3:
2218     rhstop = 3;
2219     gbl.rutype = RU_FUNC;
2220     if (!(sem.deferred_func_kind || sem.deferred_func_len)) {
2221       /*
2222          The KIND was an unresolved ident (e.g., ident from an unprocessed
2223          module),
2224          skip the mod_type until after USE stmt processing
2225        */
2226       sem.gdtype =
2227           mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
2228                    lenspec[1].propagated, (int)SST_SYMG(RHS(3)));
2229     }
2230     goto routine_id;
2231   /*
2232    *      <routine id> ::= PROGRAM <id>
2233    */
2234   case ROUTINE_ID4:
2235     gbl.rutype = RU_PROG;
2236     sem.module_procedure = false;
2237     rhstop = 2;
2238     if (IN_MODULE)
2239       ERR310("PROGRAM may not appear in a MODULE", CNULL);
2240 
2241   routine_id:
2242     is_entry = FALSE;
2243     if (sem.interface && gbl.currsub) {
2244       error(303, 2, gbl.lineno, SYMNAME(gbl.currsub), CNULL);
2245       pop_subprogram();
2246       pop_scope_level(SCOPE_NORMAL);
2247     }
2248     if (gbl.empty_contains && sem.pgphase == PHASE_END && sem.which_pass == 0) {
2249       /* empty CONTAINS body with no internal subprograms */
2250       gbl.internal = 0;
2251       sem.pgphase = PHASE_INIT;
2252     }
2253     if (sem.pgphase != PHASE_INIT && !sem.interface) {
2254       if (IN_MODULE && !have_module_state()) {
2255         /* terminate -- ow, reset_module_state() will issue
2256          * an ICE because modstate_file is NULL; could say
2257          * something about CONTAINS, but we currently cannot
2258          * detect the missing CONTAINS of a module after the
2259          * first.
2260          */
2261         error(70, 0, gbl.lineno, CNULL, CNULL);
2262       }
2263       errsev(70);
2264     }
2265     /* C1548: checking MODULE prefix for subprograms that were
2266               declared as separate module procedures */
2267     if (!sem.interface && subp_prefix.module) {
2268       sptr_temp = SST_SYMG(RHS(rhstop));
2269       if (!SEPARATEMPG(sptr_temp) && !find_explicit_interface(sptr_temp))
2270         error(1056, ERR_Severe, gbl.lineno, NULL, NULL);
2271     }
2272 
2273     /* First internal subprogram after CONTAINS, semfin may have altered the
2274      * symbol table
2275      * (esp. INVOBJ) for the host subprogram processing. Restore the state to
2276      * what it was
2277      * before semfin. (FS 20415)
2278      */
2279     if (sem.which_pass && sem.pgphase == PHASE_CONTAIN && gbl.internal == 1) {
2280       restore_host_state(2);
2281     }
2282 
2283     if (!sem.interface && sem.mod_cnt == 0) {
2284       gbl.prog_file_name = (char *)getitem(15, strlen(gbl.curr_file) + 1);
2285       strcpy(gbl.prog_file_name, gbl.curr_file);
2286     }
2287     entry_seen = FALSE;
2288     if (sem.interface) {
2289       /* open the 'interface' scope */
2290       sem.scope_stack[sem.scope_level].open = TRUE;
2291       /* set curr_scope to parent's scope */
2292       stb.curr_scope = sem.scope_stack[sem.scope_level - 1].sptr;
2293       queue_tbp(SST_SYMG(RHS(rhstop)), 0, 0, 0, TBP_IFACE);
2294     }
2295     sptr1 = sptr = SST_SYMG(RHS(rhstop));
2296 
2297     sptr = refsym_inscope(sptr, OC_OTHER);
2298     if (STYPEG(sptr) == ST_ENTRY
2299         /* Call insert_sym() if there's a type bound
2300          * procedure that is in scope
2301          */
2302         || (STYPEG(sptr) == ST_PROC && CLASSG(sptr) && VTOFFG(sptr))) {
2303       /* this must be the enclosing routine */
2304       sptr = insert_sym(sptr);
2305 
2306     } else if (STYPEG(sptr) == ST_PROC && IN_MODULE_SPEC &&
2307                get_seen_contains() && !sem.which_pass &&
2308               /* separate module procedure is allowed to be declared &
2309                  defined within the same module
2310                */
2311                !IS_INTERFACEG(sptr)) {
2312       LOGICAL err = TYPDG(sptr) && SCOPEG(sptr) != stb.curr_scope;
2313       if (!err) {
2314         int dpdsc = 0;
2315         proc_arginfo(sptr, 0, &dpdsc, 0);
2316         err = dpdsc != 0;
2317       }
2318       if (err) {
2319 
2320         errWithSrc(155, 3, SST_LINENOG(RHS(rhstop)),
2321                    "Redefinition of", SYMNAME(sptr),
2322                    SST_COLUMNG(RHS(rhstop)), 0, false, CNULL);
2323       }
2324     }
2325     if (subp_prefix.pure && subp_prefix.impure) {
2326       error(545, 3, gbl.lineno, NULL, NULL);
2327     }
2328     sptr = declsym(sptr, ST_ENTRY, TRUE);
2329 
2330     if (sem.interface) {
2331       /* and now close it again */
2332       sem.scope_stack[sem.scope_level].open = FALSE;
2333       /* curr_scope will be reset by push_scope_level */
2334     }
2335     gbl.currsub = sptr;
2336     push_scope_level(sptr, SCOPE_NORMAL);
2337     if (sem.interface) {
2338       /* For submodules, don't close the scope_stack in order to make
2339        * sure entities defined in parent modules are visible in
2340        * descendant submodules
2341        */
2342       if (!subp_prefix.module)
2343         /* close the 'normal' scope */
2344         sem.scope_stack[sem.scope_level].open = 0;
2345     }
2346     push_scope_level(sptr, SCOPE_SUBPROGRAM);
2347     sem.pgphase = PHASE_HEADER;
2348     /* Set the storage class; if it's already dummy, then this subprogram
2349      * is an argument for which there is an interface.
2350      */
2351     if (SCG(sptr) != SC_DUMMY) {
2352       if (!sem.interface || !sem.interf_base[sem.interface - 1].abstract)
2353         SCP(sptr, SC_EXTERN);
2354       else {
2355         SCP(sptr, SC_NONE);
2356         if (sem.interf_base[sem.interface - 1].abstract) {
2357           ABSTRACTP(sptr, 1);
2358           INMODULEP(sptr, IN_MODULE);
2359         }
2360       }
2361     }
2362     PUREP(sptr, subp_prefix.pure);
2363     RECURP(sptr, subp_prefix.recursive);
2364     IMPUREP(sptr, subp_prefix.impure);
2365     ELEMENTALP(sptr, subp_prefix.elemental);
2366     if (subp_prefix.module) {
2367       if (!IN_MODULE && !INMODULEG(sptr)) {
2368         ERR310("MODULE prefix allowed only within a module or submodule", CNULL);
2369       } else if (sem.interface) {
2370         /* Use SEPARATEMPP to mark this is submod related subroutines,
2371          * functions, procdures to differentiate regular module. The
2372          * SEPARATEMPP field is overloaded with ISSUBMODULEP field
2373          * ISSUBMODULEP is used for name mangling.
2374          */
2375         SEPARATEMPP(sptr, TRUE);
2376         HAS_SMP_DECP(SCOPEG(sptr), TRUE);
2377         if (IN_MODULE)
2378           INMODULEP(sptr, TRUE);
2379         if (SST_FIRSTG(RHS(rhstop))) {
2380           TBP_BOUND_TO_SMPP(sptr, TRUE);
2381           /* We also set the HAS_TBP_BOUND_TO_SMP flag on the separate module
2382            * procedure's module. This indicates that the module contains a
2383            * separate module procedure declaration to which at least one TBP
2384            * has been bound.
2385            */
2386           HAS_TBP_BOUND_TO_SMPP(SCOPEG(sptr), TRUE);
2387         }
2388       } else {
2389         SEPARATEMPP(sptr, TRUE);
2390 
2391         /* check definition vs. declared interface */
2392         /*  F2008 [12.6.2.5]
2393             The characteristics and binding label of a procedure are fixed, but the
2394             remainder of the interface may differ in differing contexts, except that
2395             for a separate module procedure body.
2396          */
2397         if (sem.which_pass) {
2398           SPTR def = find_explicit_interface(sptr);
2399           /* Make sure this def is not from the contains of ancestor module*/
2400           if (def > NOSYM) {
2401             sptr_temp = SYMLKG(sptr) ? SYMLKG(sptr) : sptr;
2402             /* Check Characteristics of procedures matches for definition vs. declaration*/
2403             if (!cmp_interfaces_strict(def, sptr_temp, CMP_IFACE_NAMES |
2404                                                        CMP_SUBMOD_IFACE))
2405               ;
2406           }
2407         }
2408       }
2409     } else {
2410       if (sem.interface && SYMIG(sptr) && INMODULEG(sptr)) {
2411         for (symi = SYMIG(sptr); symi; symi = SYMI_NEXT(symi)) {
2412           if (STYPEG(SYMI_SPTR(symi)) == ST_OPERATOR ||
2413               STYPEG(SYMI_SPTR(symi)) == ST_USERGENERIC)
2414             error(1212, ERR_Severe, gbl.lineno, SYMNAME(sptr), NULL);
2415         }
2416       }
2417     }
2418     clear_subp_prefix_settings(&subp_prefix);
2419     if (gbl.rutype == RU_FUNC) {
2420       /* for a FUNCTION (including ENTRY's), compiler created
2421        * symbols are created to represent the return values and
2422        * are stored in the FVAL field of the ENTRY's.
2423        * In the worst case, each entry will have its own ccsym.
2424        * As references occur (and in semfin), an attempt will be
2425        * made to share the temporaries.  Also, at these times,
2426        * the dtype of the temporary will have to be set properly.
2427        * semfin adjusts the storage class if necessary.
2428        */
2429       if (sem.gdtype != -1) {
2430         /* data type of function was specified */
2431         DCLDP(sptr, TRUE);
2432         DTYPEP(sptr, sem.gdtype);
2433         set_char_attributes(sptr, &sem.gdtype);
2434       }
2435     } else {
2436       DTYPEP(sptr, 0);
2437     }
2438     SYMLKP(sptr, NOSYM);
2439     FUNCLINEP(sptr, gbl.lineno);
2440     if (gbl.rutype != RU_PROG) {
2441       MSCALLP(sptr, mscall);
2442 #ifdef CREFP
2443       CREFP(sptr, cref);
2444       NOMIXEDSTRLENP(sptr, nomixedstrlen);
2445 #endif
2446     }
2447     SST_ASTP(LHS, 0);
2448     if (sem.interface) {
2449       init_implicit();
2450     } else if (IN_MODULE) {
2451     } else if (gbl.internal) {
2452       gbl.internal++;
2453       host_present = 0x8;
2454       symutl.none_implicit = sem.none_implicit &= ~host_present;
2455       SCP(sptr, SC_STATIC);
2456     }
2457     seen_implicit = FALSE;
2458     seen_parameter = FALSE;
2459     if (sem.interface && gbl.internal <= 1) {
2460       /* INTERNAL flag might have gotten set in getsym()
2461        * for this symbol even though it is an interface. An interface
2462        * body should never contain a procedure defined by a subprogram,
2463        * so this flag should never be set for an interface. Because
2464        * getsym() does not have access to sem.interface, we reset the
2465        *  NTERNAL flag here.
2466        */
2467       INTERNALP(sptr, 0);
2468     }
2469     IS_INTERFACEP(sptr, sem.interface);
2470     break;
2471 
2472   /* ------------------------------------------------------------------ */
2473   /*
2474    *	<subr prefix> ::=  |
2475    */
2476   case SUBR_PREFIX1:
2477   /* fall through */
2478   /*
2479    *	<subr prefix> ::= <prefix spec>
2480    */
2481   case SUBR_PREFIX2:
2482     check_module_prefix();
2483     if (sem.interface) {
2484       /* set curr_scope to parent's scope, so subprogram ID
2485        * gets scope of parent */
2486       stb.curr_scope = sem.scope_stack[sem.scope_level - 1].sptr;
2487     }
2488     break;
2489 
2490   /* ------------------------------------------------------------------ */
2491   /*
2492    *	<prefix spec> ::= <prefix spec> <prefix> |
2493    */
2494   case PREFIX_SPEC1:
2495     break;
2496   /*
2497    *	<prefix spec> ::= <prefix>
2498    */
2499   case PREFIX_SPEC2:
2500     break;
2501 
2502   /* ------------------------------------------------------------------ */
2503   /*
2504    *	<prefix> ::= RECURSIVE |
2505    */
2506   case PREFIX1:
2507     check_duplicate(subp_prefix.recursive, "RECURSIVE");
2508     subp_prefix.recursive = TRUE;
2509     if (subp_prefix.elemental) {
2510       errsev(460);
2511     }
2512     break;
2513   /*
2514    *	<prefix> ::= PURE |
2515    */
2516   case PREFIX2:
2517     check_duplicate(subp_prefix.pure, "PURE");
2518     subp_prefix.pure = TRUE;
2519     break;
2520   /*
2521    *	<prefix> ::= ELEMENTAL |
2522    */
2523   case PREFIX3:
2524     check_duplicate(subp_prefix.elemental, "ELEMENTAL");
2525     subp_prefix.elemental = TRUE;
2526     if (subp_prefix.recursive) {
2527       errsev(460);
2528     }
2529     break;
2530   /*
2531    *	<prefix> ::= ATTRIBUTES ( <id name list> )
2532    */
2533   case PREFIX4:
2534     if (!cuda_enabled("attributes"))
2535       break;
2536     break;
2537 
2538   /*
2539    *      <prefix> ::= IMPURE
2540    */
2541   case PREFIX5:
2542     check_duplicate(subp_prefix.impure, "IMPURE");
2543     subp_prefix.impure = TRUE;
2544     break;
2545 
2546   /*
2547    *      <prefix> ::= MODULE
2548    */
2549   case PREFIX6:
2550     check_duplicate(subp_prefix.module, "MODULE");
2551     subp_prefix.module = TRUE;
2552     break;
2553 
2554   /*
2555    *	<prefix> ::= LAUNCHBOUNDS ( <launchbound> ) |
2556    */
2557   case PREFIX7:
2558     break;
2559 
2560   /*
2561    *	<prefix> ::= LAUNCHBOUNDS ( <launchbound> , <launchbound> )
2562    */
2563   case PREFIX8:
2564     break;
2565 
2566 
2567   /* ------------------------------------------------------------------ */
2568   /*
2569    *	<launchbound> ::= <integer>
2570    */
2571   case LAUNCHBOUND1:
2572     break;
2573 
2574   /* ------------------------------------------------------------------ */
2575   /*
2576    *	<id name list> ::= <id name list> , <id name> |
2577    */
2578   case ID_NAME_LIST1:
2579     rhstop = 3;
2580     goto add_name_to_list;
2581     break;
2582   /*
2583    *	<id name list> ::= <id name>
2584    */
2585   case ID_NAME_LIST2:
2586     rhstop = 1;
2587   add_name_to_list:
2588     itemp = (ITEM *)getitem(0, sizeof(ITEM));
2589     itemp->next = ITEM_END;
2590     itemp->t.conval = SST_CVALG(RHS(rhstop));
2591     if (rhstop == 1)
2592       /* adding first item to list */
2593       SST_BEGP(LHS, itemp);
2594     else
2595       /* adding subsequent items to list */
2596       SST_ENDG(RHS(1))->next = itemp;
2597     SST_ENDP(LHS, itemp);
2598     break;
2599 
2600   /* ------------------------------------------------------------------ */
2601   /*
2602    *	<func prefix> ::= <data type> |
2603    */
2604   case FUNC_PREFIX1:
2605   /* fall through */
2606   /*
2607    *	<func prefix> ::= <data type> <prefix spec> |
2608    */
2609   case FUNC_PREFIX2:
2610   /* fall through */
2611   /*
2612    *	<func prefix> ::= <prefix spec> <data type>
2613    */
2614   case FUNC_PREFIX3:
2615   /* fall through */
2616   /*
2617    *	<func prefix> ::= <prefix spec> <data type> <prefix spec>
2618    */
2619   case FUNC_PREFIX4:
2620     check_module_prefix();
2621     if (sem.interface) {
2622       /* set curr_scope to parent's scope, so subprogram ID
2623        * gets scope of parent */
2624       stb.curr_scope = sem.scope_stack[sem.scope_level - 1].sptr;
2625     }
2626     break;
2627 
2628   /* ------------------------------------------------------------------ */
2629   /*
2630    *      <entry id> ::= ENTRY <id>
2631    */
2632   case ENTRY_ID1:
2633     sptr = SST_SYMG(RHS(2));
2634     if (gbl.internal > 1) {
2635       error(155, 3, gbl.lineno, SYMNAME(sptr),
2636             "- The ENTRY statement is not allowed in an internal procedure");
2637       SST_SYMP(LHS, 0);
2638       break;
2639     }
2640     if (sem.doif_depth > 0) {
2641       /* Inside DO, IF, WHERE block; ignore statement */
2642       errsev(118);
2643       SST_SYMP(LHS, 0);
2644       break;
2645     }
2646     if (INSIDE_STRUCT) {
2647       error(117, 3, gbl.lineno,
2648             STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
2649       SST_SYMP(LHS, 0);
2650       break;
2651     }
2652     if (gbl.rutype == RU_PROG || gbl.rutype == RU_BDATA || sem.interface) {
2653       errsev(70);
2654       SST_SYMP(LHS, 0);
2655       break;
2656     }
2657     if (gbl.rutype == RU_FUNC)
2658       /* have a function entry; create its ST_ENTRY symbol */
2659       sptr = create_func_entry(sptr);
2660     else
2661       sptr = declsym(sptr, ST_ENTRY, TRUE);
2662 
2663     if (IN_MODULE && sem.interface == 0)
2664       sptr = mod_add_subprogram(sptr);
2665     SST_SYMP(LHS, sptr);
2666 
2667     SYMLKP(sptr, SYMLKG(gbl.currsub));
2668     SYMLKP(gbl.currsub, sptr);
2669     FUNCLINEP(sptr, gbl.lineno);
2670     MSCALLP(sptr, mscall);
2671     if (sptr != gbl.currsub) {
2672       CFUNCP(sptr, CFUNCG(gbl.currsub));
2673     }
2674 #ifdef CREFP
2675     CREFP(sptr, cref);
2676     NOMIXEDSTRLENP(sptr, nomixedstrlen);
2677 #endif
2678     is_entry = TRUE;
2679     PUREP(sptr, PUREG(gbl.currsub));
2680     break;
2681 
2682   /* ------------------------------------------------------------------ */
2683   /*
2684    *      <fcn name> ::= <id> <opt len spec>
2685    */
2686   case FCN_NAME1:
2687     set_len_attributes(RHS(2), 1);
2688     break;
2689 
2690   /* ------------------------------------------------------------------ */
2691   /*
2692    *	<formal list> ::= <formal list> , <formal> |
2693    */
2694   case FORMAL_LIST1:
2695     rhstop = 3;
2696     goto add_sym_to_list;
2697   /*
2698    *	<formal list> ::= <formal>
2699    */
2700   case FORMAL_LIST2:
2701     rhstop = 1;
2702     goto add_sym_to_list;
2703 
2704   /* ------------------------------------------------------------------ */
2705   /*
2706    *	<formal> ::= <id> |
2707    */
2708   case FORMAL1:
2709     /* scan sets SST_SYMP with sym pointer */
2710     sptr = chk_intrinsic(SST_SYMG(RHS(1)), TRUE, is_entry);
2711     SST_SYMP(LHS, sptr);
2712     break;
2713   /*
2714    *	<formal> ::= *
2715    */
2716   case FORMAL2:
2717     SST_SYMP(LHS, 0);
2718     break;
2719 
2720   /* ------------------------------------------------------------------ */
2721   /*
2722    *	<ident list> ::= <ident list> , <ident> |
2723    */
2724   case IDENT_LIST1:
2725     rhstop = 3;
2726     goto add_sym_to_list;
2727   /*
2728    *	<ident list> ::= <ident>
2729    */
2730   case IDENT_LIST2:
2731     rhstop = 1;
2732   add_sym_to_list:
2733     itemp = (ITEM *)getitem(0, sizeof(ITEM));
2734     itemp->next = ITEM_END;
2735     itemp->t.sptr = SST_SYMG(RHS(rhstop));
2736     itemp->ast = SST_ASTG(RHS(rhstop)); /* copied for <access> rules */
2737     if (rhstop == 1)
2738       /* adding first item to list */
2739       SST_BEGP(LHS, itemp);
2740     else
2741       /* adding subsequent items to list */
2742       SST_ENDG(RHS(1))->next = itemp;
2743     SST_ENDP(LHS, itemp);
2744     break;
2745 
2746   /* ------------------------------------------------------------------ */
2747   /*
2748    *	<end stmt> ::= <END stmt>    |
2749    */
2750   case END_STMT1:
2751     if (gbl.rutype == RU_SUBR || gbl.rutype == RU_FUNC)
2752       defer_arg_chk(SPTR_NULL, SPTR_NULL, SPTR_NULL, 0, 0, true);
2753     if (sem.interface && !gbl.rutype)
2754         error(310, 3, gbl.lineno, "Missing ENDINTERFACE statement", CNULL);
2755     else if (sem.which_pass)
2756       fix_class_args(gbl.currsub);
2757 
2758     dummy_program();
2759     if (IN_MODULE_SPEC && gbl.internal == 0)
2760       goto end_of_module;
2761     if (gbl.currsub == 0 && sem.pgphase == PHASE_INIT && gbl.internal)
2762       check_end_subprogram(host_state.rutype, 0);
2763     else if (gbl.internal > 1) {
2764       if (gbl.rutype == RU_PROG || gbl.rutype == RU_BDATA) {
2765         error(302, 3, gbl.lineno, name_of_rutype(gbl.rutype), CNULL);
2766         gbl.internal = 0;
2767       }
2768     } else {
2769       if (0 && sem.which_pass && !sem.mod_cnt && gbl.internal == 0 &&
2770           !sem.interface) {
2771         fprintf(stderr, "OPROC %s:", gbl.src_file);
2772         fprintf(stderr, "%s\n", SYMNAME(gbl.currsub));
2773       }
2774       enforce_denorm();
2775     }
2776     SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2777     if (IN_MODULE && sem.interface == 0)
2778       mod_end_subprogram();
2779     pop_scope_level(SCOPE_NORMAL);
2780     if (!IN_MODULE && !sem.interface) {
2781       queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2782       check_defined_io();
2783     }
2784     defer_pt_decl(0, 0);
2785     break;
2786   /*
2787    *	<end stmt> ::= ENDBLOCKDATA  <opt ident> |
2788    */
2789   case END_STMT2:
2790     if (gbl.currsub == 0 || gbl.rutype != RU_BDATA)
2791       error(302, 3, gbl.lineno, "BLOCKDATA", CNULL);
2792     else if (SST_SYMG(RHS(2)) &&
2793              strcmp(SYMNAME(gbl.currsub), SYMNAME(SST_SYMG(RHS(2)))) != 0)
2794       error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL);
2795 
2796     SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2797     pop_scope_level(SCOPE_NORMAL);
2798     break;
2799   /*
2800    *	<end stmt> ::= ENDFUNCTION   <opt ident> |
2801    */
2802   case END_STMT3:
2803     defer_arg_chk(SPTR_NULL, SPTR_NULL, SPTR_NULL, 0, 0, true);
2804   submod_proc_endfunc:
2805     fix_iface(gbl.currsub);
2806     if (sem.which_pass && !sem.interface) {
2807       fix_class_args(gbl.currsub);
2808     }
2809     if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) {
2810       queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
2811       queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2812     }
2813     defer_pt_decl(0, 0);
2814     dummy_program();
2815     check_end_subprogram(RU_FUNC, SST_SYMG(RHS(2)));
2816 
2817     SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2818     pop_scope_level(SCOPE_NORMAL);
2819     if (sem.interface) {
2820       if (DTYPEG(gbl.currsub) == DT_ASSCHAR) {
2821         error(
2822             155, 3, FUNCLINEG(gbl.currsub),
2823             "FUNCTION may not be declared character*(*) when in an INTERFACE -",
2824             SYMNAME(gbl.currsub));
2825       }
2826       if (IN_MODULE) {
2827         do_iface_module();
2828       }
2829     }
2830     if (IN_MODULE && sem.interface == 0)
2831       mod_end_subprogram();
2832     check_defined_io();
2833     if (!IN_MODULE && !sem.interface)
2834       clear_ident_list();
2835     fix_proc_ptr_dummy_args();
2836     sem.seen_import = FALSE;
2837     break;
2838   /*
2839    *	<end stmt> ::= ENDMODULE     <opt ident> |
2840    */
2841   case END_STMT4:
2842     sem.seen_end_module = TRUE;
2843     if (sem.mod_sym == 0) {
2844       error(302, 3, gbl.lineno, "MODULE", CNULL);
2845       gbl.internal = 0;
2846       break;
2847     }
2848     if (sem.interface) {
2849       error(310, 3, gbl.lineno, "Missing ENDINTERFACE statement", CNULL);
2850       sem.interface = 0;
2851     }
2852     if (gbl.currsub) {
2853       error(310, 3, gbl.lineno, "Missing END statement", SYMNAME(gbl.currsub));
2854     }
2855     if (SST_SYMG(RHS(2)) &&
2856         strcmp(SYMNAME(sem.mod_sym), SYMNAME(SST_SYMG(RHS(2)))) != 0)
2857       error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL);
2858   end_of_module:
2859     queue_tbp(0, 0, 0, 0, TBP_COMPLETE_ENDMODULE);
2860     queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2861     do_iface(sem.which_pass);
2862     fix_iface0();
2863     end_module();
2864     SST_IDP(LHS, 0); /* mark as end of module */
2865     if (sem.mod_cnt == 1) {
2866       sem.mod_cnt++;
2867       /*fe_restart();*/
2868     } else {
2869       sem.mod_cnt = 0;
2870       sem.mod_sym = 0;
2871       sem.submod_sym = 0;
2872     }
2873     check_defined_io();
2874     clear_ident_list();
2875     sem.seen_end_module = FALSE;
2876     break;
2877   /*
2878    *	<end stmt> ::= ENDPROGRAM    <opt ident> |
2879    */
2880   case END_STMT5:
2881     queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
2882     queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2883     defer_pt_decl(0, 0);
2884     dummy_program();
2885     check_end_subprogram(RU_PROG, SST_SYMG(RHS(2)));
2886 
2887     SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2888     pop_scope_level(SCOPE_NORMAL);
2889     check_defined_io();
2890     break;
2891   /*
2892    *	<end stmt> ::= ENDSUBROUTINE <opt ident> |
2893    */
2894   case END_STMT6:
2895     defer_arg_chk(SPTR_NULL, SPTR_NULL, SPTR_NULL, 0, 0, true);
2896     fix_iface(gbl.currsub);
2897     if (sem.which_pass && !sem.interface) {
2898       fix_class_args(gbl.currsub);
2899     }
2900     if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) {
2901       queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
2902       queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2903     }
2904     defer_pt_decl(0, 0);
2905     dummy_program();
2906     check_end_subprogram(RU_SUBR, SST_SYMG(RHS(2)));
2907 
2908     SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2909     pop_scope_level(SCOPE_NORMAL);
2910     if (sem.interface && IN_MODULE) {
2911       do_iface_module();
2912     }
2913     if (IN_MODULE && sem.interface == 0)
2914       mod_end_subprogram();
2915     check_defined_io();
2916     if (!IN_MODULE && !sem.interface)
2917       clear_ident_list();
2918     fix_proc_ptr_dummy_args();
2919     sem.seen_import = FALSE;
2920     break;
2921   /*
2922    *	<end stmt> ::= ENDSUBMODULE <opt ident>
2923    */
2924   case END_STMT7:
2925     sem.seen_end_module = TRUE;
2926     if (sem.submod_sym <= NOSYM) {
2927       error(302, 3, gbl.lineno, "SUBMODULE", CNULL);
2928       gbl.internal = 0;
2929       break;
2930     }
2931     if (SST_SYMG(RHS(2)) &&
2932         strcmp(SYMNAME(sem.submod_sym), SYMNAME(SST_SYMG(RHS(2)))) != 0) {
2933       error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL);
2934     }
2935     goto end_of_module;
2936   /*
2937    *	<end stmt> ::= ENDPROCEDURE <opt ident>
2938    */
2939   case END_STMT8:
2940     if (gbl.currsub == 0 || !sem.module_procedure) {
2941       ERR310("unexpected END PROCEDURE", CNULL);
2942       break;
2943     }
2944     if (gbl.rutype == RU_FUNC)
2945        goto submod_proc_endfunc;
2946     /* For sub-module procedure points to a subroutine of another module,
2947        we need to take cares of the dummy arguments and process differently
2948        from the general ENDPROCEDURE.
2949      */
2950     if (gbl.rutype == RU_SUBR) {
2951       dummy_program();
2952       enforce_denorm();
2953       SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2954       pop_scope_level(SCOPE_SUBPROGRAM);
2955       defer_pt_decl(0, 0);
2956       sem.seen_import = FALSE;
2957       do_end_subprogram(top, gbl.rutype);
2958       break;
2959     }
2960     SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2961     mod_end_subprogram();
2962     sem.seen_import = FALSE;
2963     do_end_subprogram(top, gbl.rutype);
2964     gbl.currsub = 0;
2965     break;
2966 
2967   /* ------------------------------------------------------------------ */
2968   /*
2969    *	<opt ident> ::= |
2970    */
2971   case OPT_IDENT1:
2972     SST_SYMP(LHS, 0);
2973     break;
2974   /*
2975    *	<opt ident> ::= <ident>
2976    */
2977   case OPT_IDENT2:
2978     break;
2979 
2980   /* ------------------------------------------------------------------ */
2981   /*
2982    *      <declaration> ::= <data type> <optional comma> <pgm> <typdcl list> |
2983    */
2984   case DECLARATION1:
2985     if (sem.class && sem.type_mode) {
2986       error(155, 3, gbl.lineno, "CLASS components must be pointer or"
2987                                 " allocatable",
2988             CNULL);
2989     }
2990     SST_ASTP(LHS, 0);
2991     break;
2992   /*
2993    *      <declaration> ::= <dimkeyword> <opt attr> <pgm> <dcl id list>    |
2994    */
2995   case DECLARATION2:
2996     SST_ASTP(LHS, 0);
2997     break;
2998   /*
2999    *      <declaration> ::= <nis> IMPLICIT <pgm> <implicit type>   |
3000    */
3001   case DECLARATION3:
3002     SST_ASTP(LHS, 0);
3003     break;
3004   /*
3005    *      <declaration> ::= <nis> COMMON <pgm> <common list>   |
3006    */
3007   case DECLARATION4:
3008     SST_ASTP(LHS, 0);
3009     break;
3010   /*
3011    *      <declaration> ::= <nis> EXTERNAL <opt attr> <pgm> <ident list>      |
3012    */
3013   case DECLARATION5:
3014     for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
3015       /* Produce a procedure symbol */
3016       if (POINTERG(itemp->t.sptr)) {
3017         LOGICAL was_declared = DCLDG(itemp->t.sptr);
3018         /* External pointer should come out the same as procedure(T) pointer */
3019         sptr = decl_procedure_sym(itemp->t.sptr, proc_interf_sptr,
3020                                   (entity_attr.exist | ET_B(ET_POINTER)));
3021         sptr = setup_procedure_sym(itemp->t.sptr, proc_interf_sptr,
3022                                    (entity_attr.exist | ET_B(ET_POINTER)),
3023                                    entity_attr.access);
3024         DCLDP(sptr, was_declared);
3025       } else {
3026         /* Use simple approach when we can't argue that this needs to be a
3027          * procedure pointer */
3028         sptr = declsym(itemp->t.sptr, ST_PROC, FALSE);
3029       }
3030 
3031       if (!TYPDG(sptr)) {
3032         TYPDP(sptr, 1);
3033       }
3034       if (SCG(sptr) == SC_DUMMY) {
3035         IS_PROC_DUMMYP(sptr, 1);
3036       }
3037     }
3038     SST_ASTP(LHS, 0);
3039     break;
3040   /*
3041    *      <declaration> ::= <nis> INTRINSIC <opt attr> <pgm> <ident list>     |
3042    */
3043   case DECLARATION6:
3044     for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
3045       sptr = refsym(itemp->t.sptr, OC_OTHER);
3046       stype = STYPEG(sptr);
3047       if (!IS_INTRINSIC(sptr)) {
3048         /* Not an intrinsic. So, try finding it */
3049         sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_PD, 0);
3050         if (!sptr2) {
3051           sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_INTRIN, 0);
3052           if (!sptr2) {
3053             sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_GENERIC, 0);
3054           }
3055         }
3056         if (sptr2) {
3057           sptr = sptr2;
3058           stype = STYPEG(sptr);
3059           sptr2 = insert_sym(sptr);
3060           STYPEP(sptr2, ST_ALIAS);
3061           SYMLKP(sptr2, sptr);
3062         }
3063       }
3064       if (IS_INTRINSIC(stype)) {
3065         EXPSTP(sptr, 1); /* Freeze as an intrinsic */
3066         TYPDP(sptr, 1);  /* appeared in INTRINSIC statement */
3067         if (stype == ST_GENERIC) {
3068           sptr2 = select_gsame(sptr);
3069           if (sptr2)
3070             /* no need to
3071              * EXPSTP(sptr2, 1);
3072              * symbol is always begins with a .
3073              */
3074             ;
3075           else if (IN_MODULE) {
3076             /* Predefined symbols such as generics are
3077              * not exported into mod files.  A statement such as
3078              * use m, ren => max
3079              * will produce a "not public entity" message unless
3080              * we make a symbol that will be exported.
3081              */
3082             sptr2 = insert_sym(sptr);
3083             STYPEP(sptr2, ST_ALIAS);
3084             SYMLKP(sptr2, sptr);
3085           }
3086         }
3087       } else
3088         error(126, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3089     }
3090     SST_ASTP(LHS, 0);
3091     break;
3092   /*
3093    *      <declaration> ::= <iii> <nis> SAVE <opt attr> <save list> |
3094    */
3095   case DECLARATION7:
3096     SST_ASTP(LHS, 0);
3097     break;
3098   /*
3099    *      <declaration> ::= <iii> <nis> SAVE                       |
3100    */
3101   case DECLARATION8:
3102     sem.savall = TRUE;
3103     SST_ASTP(LHS, 0);
3104     break;
3105   /*
3106    *      <declaration> ::= PARAMETER <pgm> ( <ideqc list> ) |
3107    */
3108   case DECLARATION9:
3109     seen_parameter = TRUE;
3110     SST_ASTP(LHS, 0);
3111     if (sem.interface == 0)
3112       end_param();
3113     break;
3114   /*
3115    *      <declaration> ::= <nis> EQUIVALENCE <pgm> <equiv groups> |
3116    */
3117   case DECLARATION10:
3118     SST_ASTP(LHS, 0);
3119     break;
3120   /*
3121    *      <declaration> ::= <iii> <nis> DATA <dinit list>          |
3122    */
3123   case DECLARATION11:
3124     SST_ASTP(LHS, 0);
3125     break;
3126   /*
3127    *      <declaration> ::= PARAMETER  <pgm> <vxeqc list>    |
3128    */
3129   case DECLARATION12:
3130     if (flg.standard)
3131       error(171, 2, gbl.lineno, "PARAMETER", CNULL);
3132     seen_parameter = TRUE;
3133     SST_ASTP(LHS, 0);
3134     if (sem.interface == 0)
3135       end_param();
3136     break;
3137   /*
3138    *      <declaration> ::= <iii> <nis> NAMELIST <namelist groups> |
3139    */
3140   case DECLARATION13:
3141     SST_ASTP(LHS, 0);
3142     break;
3143   /*
3144    *      <declaration> ::= STRUCTURE <pgm> <struct begin1> <struct begin2> |
3145    */
3146   case DECLARATION14:
3147     if (flg.standard)
3148       error(171, 2, gbl.lineno, "STRUCTURE", CNULL);
3149     if (INSIDE_STRUCT && STSK_ENT(0).type != 's' && STSK_ENT(0).type != 'm') {
3150       error(70, 2, gbl.lineno, "(STRUCTURE ignored)", CNULL);
3151       break;
3152     }
3153     /* Get a structure stack entry */
3154     sem.stsk_depth++;
3155     NEED(sem.stsk_depth, sem.stsk_base, STSK, sem.stsk_size,
3156          sem.stsk_depth + 12);
3157     stsk = &STSK_ENT(0);
3158 
3159     dtype = sem.stag_dtype;
3160 
3161     /* Save structure information in structure stack */
3162     stsk->type = 's';
3163     stsk->mem_access = 0;
3164     stsk->dtype = dtype;
3165     stsk->sptr = SST_RNG2G(RHS(4)); /* sym ptr to field name list */
3166     stsk->last = NOSYM;
3167     stsk->ict_beg = stsk->ict_end = NULL;
3168 
3169     /* Handle the field-namelist field */
3170 
3171     sptr = stsk->sptr;
3172     if (sptr == NOSYM) {
3173       if (sem.stsk_depth != 1)
3174         error(137, 2, gbl.lineno, CNULL, CNULL);
3175     } else {
3176       if (sem.stsk_depth == 1) {
3177         error(136, 2, gbl.lineno, CNULL, CNULL);
3178       } else {
3179         /* link field-namelist into member list at this level */
3180         stsk = &STSK_ENT(1);
3181         link_members(stsk, sptr);
3182       }
3183     }
3184     SST_ASTP(LHS, 0);
3185     break;
3186   /*
3187    *      <declaration> ::= ENDSTRUCTURE               |
3188    */
3189   case DECLARATION15:
3190     if (flg.standard)
3191       error(171, 2, gbl.lineno, "ENDSTRUCTURE", CNULL);
3192     if (INSIDE_STRUCT) {
3193 
3194       /* Check out structure, get its length */
3195       stsk = &STSK_ENT(0);
3196       if (stsk->type != 's') {
3197         errsev(160);
3198         break;
3199       }
3200       dtype = stsk->dtype;
3201       sptr = stsk->sptr;
3202       chkstruct(dtype);
3203 
3204       /* Save initializer constant tree (ict) for this structure */
3205       if (sem.stsk_depth == 1 && stsk->ict_beg != NULL) {
3206         /* This is top structure, fix up top subc ict entry */
3207         ict = GET_ACL(15);
3208         ict->id = AC_VMSSTRUCT;
3209         ict->next = NULL;
3210         ict->subc = stsk->ict_beg;
3211         ict->u1.ast = 0;
3212         ict->repeatc = astb.i1;
3213         ict->sptr = 0;
3214         ict->dtype = dtype;
3215         stsk->ict_beg = ict;
3216       }
3217       DTY(dtype + 5) = put_getitem_p(stsk->ict_beg);
3218       if (DTY(dtype + 3))
3219         DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */
3220 
3221       /* Pop out to parent structure (if any) */
3222       sem.stsk_depth--;
3223       stsk = &STSK_ENT(0);
3224 
3225       /* For each member in parent structure (if any), having this
3226        * ict generate a substructure (subc) ict entry.  These are then
3227        * linked to the parent's ict.
3228        */
3229       if (INSIDE_STRUCT && DTY(dtype + 5) != 0) {
3230         for (; sptr != NOSYM; sptr = SYMLKG(sptr)) {
3231           ict = GET_ACL(15);
3232           ict->id = AC_VMSSTRUCT;
3233           ict->next = NULL;
3234           if (stsk->ict_end)
3235             stsk->ict_end->next = ict;
3236           else
3237             stsk->ict_beg = ict;
3238           stsk->ict_end = ict;
3239           ict->subc = get_getitem_p(DTY(dtype + 5));
3240           ict->u1.ast = 0;
3241           if (DTY(DTYPEG(sptr)) == TY_ARRAY)
3242             ict->repeatc = AD_NUMELM(AD_PTR(sptr));
3243           else
3244             ict->repeatc = astb.i1;
3245           ict->sptr = sptr;
3246           ict->dtype = dtype;
3247         }
3248       }
3249     } else
3250       error(70, 2, gbl.lineno, "(ENDSTRUCTURE ignored)", CNULL);
3251     SST_ASTP(LHS, 0);
3252     break;
3253   /*
3254    *      <declaration> ::= RECORD <pgm> <record list>
3255    */
3256   case DECLARATION16:
3257     if (flg.standard)
3258       error(171, 2, gbl.lineno, "RECORD", CNULL);
3259     break;
3260   /*
3261    *      <declaration> ::= UNION
3262    */
3263   case DECLARATION17:
3264     if (flg.standard)
3265       error(171, 2, gbl.lineno, "UNION", CNULL);
3266     if (!INSIDE_STRUCT) {
3267       error(70, 2, gbl.lineno, "(UNION ignored)", CNULL);
3268       break;
3269     }
3270     stsk = &STSK_ENT(0);
3271     if (stsk->type != 's' && stsk->type != 'm') {
3272       error(70, 2, gbl.lineno, "(UNION ignored)", CNULL);
3273       break;
3274     }
3275     dtype = get_type(6, TY_UNION, NOSYM);
3276     name_prefix_char = 'u';
3277     goto union_map;
3278   /*
3279    *      <declaration> ::= ENDUNION
3280    */
3281   case DECLARATION18:
3282     if (flg.standard)
3283       error(171, 2, gbl.lineno, "ENDUNION", CNULL);
3284     if (!INSIDE_STRUCT) {
3285       error(70, 2, gbl.lineno, "(ENDUNION ignored)", CNULL);
3286       break;
3287     }
3288     stsk = &STSK_ENT(0);
3289     if (stsk->type != 'u') {
3290       errsev(160);
3291       break;
3292     }
3293     dtype = stsk->dtype;
3294     sptr = stsk->sptr;
3295     chkstruct(dtype);
3296     STSK_ENT(1).last = stsk->last;
3297     DTY(dtype + 5) = put_getitem_p(stsk->ict_beg);
3298     if (stsk->ict_beg != NULL) {
3299       STSK *pstsk = &STSK_ENT(1); /* parent (a struct) of the union */
3300 #if DEBUG
3301       assert(pstsk->type == 's', "ENDUNION:union not in struct", sptr, 3);
3302 #endif
3303       /*
3304        * create a set node of the union which contains all of the
3305        * initializers for the union's maps.  This set node is added
3306        * to the structure stack of the union's parent (a structure).
3307        */
3308       ict = GET_ACL(15);
3309       ict->id = AC_VMSUNION;
3310       ict->next = NULL;
3311       ict->subc = stsk->ict_beg;
3312       ict->u1.ast = 0;
3313       ict->repeatc = astb.i1;
3314       ict->sptr = sptr;
3315       ict->dtype = dtype;
3316       if (pstsk->ict_beg == NULL)
3317         pstsk->ict_beg = ict;
3318       else
3319         pstsk->ict_end->next = ict;
3320       pstsk->ict_end = ict;
3321     }
3322     sem.stsk_depth--;
3323     SST_ASTP(LHS, 0);
3324     break;
3325   /*
3326    *      <declaration> ::= MAP
3327    */
3328   case DECLARATION19:
3329     if (flg.standard)
3330       error(171, 2, gbl.lineno, "MAP", CNULL);
3331     if (!INSIDE_STRUCT) {
3332       error(70, 2, gbl.lineno, "(MAP ignored)", CNULL);
3333       break;
3334     }
3335     stsk = &STSK_ENT(0);
3336     if (stsk->type != 'u') {
3337       error(70, 2, gbl.lineno, "(MAP ignored)", CNULL);
3338       break;
3339     }
3340     dtype = get_type(6, TY_STRUCT, NOSYM);
3341     name_prefix_char = 'm';
3342   union_map:
3343     stype = ST_MEMBER;
3344     sptr =
3345         declref(getsymf("%c@%05ld", name_prefix_char, (long)dtype), stype, 'r');
3346 #if DEBUG
3347     assert(STYPEG(sptr) == stype,
3348            scn.stmtyp == TK_UNION ? "UNION: bad stype" : "MAP: bad stype", sptr,
3349            3);
3350 #endif
3351     CCSYMP(sptr, 1);
3352     SYMLKP(sptr, NOSYM);
3353     DTYPEP(sptr, dtype); /* must be done before link members */
3354     DTY(dtype + 3) = 0;  /* no tag */
3355     /* link the union or map (structure) into the current structure */
3356     link_members(stsk, sptr);
3357 
3358     /* Save union information in structure stack */
3359     sem.stsk_depth++;
3360     NEED(sem.stsk_depth, sem.stsk_base, STSK, sem.stsk_size,
3361          sem.stsk_depth + 12);
3362     stsk = &STSK_ENT(0);
3363     stsk->type = scn.stmtyp == TK_UNION ? 'u' : 'm';
3364     stsk->mem_access = 0;
3365     stsk->dtype = dtype;
3366     stsk->sptr = sptr; /* sym ptr union */
3367     stsk->last = STSK_ENT(1).last;
3368     stsk->ict_beg = stsk->ict_end = NULL;
3369     SST_ASTP(LHS, 0);
3370     break;
3371   /*
3372    *      <declaration> ::= ENDMAP |
3373    */
3374   case DECLARATION20:
3375     if (flg.standard)
3376       error(171, 2, gbl.lineno, "ENDMAP", CNULL);
3377     if (!INSIDE_STRUCT) {
3378       error(70, 2, gbl.lineno, "(ENDMAP ignored)", CNULL);
3379       break;
3380     }
3381     stsk = &STSK_ENT(0);
3382     if (stsk->type != 'm') {
3383       errsev(160);
3384       break;
3385     }
3386     dtype = stsk->dtype;
3387     sptr = stsk->sptr;
3388     chkstruct(dtype);
3389     STSK_ENT(1).last = stsk->last;
3390     DTY(dtype + 5) = put_getitem_p(stsk->ict_beg);
3391     if (stsk->ict_beg != NULL) {
3392       STSK *pstsk = &STSK_ENT(1); /* parent (a union) of the map */
3393 #if DEBUG
3394       assert(pstsk->type == 'u', "ENDMAP: map not in union", sptr, 3);
3395 #endif
3396       /*
3397        * add the map's initializer trees to the union's (its parent)
3398        * structure stack.
3399        */
3400       if (pstsk->ict_beg == NULL)
3401         pstsk->ict_beg = stsk->ict_beg;
3402       else
3403         pstsk->ict_end->next = stsk->ict_beg;
3404       pstsk->ict_end = stsk->ict_end;
3405     }
3406     sem.stsk_depth--;
3407     SST_ASTP(LHS, 0);
3408     break;
3409   /*
3410    *      <declaration> ::= TYPE <opt type spec> <opt attr> <pgm> <id> <opt
3411    * tpsl> |
3412    */
3413   case DECLARATION21:
3414     sptr = SST_SYMG(RHS(5));
3415     np = SYMNAME(sptr);
3416     if (strcmp(np, "integer") == 0 || strcmp(np, "logical") == 0 ||
3417         strcmp(np, "real") == 0 || strcmp(np, "doubleprecision") == 0 ||
3418         strcmp(np, "complex") == 0 || strcmp(np, "character") == 0) {
3419       error(155, 3, gbl.lineno, "A derived type type-name must not be the same "
3420                                 "as the name of the intrinsic type",
3421             np);
3422       if (IS_INTRINSIC(STYPEG(sptr)))
3423         sptr = insert_sym(sptr);
3424     } else
3425       sptr = getocsym(sptr, OC_OTHER, TRUE);
3426     if (STYPEG(sptr) == ST_TYPEDEF && DTY(DTYPEG(sptr) + 2) == 0) {
3427       /* This declaration will fill in an empty TYPEDEF created in
3428        * an implicit statement.
3429        */
3430       dtype = sem.stag_dtype = DTYPEG(sptr);
3431       DTY(sem.stag_dtype + 2) = 1; /* size */
3432     } else {
3433       if (STYPEG(sptr) == ST_USERGENERIC) {
3434         int origSym = sptr;
3435         sptr = insert_sym(sptr);
3436         STYPEP(sptr, ST_TYPEDEF);
3437         GTYPEP(origSym, sptr);
3438       } else {
3439         sptr = declsym(sptr, ST_TYPEDEF, TRUE);
3440       }
3441       dtype = sem.stag_dtype = get_type(6, TY_DERIVED, NOSYM);
3442       DTYPEP(sptr, sem.stag_dtype);
3443       DTY(sem.stag_dtype + 2) = 1; /* size */
3444       DTY(sem.stag_dtype + 3) = sptr;
3445       DTY(sem.stag_dtype + 5) = 0;
3446     }
3447 #if defined(PARENTP)
3448     if (SST_CVALG(RHS(2)) & 0x4) {
3449       int sym = SST_LSYMG(RHS(2));
3450       int dtype2 = DTYPEG(sym);
3451       /* type extension */
3452       if (CFUNCG(sym)) {
3453         error(155, 3, gbl.lineno, "Cannot EXTEND BIND(C) derived type",
3454               SYMNAME(sym));
3455       } else if (DTY(dtype2) == TY_DERIVED && SEQG(DTY(dtype2 + 3))) {
3456         error(155, 3, gbl.lineno, "Cannot EXTEND SEQUENCE derived type",
3457               SYMNAME(sym));
3458       } else if (SST_CVALG(RHS(2)) & 0x1) {
3459         error(155, 3, gbl.lineno, "EXTENDS may not be used with BIND(C) "
3460                                   "derived type",
3461               SYMNAME(sym));
3462       }
3463       PARENTP(sptr, sym);
3464     } else {
3465       /* type extension */
3466       PARENTP(sptr, 0);
3467     }
3468     if (SST_CVALG(RHS(2)) & 0x8) {
3469       /* abstract type */
3470       ABSTRACTP(sptr, 1);
3471     }
3472 #endif
3473     if (SST_CVALG(RHS(2)) & 0x1)
3474       /* BIND present? */
3475       CFUNCP(sptr, 1);
3476     if (entity_attr.access == 'v') {
3477       /* we can set the private bit immediately here,
3478        * since it doesn't get overwritten later */
3479       PRIVATEP(sptr, 1);
3480     } else if (entity_attr.access == 'u') {
3481       /* if the default access mode for the module is private,
3482        * the private bit gets overwritten in semfin.do_access()
3483        * We need to remember to reset this to public */
3484       accessp = (ACCL *)getitem(3, sizeof(ACCL));
3485       accessp->sptr = sptr;
3486       accessp->type = entity_attr.access;
3487       accessp->oper = ' ';
3488       accessp->next = sem.accl.next;
3489       sem.accl.next = accessp;
3490     }
3491 
3492     if (INSIDE_STRUCT)
3493       error(117, 3, gbl.lineno,
3494             STSK_ENT(0).type == 'd' ? "derived type" : "STRUCTURE", CNULL);
3495 
3496     /* Get a structure stack entry */
3497     sem.stsk_depth++;
3498     NEED(sem.stsk_depth, sem.stsk_base, STSK, sem.stsk_size,
3499          sem.stsk_depth + 12);
3500     stsk = &STSK_ENT(0);
3501     /* Save structure information in structure stack */
3502     stsk->type = 'd';
3503     stsk->mem_access = 0;
3504     stsk->dtype = dtype;
3505     stsk->sptr = sptr;
3506     stsk->last = NOSYM;
3507     stsk->ict_beg = stsk->ict_end = NULL;
3508     sem.type_mode = 1;
3509     SST_ASTP(LHS, 0);
3510     link_parents(stsk, PARENTG(sptr));
3511     break;
3512   /*
3513    *      <declaration> ::= ENDTYPE <opt ident> |
3514    */
3515   case DECLARATION22:
3516     if (INSIDE_STRUCT) {
3517       /* Check out structure, get its length */
3518       stsk = &STSK_ENT(0);
3519       if (stsk->type != 'd') {
3520         errsev(160);
3521         break;
3522       }
3523       dtype = stsk->dtype;
3524       sptr = stsk->sptr;
3525       chkstruct(dtype);
3526       if (dtype && SST_SYMG(RHS(2)) && DTY(dtype + 3) &&
3527           strcmp(SYMNAME(DTY(dtype + 3)), SYMNAME(SST_SYMG(RHS(2)))) != 0) {
3528         error(155, 3, gbl.lineno, "Name on END TYPE statement does not"
3529                                   " match name on corresponding TYPE statement",
3530               CNULL);
3531       }
3532       if (PARENTG(DTY(dtype + 1)) && DINITG(DTY(dtype + 1))) {
3533         /* Type extension - make sure we initialize any parent components
3534          * that require initialization.
3535          */
3536         build_typedef_init_tree(DTY(dtype + 1), DDTG(DTYPEG(DTY(dtype + 1))));
3537       }
3538       if (ALLOCFLDG(sptr)) {
3539         init_allocatable_typedef_components(sptr);
3540       }
3541       save_typedef_init(sptr, dtype);
3542       build_typedef_init_tree(sptr, dtype);
3543 
3544       queue_type_param(0, dtype, 0, 2);
3545       put_default_kind_type_param(dtype, 0, 1);
3546       queue_type_param(0, 0, 0, 0);
3547 
3548       queue_tbp(sptr, 0, 0, dtype, TBP_INHERIT);
3549       queue_tbp(sptr, 0, 0, dtype, TBP_ADD_TO_DTYPE);
3550       if (!IN_MODULE)
3551         queue_tbp(0, 0, 0, 0, TBP_COMPLETE_ENDTYPE);
3552       /* Call get_static_type_descriptor() to ensure creation of type
3553        * descriptor at its definition point. This is especially important
3554        * for derived types defined in a subprogram and referenced in a
3555        * contains subprogram.
3556        */
3557       if (gbl.internal <= 1)
3558         get_static_type_descriptor(sptr);
3559       if (0 && size_of(dtype) == 0 && DTY(dtype + 1) <= NOSYM) {
3560         int mem, oldsptr, tag;
3561         tag = DTY(DTYPEG(sptr) + 3);
3562         if (!UNLPOLYG(tag)) {
3563           /* Create "empty" typedef. */
3564           oldsptr = sptr;
3565           get_static_type_descriptor(sptr);
3566           sptr = insert_sym(sptr);
3567           sptr = declsym(sptr, ST_TYPEDEF, TRUE);
3568           dtype = get_type(6, TY_DERIVED, NOSYM);
3569           DTYPEP(sptr, dtype);
3570           DTY(dtype + 1) = NOSYM;
3571           DTY(dtype + 2) = 0; /* will be filled in */
3572           DTY(dtype + 3) = sptr;
3573           DTY(dtype + 5) = 0;
3574           SDSCP(sptr, SDSCG(oldsptr));
3575           DCLDP(sptr, DCLDG(oldsptr));
3576           chkstruct(dtype);
3577         }
3578       }
3579       chk_initialization_with_kind_parm(dtype);
3580     } else
3581       error(70, 2, gbl.lineno, "(END TYPE ignored)", CNULL);
3582     sem.type_mode = 0;
3583     sem.tbp_access_stmt = 0;
3584     entity_attr.access = ' '; /* Reset access spec of types */
3585     SST_ASTP(LHS, 0);
3586     break;
3587   /*
3588    *      <declaration> ::= VOLATILE <opt attr> <pgm> <vol list> |
3589    */
3590   case DECLARATION23:
3591     SST_ASTP(LHS, 0);
3592     break;
3593   /*
3594    *      <declaration> ::= <nis> POINTER <opt attr> <pgm> <ptr list>
3595    */
3596   case DECLARATION24:
3597     SST_ASTP(LHS, 0);
3598     break;
3599   /*
3600    *      <declaration> ::= <nis> ALLOCATABLE <opt attr> <pgm> <alloc id list>
3601    */
3602   case DECLARATION25:
3603     SST_ASTP(LHS, 0);
3604     break;
3605   /*
3606    *	<declaration> ::= <data type> <opt attr list> :: <pgm> <entity decl
3607    *list> |
3608    */
3609   case DECLARATION26:
3610     if (entity_attr.exist & ET_B(ET_PARAMETER)) {
3611       seen_parameter = TRUE;
3612       if (sem.interface == 0)
3613         end_param();
3614     }
3615     SST_ASTP(LHS, 0);
3616     in_entity_typdcl = FALSE;
3617     entity_attr.exist = 0;
3618     entity_attr.access = ' ';
3619     bind_attr.exist = -1;
3620     bind_attr.altname = 0;
3621     break;
3622   /*
3623    *	<declaration> ::= <intent> <opt attr> <pgm> <ident list> |
3624    */
3625   case DECLARATION27:
3626     count = 0;
3627     for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3628       sptr = refsym(itemp->t.sptr, OC_OTHER);
3629       INTENTP(sptr, entity_attr.intent);
3630       if (sem.interface) {
3631         if (SCG(sptr) != SC_DUMMY)
3632           error(134, 3, gbl.lineno, "- intent specified for nondummy argument",
3633                 SYMNAME(sptr));
3634       } else {
3635         /* defer checking of storage class until semfin */
3636         itemp1 = (ITEM *)getitem(3, sizeof(ITEM));
3637         itemp1->next = sem.intent_list;
3638         sem.intent_list = itemp1;
3639         itemp1->t.sptr = sptr;
3640         itemp1->ast = gbl.lineno;
3641       }
3642       if (bind_attr.altname && (++count > 1))
3643         error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
3644       if (bind_attr.exist != -1) {
3645         process_bind(sptr);
3646       }
3647     }
3648     bind_attr.exist = -1;
3649     bind_attr.altname = 0;
3650     SST_ASTP(LHS, 0);
3651     break;
3652   /*
3653    *	<declaration> ::= <access spec> <opt attr> <pgm> <access list> |
3654    */
3655   case DECLARATION28:
3656     count = 0;
3657     for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3658       sptr1 = sptr = itemp->t.sptr;
3659       if (STYPEG(sptr) != ST_OPERATOR && STYPEG(sptr) != ST_USERGENERIC)
3660         sptr = refsym(sptr, OC_OTHER);
3661       if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr))
3662         error(84, 3, gbl.lineno, SYMNAME(sptr),
3663               "- must not be an automatic array");
3664       else {
3665         accessp = (ACCL *)getitem(3, sizeof(ACCL));
3666         accessp->sptr = sptr1;
3667         accessp->type = entity_attr.access;
3668         accessp->next = sem.accl.next;
3669         accessp->oper = ' ';
3670         if (itemp->ast == 1)
3671           accessp->oper = 'o';
3672         sem.accl.next = accessp;
3673       }
3674       if (bind_attr.altname && (++count > 1))
3675         error(84, 3, gbl.lineno, SYMNAME(bind_attr.altname),
3676               "- too many variables bound to name");
3677       if (bind_attr.exist != -1) {
3678         if (!IN_MODULE)
3679           error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
3680         process_bind(sptr);
3681       }
3682     }
3683     entity_attr.access = ' ';
3684     bind_attr.exist = -1;
3685     bind_attr.altname = 0;
3686     SST_ASTP(LHS, 0);
3687     break;
3688   /*
3689    *	<declaration> ::= OPTIONAL <opt attr> <pgm> <ident list> |
3690    */
3691   case DECLARATION29:
3692     for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3693       sptr = refsym(itemp->t.sptr, OC_OTHER);
3694       OPTARGP(sptr, 1);
3695     }
3696     SST_ASTP(LHS, 0);
3697     break;
3698   /*
3699    *	<declaration> ::= TARGET <opt attr> <pgm> <target list> |
3700    */
3701   case DECLARATION30:
3702     SST_ASTP(LHS, 0);
3703     break;
3704   /*
3705    *	<declaration> ::= <nis> <interface> |
3706    */
3707   case DECLARATION31:
3708     SST_ASTP(LHS, 0);
3709     break;
3710   /*
3711    *	<declaration> ::= <nis> <end interface> |
3712    */
3713   case DECLARATION32:
3714     SST_ASTP(LHS, 0);
3715     break;
3716   /*
3717    *	<declaration> ::= <nis> <pgm> USE <use>
3718    */
3719   case DECLARATION33:
3720     close_module();
3721     SST_ASTP(LHS, 0);
3722     break;
3723   /*
3724    *	<declaration> ::= <access spec> |
3725    */
3726   case DECLARATION34:
3727     if (INSIDE_STRUCT) {
3728       if (STSK_ENT(0).type != 'd') {
3729         error(155, 3, gbl.lineno,
3730               "PUBLIC/PRIVATE may only be used in derived types", "");
3731         break;
3732       }
3733       if (entity_attr.access == 'u') {
3734         ERR310("PUBLIC may not appear in a derived type definition", CNULL);
3735       } else {
3736         stsk = &STSK_ENT(0);
3737         sptr = DTY(stsk->dtype + 3); /* tag sptr */
3738         if (stsk->last != NOSYM) {
3739           if (sem.type_mode == 2 && IN_MODULE_SPEC) {
3740             if (queue_tbp(0, 0, 0, stsk->dtype, TBP_STATUS)) {
3741               error(155, 3, gbl.lineno,
3742                     "Incorrect sequence of PRIVATE and type bound "
3743                     "procedures in",
3744                     SYMNAME(sptr));
3745             }
3746             if (sem.tbp_access_stmt) {
3747               error(155, 3, gbl.lineno,
3748                     "Redundant PRIVATE statement in type bound "
3749                     "procedure section of",
3750                     SYMNAME(sptr));
3751             } else {
3752               sem.tbp_access_stmt = 1;
3753             }
3754           } else if (!PARENTG(stsk->last) || PARENTG(stsk->last) != stsk->last)
3755             /* error - private statement appears after member */
3756             error(155, 3, gbl.lineno, "PRIVATE statement must appear before "
3757                                       "components of derived type",
3758                   SYMNAME(sptr));
3759         } else {
3760           if (sem.type_mode == 2 && IN_MODULE_SPEC) {
3761             if (sem.tbp_access_stmt) {
3762               error(155, 3, gbl.lineno,
3763                     "Redundant PRIVATE statement in type bound "
3764                     "procedure section of",
3765                     SYMNAME(sptr));
3766             } else {
3767               sem.tbp_access_stmt = 1;
3768             }
3769           } else
3770           if (stsk->mem_access) {
3771             error(155, 3, gbl.lineno,
3772                   "Redundant PRIVATE statement in derived type", SYMNAME(sptr));
3773           }
3774           /* set PUBLIC/PRIVATE here.  link_members() will apply it to
3775              the components of this derived type. */
3776           stsk->mem_access = entity_attr.access;
3777         }
3778       }
3779     } else { /* not INSIDE_STRUCT */
3780       if (sem.accl.type) {
3781         if (sem.accl.type == entity_attr.access)
3782           error(155, 2, gbl.lineno, "Redundant PUBLIC/PRIVATE statement",
3783                 CNULL);
3784         else
3785           error(155, 3, gbl.lineno, "Conflicting PUBLIC/PRIVATE statement",
3786                 CNULL);
3787       } else
3788         sem.accl.type = entity_attr.access;
3789     }
3790     SST_ASTP(LHS, 0);
3791     break;
3792 
3793   /*
3794    *	<declaration> ::= <procedure stmt> |
3795    */
3796   case DECLARATION35:
3797     SST_ASTP(LHS, 0);
3798     break;
3799   /*
3800    *	<declaration> ::= <mp threadprivate> ( <tp list> ) |
3801    */
3802   case DECLARATION36:
3803     for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) {
3804       sptr = itemp->t.sptr; /* ST_CMBLK */
3805       if (sptr == 0)
3806         continue;
3807       THREADP(sptr, 1);
3808 
3809       if (STYPEG(sptr) != ST_CMBLK && !DCLDG(sptr) && !SAVEG(sptr) &&
3810           !sem.savall) {
3811         error(38, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3812       } else if (STYPEG(sptr) != ST_CMBLK && ALLOCATTRG(sptr)) {
3813         get_static_descriptor(sptr);
3814         get_all_descriptors(sptr);
3815       }
3816     }
3817     SST_ASTP(LHS, 0);
3818     break;
3819   /*
3820    *	<declaration> ::= <dec declaration>
3821    */
3822   case DECLARATION37:
3823     SST_ASTP(LHS, 0);
3824     break;
3825   /*
3826    *	<declaration> ::= <pragma declaration> |
3827    */
3828   case DECLARATION38:
3829     SST_ASTP(LHS, 0);
3830     break;
3831   /*
3832    *	<declaration> ::= <nis> AUTOMATIC <opt attr> <pgm> <ident list>     |
3833    */
3834   case DECLARATION39:
3835     uf("AUTOMATIC");
3836     break;
3837   /*
3838    *	<declaration> ::= <nis> STATIC <opt attr> <pgm> <ident list>
3839    */
3840   case DECLARATION40:
3841     uf("STATIC");
3842     break;
3843   /*
3844    *      <declaration> ::= BIND <bind attr> <opt attr> <bind list> |
3845    */
3846   case DECLARATION41: {
3847     int ii;
3848     ii = 1;
3849     count = 0;
3850     /* go through ths bind list and call process_bind for each */
3851     if (bind_attr.exist != -1) {
3852       for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3853         if (bind_attr.altname && (++count > 1))
3854           error(84, 3, gbl.lineno, SYMNAME(bind_attr.altname),
3855                 "- too many variables bound to name");
3856         if (!IN_MODULE)
3857           error(84, 2, gbl.lineno, "BIND: allowed only in module", 0);
3858         process_bind(itemp->t.sptr);
3859       }
3860       bind_attr.exist = -1;
3861       bind_attr.altname = 0;
3862     }
3863   }
3864     SST_ASTP(LHS, 0);
3865     break;
3866   /*
3867    *	<declaration> ::= <nis> <pgm> <import> <opt import> |
3868    */
3869   case DECLARATION42:
3870     SST_ASTP(LHS, 0);
3871     break;
3872   /*
3873    *	<declaration> ::= <nis> <pgm> ENUM , BIND ( <id name> ) |
3874    */
3875   case DECLARATION43:
3876     np = scn.id.name + SST_CVALG(RHS(7));
3877     if (sem_strcmp(np, "c") == 0) {
3878       sem.in_enum = TRUE;
3879     } else
3880       error(4, 3, gbl.lineno, "Illegal BIND -", np);
3881     next_enum = 0;
3882     SST_ASTP(LHS, 0);
3883     break;
3884   /*
3885    *	<declaration> ::= <nis> ENUMERATOR <opt attr> <enums> |
3886    */
3887   case DECLARATION44:
3888     SST_ASTP(LHS, 0);
3889     break;
3890   /*
3891    *	<declaration> ::= <nis> ENDENUM |
3892    */
3893   case DECLARATION45:
3894     sem.in_enum = FALSE;
3895     SST_ASTP(LHS, 0);
3896     break;
3897   /*
3898    *	<declaration> ::= <procedure declaration> |
3899    */
3900   case DECLARATION46:
3901     SST_ASTP(LHS, 0);
3902     break;
3903   /*
3904    *	<declaration> ::= <type bound procedure> |
3905    */
3906   case DECLARATION47:
3907     SST_ASTP(LHS, 0);
3908     break;
3909   /*
3910    *	<declaration> ::= ATTRIBUTES ( <id name list> ) <opt attr> <pgm> <ident
3911    *list> |
3912    */
3913   case DECLARATION48:
3914     if (!cuda_enabled("attributes")) {
3915       SST_ASTP(LHS, 0);
3916       break;
3917     }
3918     SST_ASTP(LHS, 0);
3919     break;
3920   /*
3921    *	<declaration> ::= TCONTAINS |
3922    */
3923   case DECLARATION49:
3924     dtype = stsk->dtype;
3925     if (DTY(dtype) == TY_DERIVED) {
3926       int tag = DTY(dtype + 3);
3927       if (SEQG(tag)) {
3928         error(155, 3, gbl.lineno, "Type bound procedure part not allowed "
3929                                   "for SEQUENCE type",
3930               SYMNAME(tag));
3931       }
3932       if (CFUNCG(tag)) {
3933         error(155, 3, gbl.lineno, "Type bound procedure part not allowed "
3934                                   "for BIND(C) type",
3935               SYMNAME(tag));
3936       }
3937     }
3938     sem.type_mode = 2;
3939     SST_ASTP(LHS, 0);
3940     break;
3941   /*
3942    *	<declaration> ::= <nis> PROTECTED <opt attr> <pgm> <ident list>
3943    */
3944   case DECLARATION50:
3945     if (!IN_MODULE_SPEC) {
3946       error(155, 3, gbl.lineno,
3947             "PROTECTED may only appear in the specification part of a MODULE",
3948             CNULL);
3949     }
3950     for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
3951       sptr = ref_ident_inscope(itemp->t.sptr);
3952       PROTECTEDP(sptr, 1);
3953     }
3954     SST_ASTP(LHS, 0);
3955     break;
3956   /*
3957    *	<declaration> ::= <nis> ASYNCHRONOUS <opt attr> <pgm> <ident list>
3958    */
3959   case DECLARATION51:
3960     for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
3961       sptr = ref_ident_inscope(itemp->t.sptr);
3962       ASYNCP(sptr, 1);
3963     }
3964     SST_ASTP(LHS, 0);
3965     break;
3966 
3967   /*
3968    *	<declaration> ::= <nis> <accel decl begin> ACCDECL <accel decl list>
3969    */
3970   case DECLARATION52:
3971     SST_ASTP(LHS, 0);
3972     break;
3973   /*
3974    *	<declaration> ::= <nis> <accel decl begin> DECLARE <accel decl list> |
3975    */
3976   case DECLARATION53:
3977     SST_ASTP(LHS, 0);
3978     break;
3979   /*
3980    *      <declaration> ::= <generic type procedure> |
3981    */
3982   case DECLARATION54:
3983     break;
3984   /*
3985    *	<declaration> ::= <final subroutines> |
3986    */
3987   case DECLARATION55:
3988     break;
3989   /*
3990    *	<declaration> ::= <nis> CONTIGUOUS <opt attr> <pgm> <ident list>
3991    */
3992   case DECLARATION56:
3993     break;
3994   /*
3995    *	<declaration> ::= <nis> <accel decl begin> ROUTINE <accel routine list>
3996    */
3997   case DECLARATION57:
3998     SST_ASTP(LHS, 0);
3999     break;
4000   /*
4001    *	<declaration> ::= <nis> <accel decl begin> ROUTINE
4002    *           ( <routine id list> ) <accel routine list> |
4003    */
4004   case DECLARATION58:
4005     SST_ASTP(LHS, 0);
4006     break;
4007   /*
4008    *	<declaration> ::= <seq> <pgm> |
4009    */
4010   case DECLARATION59:
4011     if (INSIDE_STRUCT && STSK_ENT(0).type == 'd' && SST_CVALG(RHS(1)) == 's') {
4012       stsk = &STSK_ENT(0);
4013       sptr = DTY(stsk->dtype + 3); /* tag sptr */
4014       if (stsk->last != NOSYM) {
4015         /* error - SEQUENCE statement appears after member */
4016         error(
4017             155, 3, gbl.lineno,
4018             "SEQUENCE statement must appear before components of derived type",
4019             SYMNAME(sptr));
4020       } else {
4021         if (SEQG(sptr)) {
4022           error(155, 3, gbl.lineno,
4023                 "Redundant SEQUENCE statement in derived type", SYMNAME(sptr));
4024         }
4025         SEQP(sptr, 1); /* set SEQ on the tag of derived type */
4026         if (PARENTG(sptr)) {
4027           error(155, 3, gbl.lineno,
4028                 "SEQUENCE may not appear in a derived type with "
4029                 "EXTENDS keyword",
4030                 CNULL);
4031         }
4032       }
4033     }
4034     SST_ASTP(LHS, 0);
4035     break;
4036   /*
4037    *	<declaration> ::= <nis> <mp decl begin> <mp decl> |
4038    */
4039   case DECLARATION60:
4040     break;
4041   /*
4042    *	<declaration> ::= <nis> VALUE <opt attr> <pgm> <ident list>
4043    */
4044   case DECLARATION61:
4045     for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
4046       sptr = ref_ident_inscope(itemp->t.sptr);
4047       PASSBYVALP(sptr, 1);
4048       PASSBYREFP(sptr, 0);
4049     }
4050     SST_ASTP(LHS, 0);
4051     break;
4052   /*
4053    *	<declaration> ::= <accel begin> <accel dp stmts>
4054    */
4055   case DECLARATION62:
4056     break;
4057 
4058   /* ------------------------------------------------------------------ */
4059   /*
4060    *	<accel dp stmts> ::= <accel shape declstmt> |
4061    */
4062   case ACCEL_DP_STMTS1:
4063     break;
4064   /*
4065    *	<accel dp stmts> ::= <accel policy declstmt>
4066    */
4067   case ACCEL_DP_STMTS2:
4068     break;
4069 
4070   /* ------------------------------------------------------------------ */
4071   /*
4072    *	<accel shape declstmt> ::= ACCSHAPE <accel shape dir>
4073    */
4074   case ACCEL_SHAPE_DECLSTMT1:
4075     break;
4076 
4077   /* ------------------------------------------------------------------ */
4078   /*
4079    *	<accel shape dir> ::= ( <accel dpvarlist> ) |
4080    */
4081   case ACCEL_SHAPE_DIR1:
4082   /*
4083    *	<accel shape dir> ::= ( <accel dpvarlist> ) <accel shape attrs> |
4084    */
4085   case ACCEL_SHAPE_DIR2:
4086     break;
4087   /*
4088    *	<accel shape dir> ::= '<' <ident> '>' ( <accel dpvarlist> ) |
4089    */
4090   case ACCEL_SHAPE_DIR3:
4091   /*
4092    *	<accel shape dir> ::= '<' <ident> '>' ( <accel dpvarlist> ) <accel shape attrs>
4093    */
4094   case ACCEL_SHAPE_DIR4:
4095     break;
4096 
4097   /* ------------------------------------------------------------------ */
4098   /*
4099    *	<accel shape attrs> ::= <accel shape attrs> <accel shape attr> |
4100    */
4101   case ACCEL_SHAPE_ATTRS1:
4102     break;
4103   /*
4104    *	<accel shape attrs> ::= <accel shape attr>
4105    */
4106   case ACCEL_SHAPE_ATTRS2:
4107     break;
4108 
4109   /* ------------------------------------------------------------------ */
4110   /*
4111    *	<accel shape attr> ::= <accel dpdefault attr> |
4112    */
4113   case ACCEL_SHAPE_ATTR1:
4114     break;
4115   /*
4116    *	<accel shape attr> ::= <accel dpinit_needed attr> |
4117    */
4118   case ACCEL_SHAPE_ATTR2:
4119     break;
4120   /*
4121    *	<accel shape attr> ::= <accel dptype attr>
4122    */
4123   case ACCEL_SHAPE_ATTR3:
4124     break;
4125 
4126   /* ------------------------------------------------------------------ */
4127   /*
4128    *	<accel dpdefault attr> ::= DEFAULT ( <ident> )
4129    */
4130   case ACCEL_DPDEFAULT_ATTR1:
4131     break;
4132 
4133 
4134   /* ------------------------------------------------------------------ */
4135   /*
4136    *	<accel dpinit_needed attr> ::= INIT_NEEDED ( <accel dpinitvar list> )
4137    */
4138   case ACCEL_DPINIT_NEEDED_ATTR1:
4139     break;
4140 
4141   /* ------------------------------------------------------------------ */
4142   /*
4143    *	<accel dpinitvar list> ::= <accel dpinitvar list>, <ident> |
4144    */
4145   case ACCEL_DPINITVAR_LIST1:
4146   /*
4147    *	<accel dpinitvar list> ::= <ident>
4148    */
4149   case ACCEL_DPINITVAR_LIST2:
4150     break;
4151 
4152   /* ------------------------------------------------------------------ */
4153   /*
4154    *	<accel dptype attr> ::= TYPE ( <ident> )
4155    */
4156   case ACCEL_DPTYPE_ATTR1:
4157     break;
4158 
4159   /* ------------------------------------------------------------------ */
4160   /*
4161    *	<accel policy declstmt> ::= ACCPOLICY <accel policy name> <accel policy dir>
4162    */
4163   case ACCEL_POLICY_DECLSTMT1:
4164     break;
4165 
4166   /* ------------------------------------------------------------------ */
4167   /*
4168    *	<accel policy name> ::= '<' <ident> '>' |
4169    */
4170   case ACCEL_POLICY_NAME1:
4171   /*
4172    *	<accel policy name> ::= '<' <ident> : <ident> '>'
4173    */
4174   case ACCEL_POLICY_NAME2:
4175     break;
4176 
4177   /* ------------------------------------------------------------------ */
4178   /*
4179    *	<accel policy dir> ::= <accel policy attr list>
4180    */
4181   case ACCEL_POLICY_DIR1:
4182     break;
4183 
4184   /* ------------------------------------------------------------------ */
4185   /*
4186    *	<accel policy attr list> ::= <accel policy attr list> <accel policy attr> |
4187    */
4188   case ACCEL_POLICY_ATTR_LIST1:
4189     break;
4190   /*
4191    *	<accel policy attr list> ::= <accel policy attr>
4192    */
4193   case ACCEL_POLICY_ATTR_LIST2:
4194     break;
4195 
4196   /* ------------------------------------------------------------------ */
4197   /*
4198    *	<accel policy attr> ::= CREATE ( <accel dpvarlist> ) |
4199    */
4200   case ACCEL_POLICY_ATTR1:
4201     break;
4202   /*
4203    *	<accel policy attr> ::= NO_CREATE ( <accel dpvarlist> ) |
4204    */
4205   case ACCEL_POLICY_ATTR2:
4206     break;
4207   /*
4208    *	<accel policy attr> ::= COPYIN ( <accel dpvarlist> ) |
4209    */
4210   case ACCEL_POLICY_ATTR3:
4211     break;
4212   /*
4213    *	<accel policy attr> ::= COPYOUT ( <accel dpvarlist> ) |
4214    */
4215   case ACCEL_POLICY_ATTR4:
4216     break;
4217   /*
4218    *	<accel policy attr> ::= COPY ( <accel dpvarlist> ) |
4219    */
4220   case ACCEL_POLICY_ATTR5:
4221     break;
4222   /*
4223    *	<accel policy attr> ::= UPDATE ( <accel dpvarlist> ) |
4224    */
4225   case ACCEL_POLICY_ATTR6:
4226     break;
4227   /*
4228    *	<accel policy attr> ::= DEVICEPTR ( <accel dpvarlist> ) |
4229    */
4230   case ACCEL_POLICY_ATTR7:
4231     break;
4232   /*
4233    *	<accel policy attr> ::= <accel dpdefault attr> |
4234    */
4235   case ACCEL_POLICY_ATTR8:
4236     break;
4237   /*
4238    *	<accel policy attr> ::= <accel dptype attr>
4239    */
4240   case ACCEL_POLICY_ATTR9:
4241     break;
4242 
4243   /* ------------------------------------------------------------------ */
4244   /*
4245    *	<accel dpvarlist> ::= <accel dpvarlist> <accel dpvar> |
4246    */
4247   case ACCEL_DPVARLIST1:
4248     break;
4249   /*
4250    *	<accel dpvarlist> ::= <accel dpvar>
4251    */
4252   case ACCEL_DPVARLIST2:
4253     break;
4254 
4255   /* ------------------------------------------------------------------ */
4256   /*
4257    *	<accel dpvar> ::= <ident> |
4258    */
4259   case ACCEL_DPVAR1:
4260   /*
4261    *	<accel dpvar> ::= <ident> '<' <ident> '>' |
4262    */
4263   case ACCEL_DPVAR2:
4264   /*
4265    *	<accel dpvar> ::= <ident> ( <accel dpvar bnds> ) |
4266    */
4267   case ACCEL_DPVAR3:
4268   /*
4269    *	<accel dpvar> ::= <ident> '<' <ident> '>' ( <accel dpvar bnds> )
4270    */
4271   case ACCEL_DPVAR4:
4272     break;
4273 
4274   /* ------------------------------------------------------------------ */
4275   /*
4276    *	<accel dpvar bnds> ::= <accel dpvar bnds> , <accel dpvar bnd> |
4277    */
4278   case ACCEL_DPVAR_BNDS1:
4279     break;
4280   /*
4281    *	<accel dpvar bnds> ::= <accel dpvar bnd>
4282    */
4283   case ACCEL_DPVAR_BNDS2:
4284     break;
4285 
4286   /* ------------------------------------------------------------------ */
4287   /*
4288    *	<accel dpvar bnd> ::= <accel dp bnd> : <accel dp bnd> |
4289    */
4290   case ACCEL_DPVAR_BND1:
4291     break;
4292   /*
4293    *	<accel dpvar bnd> ::= <accel dp bnd>
4294    */
4295   case ACCEL_DPVAR_BND2:
4296     break;
4297 
4298   /* ------------------------------------------------------------------ */
4299   /*
4300    *	<accel dp bnd> ::= <accel dp sbnd>
4301    */
4302   case ACCEL_DP_BND1:
4303     break;
4304   /*
4305    *	<accel dp bnd> ::= <accel dp bndexp> |
4306    */
4307   case ACCEL_DP_BND2:
4308     break;
4309   /*
4310    *	<accel dp bnd> ::= <accel dp bndexp1>
4311    */
4312   case ACCEL_DP_BND3:
4313     break;
4314 
4315   /* ------------------------------------------------------------------ */
4316   /*
4317    *	<accel dp bndexp> ::= <accel dp addexp> |
4318    */
4319   case ACCEL_DP_BNDEXP1:
4320     break;
4321   /*
4322    *	<accel dp bndexp> ::= <accel dp mulexp>
4323    */
4324   case ACCEL_DP_BNDEXP2:
4325     break;
4326 
4327   /* ------------------------------------------------------------------ */
4328   /*
4329    *	<accel dp addexp> ::= <accel dp sbnd> <accel add opr> <accel dp sbnd>
4330    */
4331   case ACCEL_DP_ADDEXP1:
4332     break;
4333 
4334   /* ------------------------------------------------------------------ */
4335   /*
4336    *	<accel dp mulexp> ::= <accel dp sbnd> <accel mul opr> <accel dp sbnd>
4337    */
4338   case ACCEL_DP_MULEXP1:
4339     break;
4340 
4341   /* ------------------------------------------------------------------ */
4342   /*
4343    *	<accel add opr> ::= + |
4344    */
4345   case ACCEL_ADD_OPR1:
4346     break;
4347   /*
4348    *	<accel add opr> ::= -
4349    */
4350   case ACCEL_ADD_OPR2:
4351     break;
4352 
4353   /* ------------------------------------------------------------------ */
4354   /*
4355    *	<accel mul opr> ::= * |
4356    */
4357   case ACCEL_MUL_OPR1:
4358     break;
4359   /*
4360    *	<accel mul opr> ::= /
4361    */
4362   case ACCEL_MUL_OPR2:
4363     break;
4364 
4365   /* ------------------------------------------------------------------ */
4366   /*
4367    *	<accel dp bndexp1> ::= <accel dp mulexp> <accel add opr> <accel dp sbnd>
4368    */
4369   case ACCEL_DP_BNDEXP11:
4370     break;
4371 
4372   /* ------------------------------------------------------------------ */
4373   /*
4374    *	<accel dp sbnd> ::= <constant> |
4375    */
4376   case ACCEL_DP_SBND1:
4377     break;
4378   /*
4379    *	<accel dp sbnd> ::= <ident>
4380    */
4381   case ACCEL_DP_SBND2:
4382     break;
4383 
4384   /* ------------------------------------------------------------------ */
4385   /*
4386    *	<routine id list> ::= <ident> |
4387    */
4388   case ROUTINE_ID_LIST1:
4389     itemp = (ITEM *)getitem(0, sizeof(ITEM));
4390     itemp->next = ITEM_END;
4391     itemp->t.sptr = SST_SYMG(RHS(1));
4392     SST_BEGP(LHS, itemp);
4393     SST_ENDP(LHS, itemp);
4394     break;
4395 
4396   /*
4397    *	<routine id list> ::= <routine id list> , <ident>
4398    */
4399   case ROUTINE_ID_LIST2:
4400     itemp = (ITEM *)getitem(0, sizeof(ITEM));
4401     itemp->next = ITEM_END;
4402     itemp->t.sptr = SST_SYMG(RHS(3));
4403     SST_ENDG(RHS(1))->next = itemp;
4404     SST_ENDP(LHS, itemp);
4405     break;
4406 
4407   /* ------------------------------------------------------------------ */
4408   /*
4409    *      <final> ::= <id>
4410    */
4411   case FINAL1:
4412     break;
4413   /* ------------------------------------------------------------------ */
4414   /*
4415    *      <opt tpsl> ::= |
4416    */
4417   case OPT_TPSL1:
4418     break;
4419   /*
4420    *      <opt tpsl> ::= ( <type param spec list> )
4421    */
4422   case OPT_TPSL2:
4423     sem.param_offset = 0;
4424     break;
4425   /* ------------------------------------------------------------------ */
4426   /*
4427    *      <type param spec list> ::= <type param spec list> , <id> |
4428    */
4429   case TYPE_PARAM_SPEC_LIST1:
4430     rhstop = 3;
4431     goto tpsl_shared;
4432   /*
4433    *      <type param spec list> ::= <id>
4434    */
4435   case TYPE_PARAM_SPEC_LIST2:
4436     rhstop = 1;
4437   tpsl_shared:
4438     sptr = SST_SYMG(RHS(rhstop));
4439     if (sem.extends && sem.param_offset == 0) {
4440       sem.param_offset = get_highest_param_offset(DTYPEG(sem.extends));
4441     }
4442     sem.param_offset += 1;
4443     queue_type_param(sptr, 0, sem.param_offset, 1);
4444     break;
4445 
4446   /* ------------------------------------------------------------------ */
4447   /*
4448    *      <opt derived type spec> ::= |
4449    */
4450   case OPT_DERIVED_TYPE_SPEC1:
4451   /* fall thru */
4452   /*
4453    *      <opt derived type spec> ::= ( <type param decl list> )
4454    */
4455   case OPT_DERIVED_TYPE_SPEC2:
4456     break;
4457 
4458   /* ------------------------------------------------------------------ */
4459   /*
4460    *      <type param decl list> ::= <type param value> |
4461    */
4462   case TYPE_PARAM_DECL_LIST1:
4463     break;
4464   /*
4465    *      <type param decl list> ::= <type param decl list> , <type param value>
4466    */
4467   case TYPE_PARAM_DECL_LIST2:
4468     break;
4469 
4470   /* ------------------------------------------------------------------ */
4471   /*
4472    *      <type param value> ::= * |
4473    */
4474   case TYPE_PARAM_VALUE5:
4475     sem.param_assume_sz = 1;
4476     sem.param_defer_len = 0;
4477     goto param_comm;
4478 
4479   /*
4480    *      <type param value> ::= : |
4481    */
4482   case TYPE_PARAM_VALUE3:
4483     sem.param_assume_sz = 0;
4484     sem.param_defer_len = 1;
4485     goto param_comm;
4486 
4487   /*
4488    *      <type param value> ::= <expression> |
4489    */
4490   case TYPE_PARAM_VALUE1:
4491     sem.param_assume_sz = 0;
4492     sem.param_defer_len = 0;
4493   param_comm:
4494     if (sem.param_offset < 0) {
4495       error(155, 3, gbl.lineno, "A non keyword = type parameter specifier "
4496                                 "cannot follow a keyword = type parameter "
4497                                 "specifier",
4498             NULL);
4499     } else {
4500       sem.param_offset += 1;
4501       if (!sem.param_assume_sz && !sem.param_defer_len) {
4502         mkexpr(RHS(1));
4503         ast = SST_ASTG(RHS(1));
4504       } else {
4505         ast = 0;
4506       }
4507       if (A_TYPEG(ast) == A_CNST) {
4508         defer_put_kind_type_param(sem.param_offset, SST_CVALG(RHS(1)), NULL, 0,
4509                                   ast, 1);
4510       } else {
4511         defer_put_kind_type_param(sem.param_offset, -1, NULL, 0, ast, 1);
4512       }
4513     }
4514     break;
4515   /*
4516    *      <type param value> ::= <id name> = *
4517    */
4518   case TYPE_PARAM_VALUE6:
4519     sem.param_assume_sz = 1;
4520     sem.param_defer_len = 0;
4521     goto param_kwd_comm;
4522   /*
4523    *      <type param value> ::= <id name> = :
4524    */
4525   case TYPE_PARAM_VALUE4:
4526     sem.param_assume_sz = 0;
4527     sem.param_defer_len = 1;
4528     goto param_kwd_comm;
4529 
4530   /*
4531    *      <type param value> ::= <id name> = <expression>
4532    */
4533   case TYPE_PARAM_VALUE2:
4534     sem.param_assume_sz = 0;
4535     sem.param_defer_len = 0;
4536   param_kwd_comm:
4537     np = scn.id.name + SST_CVALG(RHS(1));
4538     sem.param_offset = -1;
4539     if (!sem.param_assume_sz && !sem.param_defer_len) {
4540       mkexpr(RHS(3));
4541       ast = SST_ASTG(RHS(3));
4542     } else {
4543       ast = 0;
4544     }
4545     if (A_TYPEG(ast) == A_CNST) {
4546       defer_put_kind_type_param(sem.param_offset, SST_CVALG(RHS(3)), np, 0, ast,
4547                                 1);
4548     } else {
4549       defer_put_kind_type_param(sem.param_offset, -1, np, 0, ast, 1);
4550     }
4551 
4552   /* ------------------------------------------------------------------ */
4553   /*
4554    *	<opt comma> ::= |
4555    */
4556   case OPT_COMMA1:
4557     break;
4558   /*
4559    *	<opt comma> ::= ,
4560    */
4561   case OPT_COMMA2:
4562     break;
4563 
4564     break;
4565 
4566   /* ------------------------------------------------------------------ */
4567   /*
4568    *	<dimkeyword> ::= DIMENSION |
4569    */
4570   case DIMKEYWORD1:
4571     /* disallow DIMENSION in a structure */
4572     if (INSIDE_STRUCT &&
4573         (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) {
4574       error(117, 3, gbl.lineno,
4575             STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
4576       sem.ignore_stmt = TRUE;
4577     }
4578     break;
4579   /*
4580    *	<dimkeyword> ::= <dimattr>
4581    */
4582   case DIMKEYWORD2:
4583     /* disallow DIMENSION in a structure */
4584     if (INSIDE_STRUCT &&
4585         (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) {
4586       error(117, 3, gbl.lineno,
4587             STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
4588       sem.ignore_stmt = TRUE;
4589     }
4590     scn.stmtyp = TK_DIMENSION;
4591     break;
4592 
4593   /* ------------------------------------------------------------------ */
4594   /*
4595    *      <nis> ::=
4596    */
4597   case NIS1:
4598     /* "not inside structure" test; if inside a structure emit error
4599      * message and set flag to tell parser to skip over the current
4600      * statement.
4601      */
4602     /* need to allow SEQUENCE (a hpf spec) in derived types */
4603     if (INSIDE_STRUCT &&
4604         (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) {
4605       error(117, 3, gbl.lineno,
4606             STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
4607       sem.ignore_stmt = TRUE;
4608     }
4609     break;
4610 
4611   /* ------------------------------------------------------------------ */
4612   /*
4613    *      <data type> ::= <base type> <opt len spec> |
4614    */
4615   case DATA_TYPE1:
4616     rhstop = 2;
4617     goto data_type_shared;
4618   /*
4619    *	  <data type> ::= <base type> ( <len kind> ) |
4620    */
4621   case DATA_TYPE2:
4622     rhstop = 3;
4623   data_type_shared:
4624     if (sem.deferred_func_len || sem.deferred_func_kind) {
4625       /* probably defined in a USEd module, wait until USE stmts have been
4626        * processed */
4627       break;
4628     }
4629 
4630     set_len_attributes(RHS(rhstop), 0);
4631     sem.gdtype =
4632         mod_type(sem.gdtype, sem.gty, lenspec[0].kind, lenspec[0].len, 0, 0);
4633     break;
4634   /*
4635    *      <data type> ::= CLASS <pgm> ( * )
4636    */
4637   case DATA_TYPE5:
4638     sptr = get_unl_poly_sym(0);
4639 #if DEBUG
4640     assert(DTY(DTYPEG(sptr)) == TY_DERIVED && UNLPOLYG(DTY(DTYPEG(sptr) + 3)),
4641            "semant1: Invalid dtype for CLASS(*)", 0, 3);
4642 #endif
4643     sem.class = 1;
4644     goto type_common;
4645 
4646   /*
4647    *      <data type> ::= CLASS  <pgm> ( <id> <opt derived type spec> )
4648    */
4649   case DATA_TYPE4:
4650     sptr = refsym((int)SST_SYMG(RHS(4)), OC_OTHER);
4651     sem.class = 1;
4652     goto type_common;
4653   /*
4654    *	<data type> ::= TYPE ( <id> <opt derived type spec> )
4655    */
4656   case DATA_TYPE3:
4657     sptr = refsym((int)SST_SYMG(RHS(3)), OC_OTHER);
4658   type_common:
4659     if (STYPEG(sptr) != ST_TYPEDEF) {
4660       if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) {
4661         sptr = GTYPEG(sptr);
4662       } else if (STYPEG(sptr) == ST_UNKNOWN && sem.pgphase == PHASE_INIT) {
4663         sem.deferred_dertype = sptr;
4664         sem.deferred_kind_len_lineno = gbl.lineno;
4665         sptr = declsym(sptr, ST_TYPEDEF, TRUE);
4666       } else if (STYPEG(sptr) == ST_UNKNOWN &&
4667                  (scn.stmtyp == TK_IMPLICIT ||
4668                   (INSIDE_STRUCT && STSK_ENT(0).type == 'd'))) {
4669         /* assume a forward reference -- legal if the type
4670          * appears in an implicit statement or is a component
4671          * declaration with the POINTER attribute or if phase is
4672          * PHASE_INIT (in which case it could be a function return
4673          * type).
4674          */
4675         sptr = declsym(sptr, ST_TYPEDEF, TRUE);
4676         dtype = get_type(6, TY_DERIVED, NOSYM);
4677         DTYPEP(sptr, dtype);
4678         DTY(dtype + 2) = 0; /* will be filled in */
4679         DTY(dtype + 3) = sptr;
4680         DTY(dtype + 5) = 0;
4681       } else {
4682         /* recover by creating an empty typedef */
4683         error(155, 3, gbl.lineno, "Derived type has not been declared -",
4684               SYMNAME(sptr));
4685         sptr = insert_sym(sptr);
4686         sptr = declsym(sptr, ST_TYPEDEF, TRUE);
4687         dtype = get_type(6, TY_DERIVED, NOSYM);
4688         DTYPEP(sptr, dtype);
4689         DTY(dtype + 2) = 0; /* will be filled in */
4690         DTY(dtype + 3) = sptr;
4691         DTY(dtype + 5) = 0;
4692       }
4693     }
4694 
4695     else if (DTY(DTYPEG(sptr) + 1) <= NOSYM &&
4696              (!INSIDE_STRUCT || STSK_ENT(0).type != 'd')) {
4697       int mem, oldsptr, tag;
4698       tag = DTY(DTYPEG(sptr) + 3);
4699     } else if (!sem.class && ABSTRACTG(sptr)) {
4700       error(155, 3, gbl.lineno, "illegal use of abstract type", SYMNAME(sptr));
4701     }
4702     if (!sem.type_mode || sem.stag_dtype != DTYPEG(sptr)) {
4703 /* Do not call defer_put_kind_type_param() if this declaration
4704  * is part of a recursively typed component. The
4705  * defer_put_kind_type_param() call below processes all type parameters.
4706  * But in this case, the type has not yet been fully defined. So, we
4707  * need to handle this later.
4708  */
4709       sem.stag_dtype = DTYPEG(sptr);
4710       sem.gdtype = sem.ogdtype = sem.stag_dtype;
4711       defer_put_kind_type_param(0, 0, NULL, sem.stag_dtype, 0, 2);
4712     } else {
4713       sem.stag_dtype = DTYPEG(sptr);
4714       sem.gdtype = sem.ogdtype = sem.stag_dtype;
4715     }
4716     defer_put_kind_type_param(0, 0, NULL, 0, 0, 0);
4717     if (!sem.new_param_dt && has_type_parameter(sem.stag_dtype) &&
4718         defer_pt_decl(0, 2)) {
4719       /* In this case we're using just the default type
4720        * of a parameterized derived type. We need to make sure we
4721        * create another instance of it so we don't pollute the
4722        * default type that's shared across all instances of the type
4723        * (e.g., type(t) :: x may pollute type(t(5)) :: y ).
4724        */
4725       sem.new_param_dt = create_parameterized_dt(sem.stag_dtype, 0);
4726     }
4727     put_default_kind_type_param(
4728         (sem.new_param_dt) ? sem.new_param_dt : sem.stag_dtype, 0, 0);
4729     put_length_type_param(
4730         (sem.new_param_dt) ? sem.new_param_dt : sem.stag_dtype, 0);
4731     break;
4732 
4733   /* ------------------------------------------------------------------ */
4734   /*
4735    *	<type spec> ::= <intrinsic type>
4736    */
4737   case TYPE_SPEC1:
4738     break;
4739   /*
4740    *	<type spec> ::= <ident>
4741    */
4742   case TYPE_SPEC2:
4743     SST_DTYPEP(LHS, sem.gdtype);
4744     break;
4745 
4746   /* ------------------------------------------------------------------ */
4747   /*
4748    *	<intrinsic type> ::= <base type> <opt len spec> |
4749    */
4750   case INTRINSIC_TYPE1:
4751     rhstop = 2;
4752     if (sem.gdtype == DT_CHAR || sem.gdtype == DT_NCHAR) {
4753       if (SST_IDG(RHS(2)) == 0) {
4754         if (SST_ASTG(RHS(2)))
4755           sem.gcvlen = SST_ASTG(RHS(2));
4756         else if (SST_SYMG(RHS(2)) == -2 || SST_SYMG(RHS(2)) == -1)
4757           sem.gcvlen = astb.i1;
4758         else
4759           sem.gcvlen = mk_cval(SST_SYMG(RHS(2)), DT_INT4);
4760 
4761       } else {
4762         sem.gcvlen = SST_ASTG(RHS(2));
4763       }
4764     }
4765     goto intrinsic_type_shared;
4766   /*
4767    *	<intrinsic type> ::= <base type> ( <len kind> )
4768    */
4769   case INTRINSIC_TYPE2:
4770     rhstop = 3;
4771     if (sem.gdtype == DT_CHAR || sem.gdtype == DT_NCHAR) {
4772       if (SST_IDG(RHS(3)) == 0) {
4773         if (SST_ASTG(RHS(3)))
4774           sem.gcvlen = SST_ASTG(RHS(3));
4775         else if (SST_SYMG(RHS(3)) == -2 || SST_SYMG(RHS(3)) == -1)
4776           sem.gcvlen = astb.i1;
4777         else
4778           sem.gcvlen = mk_cval(SST_SYMG(RHS(3)), DT_INT4);
4779 
4780       } else {
4781         sem.gcvlen = SST_ASTG(RHS(3));
4782       }
4783     }
4784 
4785   intrinsic_type_shared:
4786     if (is_exe_stmt && sem.which_pass == 0)
4787       break;
4788     if (sem.deferred_func_len) {
4789       /* probably defined in a USEd module, wait USE stmts have been processed
4790        */
4791       break;
4792     }
4793     set_aclen(RHS(rhstop), 1, 1);
4794     sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
4795                           lenspec[1].propagated, 0);
4796     SST_DTYPEP(LHS, sem.gdtype);
4797     set_aclen(RHS(rhstop), 1, 0);
4798     SST_IDP(LHS, 0);
4799     break;
4800 
4801   /* ------------------------------------------------------------------ */
4802   /*
4803    *      <base type> ::= INTEGER  |
4804    */
4805   case BASE_TYPE1:
4806     sem.gdtype = sem.ogdtype = stb.user.dt_int;
4807     sem.gty = TY_INT;
4808     break;
4809   /*
4810    *      <base type> ::= REAL     |
4811    */
4812   case BASE_TYPE2:
4813     sem.gdtype = sem.ogdtype = stb.user.dt_real;
4814     sem.gty = TY_REAL;
4815     break;
4816   /*
4817    *      <base type> ::= DOUBLEPRECISION |
4818    */
4819   case BASE_TYPE3:
4820     sem.gdtype = sem.ogdtype = DT_DBLE;
4821     sem.gty = TY_DBLE;
4822     if (XBIT(57, 0x10) && DTY(sem.gdtype) == TY_QUAD) {
4823       error(437, 2, gbl.lineno, "DOUBLE PRECISION", "REAL");
4824       sem.gdtype = DT_REAL;
4825     }
4826     break;
4827   /*
4828    *      <base type> ::= COMPLEX |
4829    */
4830   case BASE_TYPE4:
4831     sem.gdtype = sem.ogdtype = stb.user.dt_cmplx;
4832     sem.gty = TY_CMPLX;
4833     break;
4834   /*
4835    *      <base type> ::= DOUBLECOMPLEX   |
4836    */
4837   case BASE_TYPE5:
4838     if (flg.standard)
4839       error(171, 2, gbl.lineno, "DOUBLECOMPLEX", CNULL);
4840     sem.gdtype = sem.ogdtype = DT_DCMPLX;
4841     sem.gty = TY_DCMPLX;
4842     if (XBIT(57, 0x10) && DTY(sem.gdtype) == TY_DCMPLX) {
4843       error(437, 2, gbl.lineno, "DOUBLE COMPLEX", "COMPLEX");
4844       sem.gdtype = DT_CMPLX;
4845     }
4846     break;
4847   /*
4848    *      <base type> ::= LOGICAL  |
4849    */
4850   case BASE_TYPE6:
4851     sem.gdtype = sem.ogdtype = stb.user.dt_log;
4852     sem.gty = TY_LOG;
4853     break;
4854   /*
4855    *      <base type> ::= CHARACTER |
4856    */
4857   case BASE_TYPE7:
4858     sem.gdtype = sem.ogdtype = DT_CHAR;
4859     sem.gty = TY_CHAR;
4860     break;
4861   /*
4862    *      <base type> ::= NCHARACTER |
4863    */
4864   case BASE_TYPE8:
4865     if (flg.standard)
4866       error(171, 2, gbl.lineno, "NCHARACTER", CNULL);
4867     sem.gdtype = sem.ogdtype = DT_NCHAR;
4868     sem.gty = TY_NCHAR;
4869     break;
4870   /*
4871    *      <base type> ::= BYTE
4872    */
4873   case BASE_TYPE9:
4874     if (flg.standard)
4875       error(171, 2, gbl.lineno, "BYTE", CNULL);
4876     sem.gdtype = sem.ogdtype = DT_BINT;
4877     sem.gty = TY_BINT;
4878     break;
4879 
4880   /* ------------------------------------------------------------------ */
4881   /*
4882    *      <opt len spec> ::= |
4883    */
4884   case OPT_LEN_SPEC1:
4885     SST_IDP(LHS, 0);
4886     SST_SYMP(LHS, -1);
4887     SST_ASTP(LHS, 0);
4888     SST_DTYPEP(LHS, sem.gdtype);
4889     break;
4890   /*
4891    *      <opt len spec> ::= * <len spec>
4892    */
4893   case OPT_LEN_SPEC2:
4894     *LHS = *RHS(2);
4895     if (sem.ogdtype != DT_CHAR && flg.standard)
4896       errwarn(173);
4897     break;
4898 
4899   /*
4900    *      <opt len spec> ::= : <len spec>
4901    */
4902   case OPT_LEN_SPEC3:
4903     *LHS = *RHS(2);
4904     if (sem.ogdtype != DT_CHAR && flg.standard)
4905       errwarn(173);
4906     break;
4907 
4908   /* ------------------------------------------------------------------ */
4909   /*
4910    *      <len spec> ::= <integer>  |
4911    */
4912   case LEN_SPEC1:    /* constant value set by scan */
4913     SST_IDP(LHS, 0); /* flag that an expression was seen */
4914     SST_ASTP(LHS, 0);
4915     goto len_spec;
4916   /*
4917    *      <len spec> ::= ( <tpv> ) |
4918    */
4919   case LEN_SPEC2:
4920     *LHS = *RHS(2);
4921   char_len_spec:
4922     if (sem.ogdtype != DT_CHAR && sem.ogdtype != DT_NCHAR)
4923       SST_SYMP(LHS, 0);
4924   len_spec:
4925     if (is_exe_stmt && sem.which_pass == 0)
4926       break;
4927     if (sem.ogdtype == DT_CHAR || sem.ogdtype == DT_NCHAR) {
4928       if (SST_IDG(LHS) == 0) {
4929         if (SST_CVALG(LHS) <= 0) {
4930           /* zero-size character - set flag */
4931           SST_SYMP(LHS, -2);
4932         }
4933       }
4934       break;
4935     }
4936     if (SST_IDG(LHS) == 0 && SST_SYMG(LHS) <= 0) {
4937       /* Cause error message to print later when context is known,
4938        * ensure that illegal value -1 doesn't map to internal
4939        * flag -1 for no length spec.
4940        */
4941       SST_SYMP(LHS, 99); /* cause error message displayed later */
4942     }
4943     break;
4944 
4945   /* ------------------------------------------------------------------ */
4946   /*
4947    *	<tpv> ::= <expression> |
4948    */
4949   case TPV1:
4950     if (is_exe_stmt && sem.which_pass == 0)
4951       break;
4952     if (chk_kind_parm(RHS(1))) {
4953       mkexpr(RHS(1)); /* Needed for type parameter */
4954       ast = SST_ASTG(RHS(1));
4955       switch (A_TYPEG(ast)) {
4956       case A_ID:
4957       case A_LABEL:
4958       case A_ENTRY:
4959       case A_SUBSCR:
4960       case A_SUBSTR:
4961       case A_MEM:
4962         /* Mark possible use of type parameter */
4963         sptr = sym_of_ast(ast);
4964         KINDP(sptr, -1);
4965         break;
4966       }
4967     }
4968     rhstop = 5;
4969     if (sem.ogdtype != DT_CHAR && sem.ogdtype != DT_NCHAR) {
4970       int offset;
4971       if (sem.pgphase <= PHASE_USE) {
4972         if (SST_IDG(top) == S_IDENT && STYPEG(SST_SYMG(top)) == ST_UNKNOWN) {
4973           /* probably defined in a USEd module, wait until USE stmts
4974            * have been processed */
4975           ast = SST_ASTG(RHS(1));
4976           if (!ast) {
4977             ast = mk_id(SST_SYMG(top));
4978           }
4979           sem.deferred_func_kind = ast;
4980           sem.deferred_kind_len_lineno = gbl.lineno;
4981           break;
4982         } else if (SST_IDG(top) == S_EXPR) {
4983           sem.deferred_func_kind = SST_ASTG(RHS(1));
4984           sem.deferred_kind_len_lineno = gbl.lineno;
4985           break;
4986         }
4987       }
4988       offset = chk_kind_parm(RHS(1));
4989       if (offset) {
4990         /* TO DO: Save length expression candidate like in DT_CHAR case */
4991         sem.type_param_candidate = offset;
4992         SST_SYMP(LHS, 4); /* place holder */
4993         sem.kind_candidate = (ITEM *)getitem(0, sizeof(ITEM));
4994         sem.kind_candidate->t.stkp = (SST *)getitem(0, sizeof(SST));
4995         *(sem.kind_candidate->t.stkp) = *RHS(1);
4996       } else
4997         SST_SYMP(LHS, chkcon(RHS(1), DT_INT4, TRUE));
4998     } else {
4999       int offset;
5000       offset = chk_kind_parm(RHS(1));
5001       if (offset) {
5002         sem.type_param_candidate = offset;
5003         sem.len_candidate = (ITEM *)getitem(0, sizeof(ITEM));
5004         sem.len_candidate->t.stkp = (SST *)getitem(0, sizeof(SST));
5005         *(sem.len_candidate->t.stkp) = *RHS(1);
5006         SST_SYMP(LHS, 1); /* place holder */
5007         SST_IDP(LHS, 0);  /* flag that a constant was seen */
5008         SST_ASTP(LHS, 0); /* not expression */
5009         break;
5010       }
5011       sem.len_candidate = 0;
5012       constant_lvalue(RHS(1));
5013       if (SST_IDG(RHS(1)) == S_CONST) {
5014         SST_SYMP(LHS, chkcon(RHS(1), DT_INT4, TRUE));
5015       } else {
5016         (void)chktyp(RHS(1), DT_INT, TRUE);
5017         ast = SST_ASTG(RHS(1));
5018         /* flag that an expression was seen: id field is 1, sym field
5019          * is non-zero, and ast field is the ast of the expression.
5020          */
5021         if (sem.pgphase == PHASE_INIT) {
5022           if (SST_IDG(top) == S_IDENT && STYPEG(SST_SYMG(top)) == ST_UNKNOWN) {
5023             /* probably defined in a USEd module,
5024              * wait until USE stmts have been processed */
5025             if (!ast) {
5026               ast = mk_id(SST_SYMG(top));
5027             }
5028             sem.deferred_func_len = ast;
5029             sem.deferred_kind_len_lineno = gbl.lineno;
5030             break;
5031           } else if (SST_IDG(top) == S_EXPR) {
5032             sem.deferred_func_len = SST_ASTG(RHS(1));
5033             sem.deferred_kind_len_lineno = gbl.lineno;
5034             break;
5035           }
5036         }
5037 
5038         SST_IDP(LHS, 1);
5039         SST_SYMP(LHS, _INF_CLEN);
5040         SST_ASTP(LHS, SST_ASTG(RHS(1)));
5041         break;
5042       }
5043     }
5044 
5045     SST_IDP(LHS, 0);  /* flag that a constant was seen */
5046     SST_ASTP(LHS, 0); /* not expression */
5047     break;
5048   /*
5049    *	<tpv> ::= *
5050    */
5051   case TPV2:
5052     /* flag that a '*' was seen: id field is 1, sym field is zero. */
5053     SST_IDP(LHS, 1);
5054     SST_SYMP(LHS, 0);
5055     SST_ASTP(LHS, 0); /* not expression */
5056     break;
5057   /*
5058    *	<tpv> ::= :
5059    */
5060   case TPV3:
5061     /* flag that a ':' was seen: id field is 1, sym field is -1. */
5062     SST_IDP(LHS, 1);
5063     SST_SYMP(LHS, -1);
5064     SST_ASTP(LHS, 0); /* not expression */
5065     break;
5066 
5067   /* ------------------------------------------------------------------ */
5068   /*
5069    *	<len kind> ::= <tpv> |
5070    */
5071   case LEN_KIND1:
5072     if (is_exe_stmt && sem.which_pass == 0)
5073       break;
5074     if (sem.deferred_func_kind) {
5075       /* probably defined in a USEd module, wait USE stmts have been processed
5076        */
5077       break;
5078     }
5079 
5080     if (sem.gdtype != DT_CHAR && sem.gdtype != DT_NCHAR) {
5081       sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(1)));
5082       SST_SYMP(LHS, -1);
5083       break;
5084     }
5085     goto len_spec;
5086   /*
5087    *	<len kind> ::= <len kind spec> |
5088    */
5089   case LEN_KIND2:
5090     if (is_exe_stmt && sem.which_pass == 0)
5091       break;
5092     switch (SST_FLAGG(RHS(1))) {
5093     case 0: /* error */
5094       break;
5095     case 1: /* LEN = */
5096       if (sem.ogdtype == DT_CHAR)
5097         goto char_len_spec;
5098       error(81, 3, gbl.lineno,
5099             "- LEN = cannot be specified with non-character type", CNULL);
5100       break;
5101     case 2: /* KIND = */
5102       sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(1)));
5103       break;
5104     }
5105     SST_SYMP(LHS, -1);
5106     break;
5107   /*
5108    *	<len kind> ::= <tpv> , <len kind spec>|
5109    */
5110   case LEN_KIND3: /* len, kind = ... */
5111     if (is_exe_stmt && sem.which_pass == 0)
5112       break;
5113     if (sem.ogdtype != DT_CHAR) {
5114       error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL);
5115       SST_SYMP(LHS, -1); /* an error occurred - null processing */
5116       break;
5117     }
5118     switch (SST_FLAGG(RHS(3))) {
5119     case 0: /* error */
5120       break;
5121     case 1: /* LEN = */
5122       error(81, 3, gbl.lineno, "- Repeated LEN", CNULL);
5123       break;
5124     case 2: /* KIND = */
5125       sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(3)));
5126       break;
5127     }
5128     goto char_len_spec;
5129   /*
5130    *	<len kind> ::= <tpv> , <tpv> |
5131    */
5132   case LEN_KIND4: /* len, kind */
5133     if (is_exe_stmt && sem.which_pass == 0)
5134       break;
5135     if (sem.ogdtype != DT_CHAR) {
5136       error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL);
5137       SST_SYMP(LHS, -1); /* an error occurred - null processing */
5138       break;
5139     }
5140     sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(3)));
5141     goto char_len_spec;
5142   /*
5143    *	<len kind> ::= <len kind spec> , <len kind spec>
5144    */
5145   case LEN_KIND5: /* len = .., kind = ... or kind = ..., len = ... */
5146     if (is_exe_stmt && sem.which_pass == 0)
5147       break;
5148     if (sem.ogdtype != DT_CHAR) {
5149       error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL);
5150       SST_SYMP(LHS, -1); /* an error occurred - null processing */
5151       break;
5152     }
5153     switch (SST_FLAGG(RHS(1))) {
5154     default: /* error */
5155       break;
5156     case 1: /* LEN = */
5157       switch (SST_FLAGG(RHS(3))) {
5158       case 0: /* error */
5159         break;
5160       case 1: /* LEN = */
5161         error(81, 3, gbl.lineno, "- Repeated LEN =", CNULL);
5162         break;
5163       case 2: /* KIND = */
5164         sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(3)));
5165         goto char_len_spec;
5166       }
5167       break;
5168     case 2: /* KIND = */
5169       switch (SST_FLAGG(RHS(3))) {
5170       case 0: /* error */
5171         break;
5172       case 1: /* LEN = */
5173         sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(1)));
5174         *LHS = *RHS(3);
5175         goto char_len_spec;
5176       case 2: /* KIND = */
5177         error(81, 3, gbl.lineno, "- Repeated KIND =", CNULL);
5178         break;
5179       }
5180       break;
5181     }
5182     SST_SYMP(LHS, -1); /* an error occurred - null processing */
5183     break;
5184 
5185   /* ------------------------------------------------------------------ */
5186   /*
5187    *	<len kind spec> ::= <id name> = <tpv>
5188    */
5189   case LEN_KIND_SPEC1:
5190     np = scn.id.name + SST_CVALG(RHS(1));
5191     *LHS = *RHS(3);
5192     if (is_exe_stmt && sem.which_pass == 0)
5193       break;
5194     SST_FLAGP(LHS, 0);
5195     if (sem_strcmp(np, "len") == 0) {
5196       SST_FLAGP(LHS, 1);
5197       if (sem.type_param_candidate && sem.len_candidate) {
5198         sem.len_type_param = sem.type_param_candidate;
5199         sem.type_param_candidate = 0;
5200         mkexpr(sem.len_candidate->t.stkp);
5201         ast = SST_ASTG(sem.len_candidate->t.stkp);
5202         if (A_TYPEG(ast) != A_CNST) {
5203           /* set ignore flag on any len type parameters to prevent
5204            * "implicit none" errors
5205            */
5206           chk_len_parm_expr(ast, 0, 1);
5207         }
5208       }
5209     } else if (sem_strcmp(np, "kind") == 0) {
5210       sem.kind_type_param = sem.type_param_candidate;
5211       sem.type_param_candidate = 0;
5212       if (!sem.deferred_func_kind) {
5213         if (SST_IDG(RHS(3))) {
5214           if (SST_ASTG(RHS(3)))
5215             errsev(87);
5216           else
5217             error(81, 3, gbl.lineno, "- KIND = *", CNULL);
5218         } else
5219           SST_FLAGP(LHS, 2);
5220       }
5221     } else {
5222       error(34, 3, gbl.lineno, np, CNULL);
5223     }
5224     break;
5225 
5226   /* ------------------------------------------------------------------ */
5227   /*
5228    *      <optional comma> ::= |
5229    */
5230   case OPTIONAL_COMMA1:
5231     break;
5232   /*
5233    *      <optional comma> ::= ,
5234    */
5235   case OPTIONAL_COMMA2:
5236     break;
5237 
5238   /* ------------------------------------------------------------------ */
5239   /*
5240    *	<opt attr> ::=   |
5241    */
5242   case OPT_ATTR1:
5243     break;
5244   /*
5245    *	<opt attr> ::= ::
5246    */
5247   case OPT_ATTR2:
5248     break;
5249 
5250   /* ------------------------------------------------------------------ */
5251   /*
5252    *      <typdcl list> ::= <typdcl list> , <typdcl item> |
5253    */
5254   case TYPDCL_LIST1:
5255     break;
5256   /*
5257    *      <typdcl list> ::= <typdcl item>
5258    */
5259   case TYPDCL_LIST2:
5260     break;
5261 
5262   /* ------------------------------------------------------------------ */
5263   /*
5264    *      <typdcl item> ::= <dcl id> / <dinit const list> / |
5265    */
5266   case TYPDCL_ITEM1:
5267     if (flg.standard)
5268       errwarn(174);
5269     inited = TRUE;
5270     goto typ_dcl_item;
5271   /*
5272    *      <typdcl item> ::= <dcl id>
5273    */
5274   case TYPDCL_ITEM2:
5275     inited = FALSE;
5276   typ_dcl_item:
5277     sptr = SST_SYMG(RHS(1));
5278     if (flg.xref)
5279       xrefput(sptr, 'd');
5280     dtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
5281                      lenspec[1].propagated, sptr);
5282     if (!DCLDG(sptr)) {
5283       switch (STYPEG(sptr)) {
5284       /* any cases for which a type must be identical to the variable's
5285        * implicit type.
5286        */
5287       case ST_PARAM:
5288         if (DTYPEG(sptr) != dtype)
5289           error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5290         break;
5291       default:
5292         break;
5293       }
5294     }
5295   common_typespecs:
5296     if (DCLDG(sptr)) {
5297       switch (STYPEG(sptr)) {
5298       /*  any cases for which a data type does not apply */
5299       case ST_MODULE:
5300       case ST_NML:
5301         error(44, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5302         break;
5303       default:
5304         /* data type for ident has already been specified */
5305         if (DDTG(DTYPEG(sptr)) == dtype)
5306           error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
5307         else if (DTY(DTYPEG(sptr)) == TY_PTR &&
5308                  DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC &&
5309                  DTY(DTY(DTYPEG(sptr) + 1) + 1) == DT_NONE &&
5310                  DTY(DTY(DTYPEG(sptr) + 1) + 2) == 0) {
5311           /* ptr to procedure, return dtype is DT_NONE, no interface; just
5312            * update the return dtype (no longer assume it's a pointer to a
5313            * subroutine).
5314            */
5315           DTY(DTY(DTYPEG(sptr) + 1) + 1) = dtype;
5316         } else {
5317           error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5318         }
5319       }
5320       break; /* to avoid setting symbol table entry's stype field */
5321     }
5322 
5323     DCLDP(sptr, TRUE);
5324 
5325     /* Procedure pointer without a declared type (combination of "external" and
5326      * "pointer" attributes) */
5327     if (is_procedure_ptr_dtype(DTYPEG(sptr))) {
5328       set_proc_ptr_result_dtype(DTYPEG(sptr), dtype);
5329       /* Avoid the rest */
5330       break;
5331     }
5332 
5333     /* Procedure without a type ("external" attribute) */
5334     if (is_procedure_dtype(DTYPEG(sptr))) {
5335       set_proc_result_dtype(DTYPEG(sptr), dtype);
5336       /* Avoid the rest */
5337       break;
5338     }
5339 
5340     set_char_attributes(sptr, &dtype);
5341     if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
5342       DTY(DTYPEG(sptr) + 1) = dtype;
5343       if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) &&
5344           DISTMEMG(DTY(dtype + 3))) {
5345         error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5346       }
5347     } else {
5348       DTYPEP(sptr, dtype);
5349     }
5350     if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr)) {
5351 #if DEBUG
5352       interr("semant1: data type set for ST_ENTRY with FVAL", sptr, 3);
5353 #endif
5354       DCLDP(FVALG(sptr), TRUE);
5355       DTYPEP(FVALG(sptr), DTYPEG(sptr));
5356       set_char_attributes(FVALG(sptr), &dtype);
5357     }
5358     if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER &&
5359         RESULTG(sptr)) {
5360       /* set the type for the entry point as well */
5361       copy_type_to_entry(sptr);
5362     }
5363     if (inited) { /* check if symbol is data initialized */
5364       gen_dinit(sptr, RHS(3));
5365     } else if (DTY(DDTG(dtype)) == TY_DERIVED && !POINTERG(sptr) &&
5366                !ADJARRG(sptr) && !ALLOCG(sptr) && SCG(sptr) != SC_DUMMY) {
5367       int dt_dtype = DDTG(dtype);
5368       if (INSIDE_STRUCT) {
5369         /* Uninitialized declaration of a derived type data item.
5370          * Check for and handle any component intializations defined
5371          * for this derived type */
5372         build_typedef_init_tree(sptr, dt_dtype);
5373       } else if (DTY(dt_dtype + 5) && SCOPEG(sptr) &&
5374                  SCOPEG(sptr) == stb.curr_scope &&
5375                  STYPEG(stb.curr_scope) == ST_MODULE) {
5376         /*
5377          * a derived type module variable has component initializers,
5378          * so generate inits.
5379          */
5380         build_typedef_init_tree(sptr, dt_dtype);
5381       }
5382     }
5383 
5384     break;
5385 
5386   /*
5387    *      <typdcl item> ::= %FILL
5388    */
5389   case TYPDCL_ITEM3:
5390     if (flg.standard)
5391       error(176, 2, gbl.lineno, "%FILL", CNULL);
5392     if (sem.stsk_depth == 0)
5393       errwarn(145);
5394     break;
5395 
5396   /* ------------------------------------------------------------------ */
5397   /*
5398    *      <dcl id list> ::= <dcl id list> , <dcl id> |
5399    */
5400   case DCL_ID_LIST1:
5401     rhstop = 3;
5402     goto dcl_id_list;
5403   /*
5404    *      <dcl id list> ::= <dcl id> |
5405    */
5406   case DCL_ID_LIST2:
5407     rhstop = 1;
5408   /* Shared by DIMENSION and COMMON statements */
5409   dcl_id_list:
5410     sptr = SST_SYMG(RHS(rhstop));
5411     if (lenspec[1].kind)
5412       error(32, 2, gbl.lineno, SYMNAME(sptr), CNULL);
5413     if (flg.xref)
5414       xrefput(sptr, 'd');
5415     if (scn.stmtyp == TK_COMMON) {
5416       /* COMMON block defn: link symbol into list */
5417       {
5418         itemp = (ITEM *)getitem(0, sizeof(ITEM));
5419         itemp->next = ITEM_END;
5420         itemp->t.sptr = sptr;
5421         if (rhstop == 1)
5422           /* adding first common block item to list: */
5423           SST_BEGP(LHS, itemp);
5424         else
5425           SST_ENDG(RHS(1))->next = itemp;
5426       }
5427       SST_ENDP(LHS, itemp);
5428     } else {
5429 #if DEBUG
5430       assert(scn.stmtyp == TK_DIMENSION, "semant:unexp.stmt-dcl_id_lis",
5431              scn.stmtyp, 3);
5432 #endif
5433     }
5434     break;
5435 
5436   /* ------------------------------------------------------------------ */
5437   /*
5438    *      <dcl id> ::= <ident> <opt len spec>  |
5439    */
5440   case DCL_ID1:
5441     set_len_attributes(RHS(2), 1);
5442     stype = ST_IDENT;
5443     sptr = SST_SYMG(RHS(1));
5444     if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr))
5445       sptr = FVALG(sptr);
5446     if (test_scope(sptr) == sem.scope_level && STYPEG(sptr) != ST_MEMBER) {
5447       dtype = DTYPEG(sptr);
5448     } else {
5449       dtype = 0;
5450     }
5451     sem.dinit_count = 1;
5452     goto dcl_shared;
5453   /*
5454    *      <dcl id> ::= <ident> <opt len spec> <dim beg> <dimension list> ) <opt
5455    * len spec>
5456    */
5457   case DCL_ID2:
5458     /* Send len spec up with ident on semantic stack */
5459     if (SST_SYMG(RHS(6)) != -1) {
5460       if (SST_SYMG(RHS(2)) != -1)
5461         errsev(46);
5462       set_len_attributes(RHS(6), 1);
5463     } else
5464       set_len_attributes(RHS(2), 1);
5465     stype = ST_ARRAY;
5466     dtype = SST_DTYPEG(RHS(4));
5467     ad = AD_DPTR(dtype);
5468     if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad) || sem.interface)
5469       sem.dinit_count = -1;
5470     else
5471       sem.dinit_count = ad_val_of(sym_of_ast(AD_NUMELM(AD_DPTR(dtype))));
5472   dcl_shared:
5473     sptr = SST_SYMG(RHS(1));
5474     if (!sem.which_pass && gbl.internal > 1) {
5475       decr_ident_use(sptr, ident_host_sub);
5476     }
5477     if (!sem.kind_type_param && !sem.len_type_param &&
5478         sem.type_param_candidate) {
5479       sem.kind_type_param = sem.type_param_candidate;
5480       sem.type_param_candidate = 0;
5481     }
5482     if (INSIDE_STRUCT) {
5483       if (STYPEG(sptr) != ST_UNKNOWN)
5484         SST_SYMP(LHS, (sptr = insert_sym(sptr)));
5485       if (sem.kind_type_param) {
5486         USEKINDP(sptr, 1);
5487         KINDP(sptr, sem.kind_type_param);
5488         if (sem.kind_candidate) {
5489           /* Save kind expression in component */
5490           mkexpr(sem.kind_candidate->t.stkp);
5491           KINDASTP(sptr, SST_ASTG(sem.kind_candidate->t.stkp));
5492         }
5493       }
5494       if (sem.len_type_param) {
5495         USELENP(sptr, 1);
5496         LENP(sptr, sem.len_type_param);
5497       }
5498       SYMLKP(sptr, NOSYM);
5499       STYPEP(sptr, ST_MEMBER);
5500       /* if the dtype was determined from the symbol table entry then it
5501        * is incorrect (because we got a new symbol entry above).
5502        */
5503       if (stype == ST_IDENT)
5504         dtype = sem.gdtype;
5505 
5506       if (sem.gdtype != -1 && DTY(sem.gdtype) == TY_DERIVED &&
5507           (STSK_ENT(0).type == 'd')) {
5508         stsk = &STSK_ENT(0);
5509         /* if outer derived type has SEQUENCE then nested one should */
5510         if (SEQG(DTY(stsk->dtype + 3)) && !SEQG(DTY(sem.gdtype + 3))) {
5511           error(155, 3, gbl.lineno,
5512                 "SEQUENCE must be set for nested derived type",
5513                 SYMNAME(DTY(sem.gdtype + 3)));
5514         }
5515         if (DTY(stsk->dtype + 3) == DTY(sem.gdtype + 3)) {
5516           error(155, 3, gbl.lineno,
5517                 "Derived type component must have the POINTER attribute -",
5518                 SYMNAME(sptr));
5519         } else if (!DCLDG(DTY(sem.gdtype + 3)))
5520           error(155, 3, gbl.lineno, "Derived type has not been declared -",
5521                 SYMNAME(DTY(sem.gdtype + 3)));
5522       }
5523 
5524       DTYPEP(sptr, dtype); /* must be done before link members */
5525       /* link field-namelist into member list at this level */
5526       stsk = &STSK_ENT(0);
5527       link_members(stsk, sptr);
5528       if (stype == ST_ARRAY && STSK_ENT(0).type != 'd' &&
5529           (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)))
5530         error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5531       if (DTY(dtype) == TY_ARRAY) {
5532         int d;
5533         d = DTY(dtype + 1);
5534         if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
5535           error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5536         }
5537         if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) {
5538           if (!ALLOCG(sptr) && AD_ADJARR(ad)) {
5539             int bndast, bnd_sptr, badArray, offset;
5540             int numdim = AD_NUMDIM(ad);
5541             for (badArray = i = 0; i < numdim; i++) {
5542               bndast = AD_LWAST(ad, i);
5543               badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
5544               if (!badArray) {
5545                 bndast = AD_UPAST(ad, i);
5546                 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
5547                 if (!badArray) {
5548                   ADJARRP(sptr, 1);
5549                   USELENP(sptr, 1);
5550                   break;
5551                 }
5552               }
5553             }
5554             if (badArray) {
5555               for (badArray = i = 0; i < numdim; i++) {
5556                 bndast = AD_LWAST(ad, i);
5557                 badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
5558                 if (badArray) {
5559                   badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
5560                   if (!badArray) {
5561                     ADJARRP(sptr, 1);
5562                     USELENP(sptr, 1);
5563                     break;
5564                   }
5565                 }
5566                 if (badArray)
5567                   goto illegal_array_member;
5568                 bndast = AD_UPAST(ad, i);
5569                 badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
5570                 if (badArray) {
5571                   badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
5572                   if (!badArray) {
5573                     ADJARRP(sptr, 1);
5574                     USELENP(sptr, 1);
5575                     break;
5576                   }
5577                 } else if (A_TYPEG(bndast) != A_ID &&
5578                            A_TYPEG(bndast) != A_CNST) {
5579 
5580                   ADJARRP(sptr, 1);
5581                   USELENP(sptr, 1);
5582                   if (!chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1)) {
5583                     USEKINDP(sptr, 1);
5584                   }
5585                   break;
5586                 }
5587                 if (badArray)
5588                   goto illegal_array_member;
5589               }
5590             }
5591           } else if (!ALLOCG(sptr)) {
5592           illegal_array_member:
5593             error(134, 3, gbl.lineno,
5594                   "- deferred shape array must have the POINTER "
5595                   "attribute in a derived type",
5596                   SYMNAME(sptr));
5597             ALLOCP(sptr, 1);
5598           }
5599         }
5600       }
5601       if (XBIT(58, 0x10000) && !F90POINTERG(sptr)) {
5602         /* we are processing a member, and we must handle all pointers
5603          * do we need descriptors for this member? */
5604         if (POINTERG(sptr) || ALLOCG(sptr) ||
5605 #ifdef USELENG
5606             USELENG(sptr) ||
5607 #endif
5608             (STYPEG(sptr) != ST_MEMBER && (ADJARRG(sptr) || RUNTIMEG(sptr)))) {
5609           get_static_descriptor(sptr);
5610           get_all_descriptors(sptr);
5611           SCP(sptr, SC_BASED);
5612         }
5613       }
5614     } else {
5615       sptr = create_var(sptr);
5616       SST_SYMP(LHS, sptr);
5617       stype1 = STYPEG(sptr);
5618       if (sem.kind_type_param) {
5619         USEKINDP(sptr, 1);
5620         KINDP(sptr, sem.kind_type_param);
5621       }
5622       if (sem.len_type_param) {
5623         USELENP(sptr, 1);
5624         LENP(sptr, sem.len_type_param);
5625       }
5626 
5627       if (DTY(sem.stag_dtype) == TY_DERIVED && sem.class) {
5628         /* TBD - Probably need to fix this condition when we
5629          * support unlimited polymorphic entities.
5630          */
5631         if (SCG(sptr) == SC_DUMMY || POINTERG(sptr) || ALLOCG(sptr)) {
5632           CLASSP(sptr, 1); /* mark polymorphic variable */
5633           if (PASSBYVALG(sptr)) {
5634             error(155, 3, gbl.lineno, "Polymorphic variable cannot have VALUE "
5635                                       "attribute -",
5636                   SYMNAME(sptr));
5637           }
5638           if (DTY(sem.stag_dtype) == TY_DERIVED) {
5639             int tag = DTY(sem.stag_dtype + 3);
5640             if (CFUNCG(tag)) {
5641               error(155, 3, gbl.lineno,
5642                     "Polymorphic variable cannot be declared "
5643                     "with a BIND(C) derived type - ",
5644                     SYMNAME(sptr));
5645             }
5646             if (SEQG(tag)) {
5647               error(155, 3, gbl.lineno,
5648                     "Polymorphic variable cannot be declared "
5649                     "with a SEQUENCE derived type - ",
5650                     SYMNAME(sptr));
5651             }
5652           }
5653 
5654         } else {
5655           error(155, 3, gbl.lineno, "Polymorphic variable must be a pointer, "
5656                                     "allocatable, or dummy object - ",
5657                 SYMNAME(sptr));
5658         }
5659       }
5660       if (DTY(sem.stag_dtype) == TY_DERIVED && sem.which_pass) {
5661         if (!(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) &&
5662             SCG(sptr) != SC_DUMMY && !FVALG(sptr) && gbl.rutype != RU_PROG) {
5663           add_auto_finalize(sptr);
5664         }
5665       }
5666       if (dtype == 0)
5667         dtype = DTYPEG(sptr);
5668       /* Assertion:
5669        *  stype  = stype we want to make symbol {ARRAY,STRUCT,or IDENT}
5670        *	stype1 = symbol's current stype
5671        */
5672       if (stype == ST_ARRAY) {
5673         if (IS_INTRINSIC(stype1)) {
5674           /* Changing intrinsic symbol to ARRAY */
5675           if ((sptr = newsym(sptr)) == 0)
5676             /* Symbol frozen as an intrinsic, ignore type decl */
5677             break;
5678           SST_SYMP(LHS, sptr);
5679           /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5680           stype1 = ST_UNKNOWN;
5681         } else
5682           switch (stype1) {
5683           case ST_UNKNOWN:
5684           case ST_IDENT:
5685           case ST_VAR:
5686           case ST_STRUCT:
5687             break;
5688           case ST_ENTRY:
5689             if (DTY(DTYPEG(sptr)) != TY_ARRAY)
5690               break;
5691             error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5692             goto dcl_shared_end;
5693           case ST_ARRAY: {
5694             /* if symbol is already an array, check if the
5695              * dimension specifiers are identical.
5696              */
5697             ADSC *ad1, *ad2;
5698             int ndim;
5699 
5700             ad1 = AD_DPTR(DTYPEG(sptr));
5701             ad2 = AD_DPTR(dtype);
5702             ndim = AD_NUMDIM(ad1);
5703             if (ndim != AD_NUMDIM(ad2)) {
5704               error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5705               goto dcl_shared_end;
5706             }
5707             for (i = 0; i < ndim; i++)
5708               if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) ||
5709                   AD_UPBD(ad1, i) != AD_UPBD(ad2, i))
5710                 break;
5711             if (i < ndim) {
5712               error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5713               goto dcl_shared_end;
5714             }
5715           }
5716             error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
5717             break;
5718           default:
5719             error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5720             goto dcl_shared_end;
5721           }
5722         DTY(dtype + 1) = DTYPEG(sptr);
5723       } else if (stype == ST_STRUCT) {
5724         if (IS_INTRINSIC(stype1)) {
5725           /* Changing intrinsic symbol to STRUCT */
5726           if ((sptr = newsym(sptr)) == 0)
5727             /* Symbol frozen as an intrinsic, ignore type decl */
5728             break;
5729           SST_SYMP(LHS, sptr);
5730           /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5731           stype1 = ST_UNKNOWN;
5732         } else if (stype1 == ST_ARRAY && DCLDG(sptr) == 0) {
5733           /* this case is OK */
5734         } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT) {
5735           error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5736           break;
5737         }
5738       } else if ((scn.stmtyp == TK_COMMON || scn.stmtyp == TK_POINTER) &&
5739                  IS_INTRINSIC(stype1)) {
5740         /* Changing intrinsic symbol to IDENT in COMMON/POINTER */
5741         if ((sptr = newsym(sptr)) == 0)
5742           /* Symbol frozen as an intrinsic, ignore in COMMON */
5743           break;
5744         SST_SYMP(LHS, sptr);
5745         /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5746         stype1 = ST_UNKNOWN;
5747         dtype = DTYPEG(sptr);
5748       } else if (IN_MODULE_SPEC && !sem.interface && IS_INTRINSIC(stype1)) {
5749         /* Changing intrinsic symbol to IDENT in module specification */
5750         if ((sptr = newsym(sptr)) == 0)
5751           /* Symbol frozen as an intrinsic, ignore in COMMON */
5752           break;
5753         SST_SYMP(LHS, sptr);
5754         /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5755         stype1 = ST_UNKNOWN;
5756         dtype = DTYPEG(sptr);
5757       }
5758       /*
5759        * The symbol's stype and data type can only be changed if
5760        * it is new or if the type is changing from an identifier or
5761        * structure to an array.  The latter can occur because of the
5762        * separation of type/record declarations from DIMENSION/COMMON
5763        * statements.  If the symbol is a record, its stype can change
5764        * only if it's an identifier; note, that its dtype will be
5765        * set (and checked) by the semantic actions for record.
5766        */
5767       if (stype1 == ST_UNKNOWN ||
5768           (stype == ST_ARRAY &&
5769            (stype1 == ST_IDENT || stype1 == ST_VAR || stype1 == ST_STRUCT))) {
5770         STYPEP(sptr, stype);
5771         DTYPEP(sptr, dtype);
5772         if (DTY(dtype) == TY_ARRAY) {
5773           int d;
5774           d = DTY(dtype + 1);
5775           if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
5776             error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5777           }
5778         }
5779         if (stype == ST_ARRAY) {
5780           if (POINTERG(sptr)) {
5781             if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
5782               error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5783             if (SCG(sptr) != SC_DUMMY)
5784               ALLOCP(sptr, 1);
5785             if (!F90POINTERG(sptr)) {
5786               get_static_descriptor(sptr);
5787               get_all_descriptors(sptr);
5788             }
5789           } else if (AD_ASSUMSZ(ad)) {
5790             if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY &&
5791                 SCG(sptr) != SC_BASED)
5792               error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5793             ASUMSZP(sptr, 1);
5794             SEQP(sptr, 1);
5795           }
5796           if (AD_ADJARR(ad)) {
5797             ADJARRP(sptr, 1);
5798             /*
5799              * mark the adjustable array if the declaration
5800              * occurs after an ENTRY statement.
5801              */
5802             if (entry_seen)
5803               AFTENTP(sptr, 1);
5804           } else if (!POINTERG(sptr) && AD_DEFER(ad)) {
5805             if (SCG(sptr) == SC_CMBLK)
5806               error(43, 3, gbl.lineno, "deferred shape array", SYMNAME(sptr));
5807             if (SCG(sptr) == SC_DUMMY) {
5808               mk_assumed_shape(sptr);
5809               ASSUMSHPP(sptr, 1);
5810               if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
5811                 SDSCS1P(sptr, 1);
5812             } else {
5813               if (AD_ASSUMSHP(ad)) {
5814                 /* this is an error if it isn't a dummy; the
5815                  * declaration could occur before its entry, so
5816                  * the check needs to be performed in semfin.
5817                  */
5818                 ASSUMSHPP(sptr, 1);
5819                 if (!XBIT(54, 2))
5820                   SDSCS1P(sptr, 1);
5821               }
5822               ALLOCP(sptr, 1);
5823               mk_defer_shape(sptr);
5824             }
5825           }
5826         }
5827       } else if (sem.gdtype != -1 && DTY(sem.gdtype) == TY_DERIVED) {
5828         if (stype1 == ST_ENTRY) {
5829           if (FVALG(sptr)) {
5830 /* should not reach this point */
5831 #if DEBUG
5832             interr("semant1: trying to set data type of ST_ENTRY", sptr, 3);
5833 #endif
5834             sptr = FVALG(sptr);
5835           } else {
5836             error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr));
5837             sptr = insert_sym(sptr);
5838           }
5839         }
5840         if (stype == ST_ARRAY && RESULTG(sptr)) {
5841           DTYPEP(sptr, dtype);
5842           if (POINTERG(sptr)) {
5843             if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
5844               error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5845           } else if (AD_ASSUMSZ(ad)) {
5846             ASUMSZP(sptr, 1);
5847             SEQP(sptr, 1);
5848           } else if (AD_ADJARR(ad))
5849             ADJARRP(sptr, 1);
5850           else if (AD_DEFER(ad)) {
5851             mk_assumed_shape(sptr);
5852             ASSUMSHPP(sptr, 1);
5853             if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
5854               SDSCS1P(sptr, 1);
5855             AD_ASSUMSHP(ad) = 1;
5856           }
5857           copy_type_to_entry(sptr);
5858         }
5859       } else if (stype == ST_STRUCT && stype1 == ST_IDENT)
5860         STYPEP(sptr, ST_STRUCT);
5861       else if (stype == ST_ARRAY) {
5862         if (stype1 == ST_ENTRY) {
5863           if (FVALG(sptr)) {
5864 /* should not reach this point */
5865 #if DEBUG
5866             interr("semant1: trying to set data type of ST_ENTRY", sptr, 3);
5867 #endif
5868             sptr = FVALG(sptr);
5869           } else {
5870             error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr));
5871             sptr = insert_sym(sptr);
5872           }
5873         }
5874         if (RESULTG(sptr)) {
5875           DTYPEP(sptr, dtype);
5876           if (POINTERG(sptr)) {
5877             if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
5878               error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5879           } else if (AD_ASSUMSZ(ad)) {
5880             ASUMSZP(sptr, 1);
5881             SEQP(sptr, 1);
5882           } else if (AD_ADJARR(ad))
5883             ADJARRP(sptr, 1);
5884           else if (AD_DEFER(ad)) {
5885             mk_assumed_shape(sptr);
5886             ASSUMSHPP(sptr, 1);
5887             if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
5888               SDSCS1P(sptr, 1);
5889             AD_ASSUMSHP(ad) = 1;
5890           }
5891           copy_type_to_entry(sptr);
5892         }
5893       }
5894     }
5895   dcl_shared_end:
5896     if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER &&
5897         RESULTG(sptr)) {
5898       /* set the type for the entry point as well */
5899       copy_type_to_entry(sptr);
5900     }
5901     break;
5902 
5903   /* ------------------------------------------------------------------ */
5904   /*
5905    *      <dim beg> ::= (
5906    */
5907   case DIM_BEG1:
5908     sem.in_dim = 1;
5909     sem.arrdim.ndim = 0;
5910     sem.arrdim.ndefer = 0;
5911     break;
5912 
5913   /* ------------------------------------------------------------------ */
5914   /*
5915    *      <dimension list> ::= <dim list>
5916    */
5917   case DIMENSION_LIST1:
5918 
5919     sem.in_dim = 0;
5920     dtype = mk_arrdsc(); /* semutil2.c */
5921     SST_DTYPEP(LHS, dtype);
5922     break;
5923   /* ------------------------------------------------------------------ */
5924   /*
5925    *      <dim list> ::= <dim list> , <dim spec> |
5926    */
5927   case DIM_LIST1:
5928     break;
5929   /*
5930    *      <dim list> ::= <dim spec>
5931    */
5932   case DIM_LIST2:
5933     break;
5934 
5935   /* ------------------------------------------------------------------ */
5936   /*
5937    *      <dim spec> ::= <explicit shape> |
5938    */
5939   case DIM_SPEC1:
5940     break;
5941   /*
5942    *      <dim spec> ::= <expression> : *  |
5943    */
5944   case DIM_SPEC2:
5945     rhstop = 3;
5946     SST_IDP(RHS(3), S_STAR);
5947     goto dim_spec;
5948   /*
5949    *      <dim spec> ::= *
5950    */
5951   case DIM_SPEC3:
5952     rhstop = 1;
5953     SST_IDP(RHS(1), S_STAR);
5954   dim_spec:
5955     if (sem.arrdim.ndim >= 7) {
5956       error(47, 3, gbl.lineno, CNULL, CNULL);
5957       break;
5958     }
5959 
5960     /* check upper bound expression */
5961     constarraysize = 1;
5962     arraysize = 0;
5963 
5964     constant_lvalue(RHS(rhstop));
5965     if (SST_IDG(RHS(rhstop)) == S_CONST) {
5966       sem.bounds[sem.arrdim.ndim].uptype = S_CONST;
5967       if (flg.standard) {
5968         int uptyp;
5969         uptyp = SST_DTYPEG(RHS(rhstop));
5970         if (!DT_ISINT(uptyp)) {
5971           error(170, 2, gbl.lineno, "array upper bound", "is not integer");
5972         }
5973       }
5974       arraysize = sem.bounds[sem.arrdim.ndim].upb =
5975           chkcon_to_isz(RHS(rhstop), FALSE);
5976       sem.bounds[sem.arrdim.ndim].upast = mk_bnd_int(SST_ASTG(RHS(rhstop)));
5977     } else if (SST_IDG(RHS(rhstop)) == S_STAR) {
5978       constarraysize = 0;
5979       sem.bounds[sem.arrdim.ndim].uptype = S_STAR;
5980       sem.bounds[sem.arrdim.ndim].upb = 0;
5981       sem.bounds[sem.arrdim.ndim].upast = 0;
5982     } else {
5983       constarraysize = 0;
5984       sem.bounds[sem.arrdim.ndim].uptype = S_EXPR;
5985       sem.bounds[sem.arrdim.ndim].upb =
5986           chk_arr_extent(RHS(rhstop), "array upper bound");
5987       ast = SST_ASTG(RHS(rhstop));
5988       if (A_ALIASG(ast)) {
5989         ast = mk_bnd_int(A_ALIASG(ast));
5990         sem.bounds[sem.arrdim.ndim].uptype = S_CONST;
5991         sem.bounds[sem.arrdim.ndim].upb = get_isz_cval(A_SPTRG(ast));
5992       } else {
5993         /* When we have an AST with A_CONV, we want to skip the type
5994            conversion AST in order to process the real intrinsic-call AST.*/
5995         if (A_TYPEG(ast) == A_CONV) {
5996           if (A_LOPG(ast) && A_TYPEG(A_LOPG(ast)) == A_INTR)
5997             ast = A_LOPG(ast);
5998         }
5999         if (*astb.atypes[A_TYPEG(ast)] == 'i' &&
6000           DT_ISINT(A_DTYPEG(ast)) && ast_isparam(ast)) {
6001           INT conval;
6002           ACL *acl = construct_acl_from_ast(ast, A_DTYPEG(ast), 0);
6003           if (acl) {
6004             acl = eval_init_expr(acl);
6005             conval = cngcon(acl->conval, acl->dtype, A_DTYPEG(ast));
6006             ast = mk_cval1(conval, (int)A_DTYPEG(ast));
6007             SST_IDP(RHS(1), S_CONST);
6008             SST_LSYMP(RHS(1), 0);
6009             SST_ASTP(RHS(1), ast);
6010             SST_ACLP(RHS(1), 0);
6011             if (DT_ISWORD(A_DTYPEG(ast)))
6012               SST_SYMP(RHS(1), CONVAL2G(A_SPTRG(ast)));
6013             else
6014               SST_SYMP(RHS(1), A_SPTRG(ast));
6015           }
6016         }
6017       }
6018       sem.bounds[sem.arrdim.ndim].upast = ast;
6019     }
6020 
6021     /* check lower bound expression */
6022 
6023     if (rhstop == 1) { /* set default lower bound */
6024       sem.bounds[sem.arrdim.ndim].lowtype = S_CONST;
6025       sem.bounds[sem.arrdim.ndim].lowb = 1;
6026       sem.bounds[sem.arrdim.ndim].lwast = 0;
6027     } else {
6028       constant_lvalue(RHS(1));
6029       if (SST_IDG(RHS(1)) == S_CONST) {
6030         sem.bounds[sem.arrdim.ndim].lowtype = S_CONST;
6031         if (flg.standard) {
6032           int lowtyp;
6033           lowtyp = SST_DTYPEG(RHS(1));
6034           if (!DT_ISINT(lowtyp)) {
6035             error(170, 2, gbl.lineno, "array lower bound", "is not integer");
6036           }
6037         }
6038         sem.bounds[sem.arrdim.ndim].lowb = chkcon_to_isz(RHS(1), FALSE);
6039         if (constarraysize)
6040           arraysize -= (sem.bounds[sem.arrdim.ndim].lowb - 1);
6041         sem.bounds[sem.arrdim.ndim].lwast = mk_bnd_int(SST_ASTG(RHS(1)));
6042       } else {
6043         constarraysize = 0;
6044         sem.bounds[sem.arrdim.ndim].lowtype = S_EXPR;
6045         sem.bounds[sem.arrdim.ndim].lowb =
6046             chk_arr_extent(RHS(1), "array lower bound");
6047         ast = SST_ASTG(RHS(1));
6048         if (A_ALIASG(ast)) {
6049           ast = mk_bnd_int(A_ALIASG(ast));
6050           sem.bounds[sem.arrdim.ndim].lowtype = S_CONST;
6051           sem.bounds[sem.arrdim.ndim].lowb = get_isz_cval(A_SPTRG(ast));
6052         }
6053         sem.bounds[sem.arrdim.ndim].lwast = ast;
6054       }
6055     }
6056     if (constarraysize && arraysize <= 0) {
6057       error(435, 2, gbl.lineno, "", CNULL);
6058       if (arraysize < 0) {
6059         /*
6060          * fix the upper bound to be lowb-1 so that the extent
6061          * evaluates to 0 so that the relatively new error #219,
6062          * 'Array too large' produced by dtypeutl.c:size_of_sym()
6063          * is avoided.
6064          */
6065         sem.bounds[sem.arrdim.ndim].upb = sem.bounds[sem.arrdim.ndim].lowb - 1;
6066         sem.bounds[sem.arrdim.ndim].upast =
6067             mk_isz_cval(sem.bounds[sem.arrdim.ndim].upb, astb.bnd.dtype);
6068       }
6069     }
6070     sem.arrdim.ndim++;
6071     break;
6072   /*
6073    *      <dim spec> ::= : |
6074    */
6075   case DIM_SPEC4:
6076     if (sem.arrdim.ndim >= 7) {
6077       error(47, 3, gbl.lineno, CNULL, CNULL);
6078       break;
6079     }
6080     sem.bounds[sem.arrdim.ndim].lowtype = 0;
6081     sem.arrdim.ndim++;
6082     sem.arrdim.ndefer++;
6083     break;
6084   /*
6085    *      <dim spec> ::= <expression> :
6086    */
6087   case DIM_SPEC5:
6088     if (sem.arrdim.ndim >= 7) {
6089       error(47, 3, gbl.lineno, CNULL, CNULL);
6090       break;
6091     }
6092     sem.bounds[sem.arrdim.ndim].lowtype = S_EXPR;
6093     (void)chk_scalartyp(RHS(1), astb.bnd.dtype, FALSE);
6094     sem.bounds[sem.arrdim.ndim].lwast = SST_ASTG(RHS(1));
6095     sem.arrdim.ndim++;
6096     sem.arrdim.ndefer++;
6097     break;
6098 
6099   /* ------------------------------------------------------------------ */
6100   /*
6101    *	<explicit shape> ::= <expression> : <expression> |
6102    */
6103   case EXPLICIT_SHAPE1:
6104     rhstop = 3;
6105     goto dim_spec;
6106   /*
6107    *	<explicit shape> ::= <expression>
6108    */
6109   case EXPLICIT_SHAPE2:
6110     rhstop = 1;
6111     goto dim_spec;
6112 
6113   /* ------------------------------------------------------------------ */
6114   /*
6115    *      <implicit type> ::= <implicit list> |
6116    */
6117   case IMPLICIT_TYPE1:
6118     break;
6119   /*
6120    *      <implicit type> ::= NONE
6121    */
6122   case IMPLICIT_TYPE2:
6123     if (sem.none_implicit & host_present)
6124       errwarn(55);
6125     if (seen_implicit || seen_parameter)
6126       error(70, 3, gbl.lineno, ": implicit none", CNULL);
6127     else
6128       symutl.none_implicit = sem.none_implicit |= host_present;
6129     newimplicitnone();
6130     if (sem.interface == 0) {
6131       ast_implicit(0, 0, 0);
6132       if (IN_MODULE_SPEC)
6133         mod_implicit(0, 0, 0);
6134     }
6135     break;
6136 
6137   /* ------------------------------------------------------------------ */
6138   /*
6139    *      <implicit list> ::= <implicit list> , <data type> <implp> <range list>
6140    * ) |
6141    */
6142   case IMPLICIT_LIST1:
6143   /*
6144    *      <implicit list> ::= <data type> <implp> <range list> )
6145    */
6146   case IMPLICIT_LIST2:
6147     if (sem.none_implicit & host_present)
6148       errwarn(56);
6149     seen_implicit = TRUE;
6150     break;
6151 
6152   /* ------------------------------------------------------------------ */
6153   /*
6154    *      <range list> ::= <range list> , <range> |
6155    */
6156   case RANGE_LIST1:
6157     rhstop = 3;
6158     goto range_list;
6159   /*
6160    *      <range list> ::= <range>
6161    */
6162   case RANGE_LIST2:
6163     rhstop = 1;
6164   range_list:
6165     begin = SST_RNG1G(RHS(rhstop));
6166     end = SST_RNG2G(RHS(rhstop));
6167     if (begin > end) {
6168       errwarn(36);
6169       end = begin;
6170     }
6171     if (flg.standard && (begin == '$' || begin == '_' || end == 0))
6172       errwarn(175);
6173     newimplicit(begin, end, sem.gdtype);
6174     if (sem.interface == 0) {
6175       ast_implicit(begin, end, sem.gdtype);
6176       if (IN_MODULE_SPEC)
6177         mod_implicit(begin, end, sem.gdtype);
6178     }
6179 
6180     /* adjust dtype of function and dummy arguments if necessary */
6181 
6182     for (sptr = gbl.currsub; sptr && sptr != NOSYM; sptr = SYMLKG(sptr)) {
6183       if (gbl.rutype == RU_FUNC) {
6184         if (FVALG(sptr) && !DCLDG(FVALG(sptr))) {
6185           setimplicit(FVALG(sptr));
6186           copy_type_to_entry(FVALG(sptr));
6187         }
6188       }
6189 
6190       count = PARAMCTG(sptr);
6191       i = DPDSCG(sptr);
6192       while (count--) {
6193         sptr2 = *(aux.dpdsc_base + i + count);
6194         if (!DCLDG(sptr2))
6195           setimplicit(sptr2);
6196       }
6197     }
6198     break;
6199 
6200   /* ------------------------------------------------------------------ */
6201   /*
6202    *      <range> ::= <letter> - <letter> |
6203    */
6204   case RANGE1:
6205     begin = SST_RNG1G(RHS(1));
6206     end = SST_RNG1G(RHS(3));
6207     if (begin == '$' || begin == '_' || end == '$' || end == '_') {
6208       /* cause an error and no action at the next production up */
6209       end = 0;
6210     }
6211     SST_RNG2P(LHS, end);
6212     break;
6213   /*
6214    *      <range> ::= <letter>
6215    */
6216   case RANGE2:
6217     SST_RNG2P(LHS, SST_RNG1G(RHS(1)));
6218     break;
6219 
6220   /* ------------------------------------------------------------------ */
6221   /*
6222    *      <common list> ::= <common list> <com dcl> |
6223    */
6224   case COMMON_LIST1:
6225     break;
6226   /*
6227    *      <common list> ::= <init com dcl>
6228    */
6229   case COMMON_LIST2:
6230     break;
6231 
6232   /* ------------------------------------------------------------------ */
6233   /*
6234    *      <init com dcl> ::= <dcl id list> |
6235    */
6236   case INIT_COM_DCL1:
6237   /*
6238    *      <init com dcl> ::= <dcl id list> , |
6239    */
6240   case INIT_COM_DCL2:
6241     rhsptr = 1;
6242     goto blank_common;
6243   /*
6244    *      <init com dcl> ::= <com dcl>
6245    */
6246   case INIT_COM_DCL3:
6247     break;
6248 
6249   /* ------------------------------------------------------------------ */
6250   /*
6251    *      <com dcl> ::= '//' <dcl id list> <optional comma>   |
6252    */
6253   case COM_DCL1:
6254     rhsptr = 2;
6255     goto blank_common;
6256   /*
6257    *	<com dcl> ::= / / <dcl id list> <optional comma>   |
6258    */
6259   case COM_DCL2:
6260     rhsptr = 3;
6261     goto blank_common;
6262   blank_common:
6263     if (ignore_common_decl()) {
6264       break;
6265     }
6266     sptr = getsymbol("_BLNK_");
6267     sptr = refsym_inscope(sptr, OC_CMBLK);
6268     if (flg.xref)
6269       xrefput(sptr, 'd');
6270     if (STYPEG(sptr) == ST_UNKNOWN) {
6271       STYPEP(sptr, ST_CMBLK);
6272       SCOPEP(sptr, stb.curr_scope);
6273       SAVEP(sptr, 1);
6274       BLANKCP(sptr, 1);
6275     }
6276     goto com_dcl;
6277   /*
6278    *      <com dcl> ::= <common> <dcl id list> <optional comma>
6279    */
6280   case COM_DCL3:
6281     if (ignore_common_decl()) {
6282       break;
6283     }
6284     rhsptr = 2;
6285     sptr = SST_SYMG(RHS(1));
6286   com_dcl:
6287     if (CMEMFG(sptr) == 0) {
6288       /* first definition of this common block */
6289       {
6290         SYMLKP(sptr, gbl.cmblks); /* link into list of common blocks */
6291         gbl.cmblks = sptr;
6292       }
6293       i = 0;
6294       CMEMFP(sptr, NOSYM);
6295       CMEMLP(sptr, NOSYM);
6296     } else
6297       i = CMEMLG(sptr); /* last element of common block so far */
6298 
6299     /* loop thru dcl id list linking together symbol table entries */
6300     for (itemp = SST_BEGG(RHS(rhsptr)); itemp != ITEM_END;
6301          itemp = itemp->next) {
6302       sptr2 = itemp->t.sptr;
6303       stype = STYPEG(sptr2);
6304       if (IS_INTRINSIC(stype)) {
6305         /*
6306          * an intrinsic which can be changed due to its appearance in a
6307          * COMMON statement has already been processed in dcl_shared.
6308          * Getting here implies that the intrinsic is frozen, and
6309          * therefore, it will be ignored in the COMMON stmt.
6310          */
6311         error(40, 3, gbl.lineno, SYMNAME(sptr2), CNULL);
6312         break;
6313       } else if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_VAR &&
6314                  stype != ST_ARRAY && stype != ST_STRUCT &&
6315                  (!POINTERG(sptr2))) {
6316         error(40, 3, gbl.lineno, SYMNAME(sptr2), CNULL);
6317         reinit_sym(sptr2);
6318         STYPEP(sptr2, ST_VAR);
6319         DTYPEP(sptr2, DT_INT);
6320         SCP(sptr2, SC_LOCAL);
6321       }
6322       if (SCG(sptr2) == SC_CMBLK || SCG(sptr2) == SC_DUMMY)
6323         error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr2));
6324       else if (stype == ST_ARRAY && (ASUMSZG(sptr2) || ADJARRG(sptr2)))
6325         error(50, 3, gbl.lineno, SYMNAME(sptr2), CNULL);
6326       else if (SAVEG(sptr2)) {
6327         error(39, 2, gbl.lineno, SYMNAME(sptr2), " and a COMMON statement");
6328         SAVEP(sptr2, 0);
6329       } else {
6330         SCP(sptr2, SC_CMBLK);
6331         CMBLKP(sptr2, sptr);
6332         if (i == 0)
6333           CMEMFP(sptr, sptr2);
6334         else
6335           SYMLKP(i, sptr2);
6336         SYMLKP(sptr2, NOSYM);
6337       }
6338       i = sptr2;
6339     }
6340     CMEMLP(sptr, i); /* point to last element of common block */
6341     break;
6342 
6343   /* ------------------------------------------------------------------ */
6344   /*
6345    *      <common> ::= / <ident> /
6346    */
6347   case COMMON1:
6348     if (ignore_common_decl()) {
6349       SST_SYMP(LHS, 0);
6350       break;
6351     }
6352     sptr = refsym_inscope((int)SST_SYMG(RHS(2)), OC_CMBLK);
6353     if (STYPEG(sptr) == ST_UNKNOWN) {
6354       STYPEP(sptr, ST_CMBLK);
6355       SCOPEP(sptr, stb.curr_scope);
6356     }
6357     SST_SYMP(LHS, sptr);
6358     break;
6359 
6360   /* ------------------------------------------------------------------ */
6361   /*
6362    *      <save list> ::= <save list> , <save id> |
6363    */
6364   case SAVE_LIST1:
6365     if (flg.xref)
6366       xrefput((int)SST_SYMG(RHS(3)), 'd');
6367     break;
6368   /*
6369    *      <save list> ::= <save id>
6370    */
6371   case SAVE_LIST2:
6372     if (flg.xref)
6373       xrefput((int)SST_SYMG(RHS(1)), 'd');
6374     break;
6375 
6376   /* ------------------------------------------------------------------ */
6377   /*
6378    *      <save id> ::= <common>
6379    */
6380   case SAVE_ID1:
6381     sptr = SST_SYMG(RHS(1));
6382     SAVEP(sptr, 1);
6383     break;
6384   /*
6385    *      <save id> ::= <ident>
6386    */
6387   case SAVE_ID2:
6388     sptr = ref_ident_inscope((int)SST_SYMG(RHS(1)));
6389     stype = STYPEG(sptr);
6390 
6391     /* <ident> must be a variable or an array; it cannot be a dummy
6392      * argument or common block member.
6393      */
6394     if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) {
6395       if (ASUMSZG(sptr))
6396         error(155, 3, gbl.lineno,
6397               "An assumed-size array cannot have the SAVE attribute -",
6398               SYMNAME(sptr));
6399       else if (SCG(sptr) == SC_DUMMY)
6400         error(155, 3, gbl.lineno,
6401               "An adjustable array cannot have the SAVE attribute -",
6402               SYMNAME(sptr));
6403       else
6404         error(155, 3, gbl.lineno,
6405               "An automatic array cannot have the SAVE attribute -",
6406               SYMNAME(sptr));
6407     } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
6408                 SCG(sptr) == SC_BASED) &&
6409                (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
6410                 stype == ST_IDENT)) {
6411       sem.savloc = TRUE;
6412       SAVEP(sptr, 1);
6413       /* SCP(sptr, SC_LOCAL);
6414        * SAVE is now an attribute and may appear allocatable; the
6415        * appearance of a variable in a SAVE statement is no longer
6416        * sufficient to define the variable's storage class.
6417        */
6418     } else
6419       error(39, 2, gbl.lineno, SYMNAME(sptr), CNULL);
6420     break;
6421 
6422   /* ------------------------------------------------------------------ */
6423   /*
6424    *      <ideqc list> ::= <ideqc list> , <ident> <init beg> <expression> |
6425    */
6426   case IDEQC_LIST1:
6427     rhstop = 5;
6428     goto common_ideqc;
6429   /*
6430    *      <ideqc list> ::= <ident> <init beg> <expression>
6431    */
6432   case IDEQC_LIST2:
6433     rhstop = 3;
6434   common_ideqc:
6435     SST_IDP(RHS(rhstop - 2), S_IDENT);
6436     sptr = SST_SYMG(RHS(rhstop - 2));
6437 
6438     fixup_param_vars(RHS(rhstop - 2), RHS(rhstop));
6439     if (DTY(DTYPEG(sptr)) == TY_ARRAY || DTY(DTYPEG(sptr)) == TY_DERIVED) {
6440       sptr1 = CONVAL1G(sptr);
6441 
6442       construct_acl_for_sst(RHS(rhstop), DTYPEG(sptr1));
6443       if (!SST_ACLG(RHS(rhstop))) {
6444         goto end_ideqc;
6445       }
6446       CONVAL2P(sptr, put_getitem_p(save_acl(SST_ACLG(RHS(rhstop)))));
6447 
6448       ast = mk_id(sptr1);
6449       SST_ASTP(RHS(rhstop - 2), ast);
6450       SST_DTYPEP(RHS(rhstop - 2), DTYPEG(sptr1));
6451       SST_SHAPEP(RHS(rhstop - 2), A_SHAPEG(ast));
6452       ivl = dinit_varref(RHS(rhstop - 2));
6453 
6454       dinit(ivl, SST_ACLG(RHS(rhstop)));
6455     }
6456 
6457   end_ideqc:
6458     if (flg.xref)
6459       xrefput(sptr, 'i');
6460     sem.dinit_data = FALSE;
6461     break;
6462 
6463   /* ------------------------------------------------------------------ */
6464   /*
6465    *	<init beg> ::= =
6466    */
6467   case INIT_BEG1:
6468     sem.dinit_data = TRUE;
6469     break;
6470 
6471   /* ------------------------------------------------------------------ */
6472   /*
6473    *      <vxeqc list> ::= <vxeqc list> , <ident> = <expression> |
6474    */
6475   case VXEQC_LIST1:
6476     rhstop = 5;
6477     goto common_vxeqc;
6478   /*
6479    *      <vxeqc list> ::= <ident> = <expression>
6480    */
6481   case VXEQC_LIST2:
6482     rhstop = 3;
6483   common_vxeqc:
6484     sptr = declsym((int)SST_SYMG(RHS(rhstop - 2)), ST_PARAM, TRUE);
6485     dtype = SST_DTYPEG(RHS(rhstop));
6486     if (DCLDG(sptr) && dtype != DTYPEG(sptr))
6487       error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
6488 
6489     if (SCG(sptr) != SC_NONE) {
6490       error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
6491       break;
6492     }
6493 
6494     constant_lvalue(RHS(rhstop));
6495     if (SST_IDG(RHS(rhstop)) == S_CONST)
6496       conval = SST_CVALG(RHS(rhstop));
6497     else {
6498       errsev(87);
6499       dtype = DT_INT;
6500       conval = 1;
6501     }
6502     TYPDP(sptr, DCLDG(sptr));              /* appeared in a type statement */
6503     CONVAL2P(sptr, SST_ASTG(RHS(rhstop))); /* ast of <expression> */
6504     DTYPEP(sptr, dtype);
6505     DCLDP(sptr, TRUE);
6506     CONVAL1P(sptr, conval);
6507     VAXP(sptr, 1); /* vax-style parameter */
6508     if (sem.interface == 0)
6509       add_param(sptr);
6510     /* create an ast for the parameter; set the alias field of the ast
6511      * so that we don't have to set the alias field whenever the parameter
6512      * is referenced.
6513      */
6514     ast = mk_id(sptr);
6515     alias = mk_cval1(CONVAL1G(sptr), (int)DTYPEG(sptr));
6516     A_ALIASP(ast, alias);
6517     if (flg.xref)
6518       xrefput(sptr, 'i');
6519     break;
6520 
6521   /* ------------------------------------------------------------------ */
6522   /*
6523    *	<enums> ::= <enums> , <enum> |
6524    */
6525   case ENUMS1:
6526     break;
6527   /*
6528    *	<enums> ::= <enum>
6529    */
6530   case ENUMS2:
6531     break;
6532 
6533   /* ------------------------------------------------------------------ */
6534   /*
6535    *	<enum> ::= <ident> = <expression> |
6536    */
6537   case ENUM1:
6538     rhstop = 3;
6539     constant_lvalue(RHS(rhstop));
6540     conval = chkcon(RHS(rhstop), DT_INT4, TRUE);
6541     goto common_enum;
6542   /*
6543    *	<enum> ::= <ident>
6544    */
6545   case ENUM2:
6546     conval = next_enum;
6547   common_enum:
6548     dtype = DT_INT4;
6549     ast = mk_cval(conval, dtype);
6550     sptr = declsym((int)SST_SYMG(RHS(1)), ST_PARAM, TRUE);
6551     if (DCLDG(sptr) || SCG(sptr) != SC_NONE) {
6552       error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
6553       break;
6554     }
6555     TYPDP(sptr, DCLDG(sptr)); /* appeared in a type statement */
6556     CONVAL2P(sptr, ast);      /* ast of <expression> */
6557     DTYPEP(sptr, dtype);
6558     DCLDP(sptr, TRUE);
6559     CONVAL1P(sptr, conval);
6560     ast = mk_id(sptr);
6561     alias = mk_cval1(CONVAL1G(sptr), (int)DTYPEG(sptr));
6562     A_ALIASP(ast, alias);
6563     next_enum = conval + 1;
6564     if (flg.xref)
6565       xrefput(sptr, 'i');
6566     break;
6567 
6568   /* ------------------------------------------------------------------ */
6569   /*
6570    *      <equiv groups> ::= <equiv groups> , <equiv group> |
6571    */
6572   case EQUIV_GROUPS1:
6573     break;
6574   /*
6575    *      <equiv groups> ::= <equiv group>
6576    */
6577   case EQUIV_GROUPS2:
6578     break;
6579 
6580   /* ------------------------------------------------------------------ */
6581   /*
6582    *      <equiv group> ::= ( <equiv list> )
6583    */
6584   case EQUIV_GROUP1:
6585     /*
6586      * equivalence groups are linked together using the same field
6587      * used to link equivalence items within a single group.
6588      * A single equiv group is defined by the list beginning with an
6589      * EQVV item with a non-zero line number and ending with the item
6590      * preceding the next EQVV item with a non-zero line number (or
6591      * ending with the last item in the list).  The remaining
6592      * members in the group have line number fields which are zero.
6593      */
6594     if (sem.interface) /* HACK - throw away if in an interface block*/
6595       break;
6596     EQV(SST_NMLENDG(RHS(2))).next = sem.eqvlist;
6597     sem.eqvlist = SST_NMLBEGG(RHS(2));
6598     break;
6599 
6600   /* ------------------------------------------------------------------ */
6601   /*
6602    *      <equiv list> ::= <equiv list> , <equiv var> |
6603    */
6604   case EQUIV_LIST1:
6605     rhstop = 3;
6606     goto common_equiv;
6607   /*
6608    *      <equiv list> ::= <equiv var>
6609    */
6610   case EQUIV_LIST2:
6611     rhstop = 1;
6612   common_equiv:
6613     if (sem.interface) /* HACK - throw away if in an interface block*/
6614       break;
6615     evp = sem.eqv_avail;
6616     ++sem.eqv_avail;
6617     NEED(sem.eqv_avail, sem.eqv_base, EQVV, sem.eqv_size, sem.eqv_size + 20);
6618     EQV(evp).sptr = SST_SYMG(RHS(rhstop));
6619     EQV(evp).subscripts = SST_SUBSCRIPTG(RHS(rhstop));
6620     EQV(evp).substring = SST_SUBSTRINGG(RHS(rhstop));
6621     EQV(evp).byte_offset = SST_OFFSETG(RHS(rhstop));
6622     EQV(evp).next = 0;
6623     /* SEQP(evp->sptr, 1); -- SEQ flag set in semfin.c */
6624     if (flg.xref)
6625       xrefput(EQV(evp).sptr, 'e');
6626     if (rhstop == 1) {
6627       EQV(evp).lineno = gbl.lineno;
6628       EQV(evp).is_first = 1;
6629       SST_NMLBEGP(LHS, evp);
6630     } else {
6631       EQV(evp).lineno = 0;
6632       EQV(evp).is_first = 0;
6633       EQV(SST_NMLENDG(RHS(1))).next = evp;
6634     }
6635     SST_NMLENDP(LHS, evp);
6636     break;
6637 
6638   /* ------------------------------------------------------------------ */
6639   /*
6640    *      <equiv var> ::= <ident> |
6641    */
6642   case EQUIV_VAR1:
6643     sptr = ref_ident_inscope((int)SST_SYMG(RHS(1)));
6644     SST_SYMP(LHS, sptr);
6645     SST_SUBSCRIPTP(LHS, 0); /* No subscripting */
6646     SST_OFFSETP(LHS, 0);    /* No substringing */
6647     SST_SUBSTRINGP(LHS, 0); /* No substringing - ast */
6648     break;
6649   /*
6650    *      <equiv var> ::= <equiv var> ( <ssa list> ) |
6651    */
6652   case EQUIV_VAR2:
6653     /* Validate that the subscripts are constant expressions, and build
6654      * an item list of them in long term (until end of program) storage.
6655      */
6656     sptr = SST_SYMG(RHS(1));
6657     itemp = SST_BEGG(RHS(3));
6658     if (itemp->next == ITEM_END && SST_IDG(itemp->t.stkp) == S_TRIPLE) {
6659       if (SST_IDG(SST_E3G(itemp->t.stkp)) == S_NULL) {
6660         /* This is a possible form of a substring.  Vector triplet
6661          * notation is illegal in any form.
6662          */
6663         if (SST_OFFSETG(RHS(1)))
6664           error(144, 3, gbl.lineno, "Ugly equivalence ", "1");
6665         if (SST_IDG(SST_E1G(itemp->t.stkp)) == S_NULL) {
6666           i = 1;
6667           SST_SUBSTRINGP(LHS, 0);
6668         } else {
6669           i = chkcon(SST_E1G(itemp->t.stkp), DT_INT4, TRUE);
6670           if (i <= 0) {
6671             error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
6672             i = 0;
6673           }
6674           SST_SUBSTRINGP(LHS, SST_ASTG(SST_E1G(itemp->t.stkp)));
6675         }
6676         SST_OFFSETP(LHS, i);
6677         break;
6678       }
6679     }
6680 
6681     if (SST_SUBSCRIPTG(RHS(1)) != 0) {
6682       error(144, 3, gbl.lineno, "Ugly equivalence 3", CNULL);
6683       break;
6684     }
6685     ss = 0;
6686     numss = 0;
6687     for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) {
6688       if (ss == 0) {
6689         numss = 1;
6690         ss = sem.eqv_ss_avail;
6691         sem.eqv_ss_avail += 2;
6692         NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size,
6693              sem.eqv_ss_size + 50);
6694         SST_SUBSCRIPTP(LHS, ss); /* Save begin of subscript list */
6695         EQV_NUMSS(ss) = numss;
6696       } else {
6697         ++sem.eqv_ss_avail;
6698         NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size,
6699              sem.eqv_ss_size + 50);
6700         ++numss;
6701         EQV_NUMSS(ss) = numss;
6702       }
6703       if (SST_IDG(itemp->t.stkp) == S_KEYWORD) {
6704         /* <ident> = <expr> is illegal just use <expr> part */
6705         errsev(79);
6706         SST_SUBSCRIPTP(LHS, 0);
6707       } else if (SST_IDG(itemp->t.stkp) == S_TRIPLE) {
6708         /* Legally this can only mean character substringing.  Vector
6709          * triplet notation is not allowable in equivalencing.
6710          */
6711         error(155, 3, gbl.lineno,
6712               "Subscript triplet not allowed in EQUIVALENCE -", SYMNAME(sptr));
6713         SST_SUBSCRIPTP(LHS, 0);
6714       } else {
6715         (void)chkcon_to_isz(itemp->t.stkp, TRUE);
6716         EQV_SS(ss, numss - 1) = SST_ASTG(itemp->t.stkp);
6717       }
6718     }
6719     break;
6720   /*
6721    *      <equiv var> ::= <equiv var> . <ident>
6722    */
6723   case EQUIV_VAR3:
6724     SST_IDP(LHS, S_IDENT);
6725     SST_SYMP(LHS, 0);
6726     SST_SUBSCRIPTP(LHS, 0); /* No subscripting */
6727     SST_OFFSETP(LHS, 0);    /* No substringing */
6728     SST_SUBSTRINGP(LHS, 0); /* No substringing - ast */
6729     error(155, 3, gbl.lineno, "Member cannot be equivalenced -",
6730           SYMNAME(SST_SYMG(RHS(3))));
6731     break;
6732 
6733   /* ------------------------------------------------------------------ */
6734   /*
6735    *      <namelist groups> ::= <namelist groups> <namelist group> |
6736    */
6737   case NAMELIST_GROUPS1:
6738     break;
6739   /*
6740    *      <namelist groups> ::= <namelist group>
6741    */
6742   case NAMELIST_GROUPS2:
6743     break;
6744 
6745   /* ------------------------------------------------------------------ */
6746   /*
6747    *      <namelist group> ::= / <ident> / <namelist list>
6748    */
6749   case NAMELIST_GROUP1:
6750     sptr = declref((int)SST_SYMG(RHS(2)), ST_NML, 'd');
6751     if (DCLDG(sptr))
6752       NML_NEXT(CMEMLG(sptr)) = SST_NMLBEGG(RHS(4));
6753     else {
6754       SYMLKP(sptr, sem.nml);
6755       sem.nml = sptr;
6756       CMEMFP(sptr, SST_NMLBEGG(RHS(4)));
6757       DCLDP(sptr, TRUE);
6758       /* create the array representing the namelist group */
6759       (void)get_nml_array(sptr);
6760     }
6761     CMEMLP(sptr, SST_NMLENDG(RHS(4)));
6762     break;
6763 
6764   /* ------------------------------------------------------------------ */
6765   /*
6766    *      <namelist list> ::= <namelist list> <namelist var> |
6767    */
6768   case NAMELIST_LIST1:
6769     rhstop = 2;
6770     goto nml_list;
6771   /*
6772    *      <namelist list> ::= <namelist var>
6773    */
6774   case NAMELIST_LIST2:
6775     rhstop = 1;
6776   nml_list:
6777     i = aux.nml_avl++;
6778     NEED(aux.nml_avl, aux.nml_base, NMLDSC, aux.nml_size, aux.nml_size + 100);
6779     NML_SPTR(i) = SST_SYMG(RHS(rhstop));
6780     NML_NEXT(i) = 0;
6781     NML_LINENO(i) = gbl.lineno;
6782     if (rhstop == 1) /* first item in the list */
6783       SST_NMLBEGP(LHS, i);
6784     else /* add item to the end of the list */
6785       NML_NEXT(SST_NMLENDG(RHS(1))) = i;
6786     SST_NMLENDP(LHS, i); /* item is now the end of the list */
6787     break;
6788 
6789   /* ------------------------------------------------------------------ */
6790   /*
6791    *      <namelist var> ::= <ident> <optional comma>
6792    */
6793   case NAMELIST_VAR1:
6794     sptr = ref_ident((int)SST_SYMG(RHS(1)));
6795     SST_SYMP(LHS, sptr);
6796     /* equivalence processing is done before the namelist processing;
6797      * this order is necessary to accomodate adding members to a
6798      * common block by equivalencing.  For SC_LOCALs the namelist
6799      * processing switches the storage class to SC_STATIC; therefore,
6800      * the equivalence processor needs to know that a variable appeared
6801      * as a namelist item.
6802      */
6803     NMLP(sptr, 1);
6804     break;
6805 
6806   /* ------------------------------------------------------------------ */
6807   /*
6808    * <struct begin1> ::= |
6809    */
6810   case STRUCT_BEGIN11:
6811     sem.stag_dtype = get_type(6, TY_STRUCT, NOSYM);
6812     DTY(sem.stag_dtype + 3) = 0; /* no tag */
6813     if (sem.stsk_depth == 0)
6814       error(135, 2, gbl.lineno, CNULL, CNULL);
6815     break;
6816   /*
6817    *      <struct begin1> ::= / <ident> /
6818    */
6819   case STRUCT_BEGIN12:
6820     sptr = declsym((int)SST_SYMG(RHS(2)), ST_STAG, TRUE);
6821     sem.stag_dtype = get_type(6, TY_STRUCT, NOSYM);
6822     DTYPEP(sptr, sem.stag_dtype);   /* give tag its dtype */
6823     DTY(sem.stag_dtype + 3) = sptr; /* give dtype its tag */
6824     DTY(sem.stag_dtype + 5) = 0;    /* ict pointer */
6825     NESTP(sptr, INSIDE_STRUCT);     /* nested structure */
6826     /* NOTE: we don't set DCLD here; see ENDSTRUCTURE */
6827     break;
6828 
6829   /* ------------------------------------------------------------------ */
6830   /*
6831    *      <struct begin2> ::= |
6832    */
6833   case STRUCT_BEGIN21:
6834     SST_RNG2P(LHS, NOSYM);
6835     break;
6836   /*
6837    *      <struct begin2> ::= <field namelist>
6838    */
6839   case STRUCT_BEGIN22:
6840     break;
6841 
6842   /* ------------------------------------------------------------------ */
6843   /*
6844    *      <field namelist> ::= <field namelist> , <field name> |
6845    */
6846   case FIELD_NAMELIST1:
6847     SYMLKP(SST_SYMG(RHS(1)), SST_SYMG(RHS(3)));
6848     SST_SYMP(LHS, SST_SYMG(RHS(3)));
6849     break;
6850   /*
6851    *      <field namelist> ::= <field name>
6852    */
6853   case FIELD_NAMELIST2:
6854     /* Save ptr to 1st field name in field namelist */
6855     SST_RNG2P(LHS, SST_SYMG(RHS(1)));
6856     break;
6857 
6858   /* ------------------------------------------------------------------ */
6859   /*
6860    *      <field name> ::= <ident> |
6861    */
6862   case FIELD_NAME1:
6863     dtype = sem.stag_dtype;
6864     goto field_name;
6865   /*
6866    *      <field name> ::= <ident> <dim beg> <dimension list> )
6867    */
6868   case FIELD_NAME2:
6869     dtype = SST_DTYPEG(RHS(3));
6870     ad = AD_DPTR(dtype);
6871     if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))
6872       error(50, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
6873   field_name:
6874     stype = ST_MEMBER;
6875     sptr = SST_SYMG(RHS(1));
6876     if (STYPEG(sptr) != ST_UNKNOWN)
6877       SST_SYMP(LHS, (sptr = insert_sym(sptr)));
6878     SYMLKP(sptr, NOSYM);
6879     if (DTY(dtype) == TY_ARRAY)
6880       DTY(dtype + 1) = sem.stag_dtype;
6881     STYPEP(sptr, stype);
6882     DTYPEP(sptr, dtype);
6883     FNMLP(sptr, 1); /* declaration due to field name */
6884     break;
6885 
6886   /* ------------------------------------------------------------------ */
6887   /*
6888    *      <record list> ::= <record list> <record> |
6889    */
6890   case RECORD_LIST1:
6891     break;
6892   /*
6893    *      <record list> ::= <record>
6894    */
6895   case RECORD_LIST2:
6896     break;
6897 
6898   /* ------------------------------------------------------------------ */
6899   /*
6900    *      <record> ::= / <struct name> / <record namelist>
6901    */
6902   case RECORD1:
6903     break;
6904 
6905   /* ------------------------------------------------------------------ */
6906   /*
6907    *      <struct name> ::= <ident>
6908    */
6909   case STRUCT_NAME1:
6910     /* Make sure sym ptr on stack is to a structure tag */
6911     SST_SYMP(LHS, (sptr = declref((int)SST_SYMG(RHS(1)), ST_STAG, 'r')));
6912     if (!DCLDG(sptr)) {
6913       error(139, 3, gbl.lineno, SYMNAME(sptr), CNULL);
6914       dtype = get_type(6, TY_STRUCT, NOSYM);
6915       DTY(dtype + 2) = 1;    /* size */
6916       DTY(dtype + 3) = sptr; /* tag */
6917       DTY(dtype + 5) = 0;    /* ict pointer */
6918       DTYPEP(sptr, dtype);
6919       DCLDP(sptr, TRUE);
6920     }
6921     sem.stag_dtype = DTYPEG(sptr);
6922     break;
6923 
6924   /* ------------------------------------------------------------------ */
6925   /*
6926    *      <record namelist> ::= <record namelist> <record dcl> |
6927    */
6928   case RECORD_NAMELIST1:
6929     sptr = SST_SYMG(RHS(2));
6930     goto record_dcl;
6931   /*
6932    *      <record namelist> ::= <record dcl>
6933    */
6934   case RECORD_NAMELIST2:
6935     sptr = SST_SYMG(RHS(1));
6936   record_dcl:
6937     dtype = sem.stag_dtype;
6938     inited = FALSE;
6939     ict1 = (ACL *)get_getitem_p(DTY(dtype + 5));
6940     if (ict1) {
6941       /* Need to build an initializer constant tree */
6942       ict = GET_ACL(15);
6943       *ict = *ict1;
6944       ict->sptr = sptr;
6945       if (DTY(DTYPEG(sptr)) == TY_ARRAY)
6946         ict->repeatc = AD_NUMELM(AD_PTR(sptr));
6947       else
6948         ict->repeatc = astb.i1;
6949       if (INSIDE_STRUCT) {
6950         if (stsk->ict_end)
6951           stsk->ict_end->next = ict;
6952         else
6953           stsk->ict_beg = ict;
6954         stsk->ict_end = ict;
6955       } else if (SCG(sptr) != SC_DUMMY) {
6956         /*
6957          * NOTE: it's legal to use a STRUCTURE which contains
6958          * dinits to declare a dummy argument
6959          */
6960         dinit((VAR *)NULL, ict);
6961       }
6962     }
6963     goto common_typespecs;
6964 
6965   /* ------------------------------------------------------------------ */
6966   /*
6967    *      <record dcl> ::= <ident> <optional comma> |
6968    */
6969   case RECORD_DCL1:
6970     stype = ST_STRUCT;
6971     dtype = sem.stag_dtype;
6972     goto dcl_shared;
6973   /*
6974    *      <record dcl> ::= <ident> <dim beg> <dimension list> ) <optional comma>
6975    */
6976   case RECORD_DCL2:
6977     stype = ST_ARRAY;
6978     dtype = SST_DTYPEG(RHS(3));
6979     ad = AD_DPTR(dtype);
6980     goto dcl_shared;
6981 
6982   /* ------------------------------------------------------------------ */
6983   /*
6984    *      <vol list> ::= <vol list> , <vol id> |
6985    */
6986   case VOL_LIST1:
6987     break;
6988   /*
6989    *      <vol list> ::= <vol id>
6990    */
6991   case VOL_LIST2:
6992     break;
6993 
6994   /* ------------------------------------------------------------------ */
6995   /*
6996    *      <vol id> ::= <common> |
6997    */
6998   case VOL_ID1:
6999     sptr = SST_SYMG(RHS(1));
7000     VOLP(sptr, 1);
7001     break;
7002   /*
7003    *      <vol id> ::= <ident>
7004    */
7005   case VOL_ID2:
7006     sptr = ref_ident_inscope((int)SST_SYMG(RHS(1)));
7007     VOLP(sptr, 1);
7008     break;
7009 
7010   /* ------------------------------------------------------------------ */
7011   /*
7012    *      <dinit list> ::= <dinit list> <optional comma> <dinit> |
7013    */
7014   case DINIT_LIST1:
7015     break;
7016   /*
7017    *      <dinit list> ::= <dinit>
7018    */
7019   case DINIT_LIST2:
7020     break;
7021 
7022   /* ------------------------------------------------------------------ */
7023   /*
7024    *      <dinit> ::= <dinit var list> / <dinit const list> /
7025    */
7026   case DINIT1:
7027     /* call dinit to write data initialization records */
7028     if (!sem.dinit_error) {
7029       SST_CLBEGP(RHS(3),
7030                  rewrite_acl(SST_CLBEGG(RHS(3)), SST_CLBEGG(RHS(3))->dtype, 0));
7031       dinit(SST_VLBEGG(RHS(1)), SST_CLBEGG(RHS(3)));
7032     }
7033     sem.dinit_error = FALSE;
7034     sem.dinit_data = FALSE;
7035     break;
7036 
7037   /* ------------------------------------------------------------------ */
7038   /*
7039    *      <dinit var list> ::= <dinit var list> , <dinit var> |
7040    */
7041   case DINIT_VAR_LIST1:
7042     /* append entry to end of dinit var list */
7043     ((SST_VLENDG(RHS(1))))->next = SST_VLBEGG(RHS(3));
7044     SST_VLENDP(LHS, SST_VLENDG(RHS(3)));
7045     break;
7046   /*
7047    *      <dinit var list> ::= <dinit var>
7048    */
7049   case DINIT_VAR_LIST2:
7050     break;
7051 
7052   /* ------------------------------------------------------------------ */
7053   /*
7054    *      <dinit var> ::= <dvar ref> |
7055    */
7056   case DINIT_VAR1:
7057     (void)mklvalue(RHS(1), 2); /* ILM pointer of var ref */
7058     dtype = SST_DTYPEG(RHS(1));
7059     {
7060       /* build an element for the dinit var list */
7061       ivl = dinit_varref(RHS(1));
7062       if (ivl == NULL) {
7063         /* an array section was initialized -- dinit_varref()
7064          * transforms this <data var> into an implied do or a nested
7065          * implied do.
7066          */
7067         break;
7068       }
7069     }
7070     sem.dinit_data = TRUE;
7071     if (ivl->u.varref.id == S_LVALUE && SCG(SST_LSYMG(RHS(1))) == SC_BASED) {
7072       error(116, 3, gbl.lineno, SYMNAME(SST_LSYMG(RHS(1))), "(DATA)");
7073       sem.dinit_error = TRUE;
7074     }
7075     SST_VLBEGP(LHS, SST_VLENDP(LHS, ivl));
7076     break;
7077   /*
7078    *      <dinit var> ::= ( <dinit var list> , <ident> = <expression> ,
7079    * <expression> <e3> )
7080    */
7081   case DINIT_VAR2:
7082     (void)chk_scalartyp(RHS((9)), DT_INT, TRUE);
7083     /* build a doend element for the dinit var list */
7084     ivl = (VAR *)getitem(15, sizeof(VAR));
7085     SST_VLENDP(LHS, ivl);
7086     SST_VLENDG(RHS(2))->next = ivl;
7087     ivl->id = Doend;
7088     ivl->next = NULL;
7089 
7090     /* Create the dostart element, link it to the doend element, and
7091      * link all in the order dostart, <dinit var list>, then doend
7092      */
7093     ivl->u.doend.dostart = (VAR *)getitem(15, sizeof(VAR));
7094     ivl = ivl->u.doend.dostart;
7095     ivl->id = Dostart;
7096     sptr = refsym((int)SST_SYMG(RHS(4)), OC_OTHER);
7097     if (!DCLDG(sptr))
7098       IGNOREP(sptr, TRUE);
7099     SST_SYMP(RHS(4), sptr);
7100     (void)chktyp(RHS(4), DT_INT, TRUE);
7101     ivl->u.dostart.indvar = SST_ASTG(RHS(4));
7102     (void)chk_scalartyp(RHS(6), DT_INT, TRUE);
7103     ivl->u.dostart.lowbd = SST_ASTG(RHS(6));
7104     (void)chk_scalartyp(RHS(8), DT_INT, TRUE);
7105     ivl->u.dostart.upbd = SST_ASTG(RHS(8));
7106     ivl->u.dostart.step = SST_ASTG(RHS(9));
7107     ivl->next = SST_VLBEGG(RHS(2));
7108     SST_VLBEGP(LHS, ivl);
7109     break;
7110 
7111   /* ------------------------------------------------------------------ */
7112   /*
7113    *      <e3> ::=   |
7114    */
7115   case E31:
7116     SST_IDP(LHS, S_CONST);
7117     SST_CVALP(LHS, 1);
7118     SST_DTYPEP(LHS, DT_INT);
7119     SST_ASTP(LHS, 0);
7120     break;
7121   /*
7122    *      <e3> ::= , <expression>
7123    */
7124   case E32:
7125     *LHS = *RHS(2);
7126     break;
7127 
7128   /* ------------------------------------------------------------------ */
7129   /*
7130    *      <dinit const list> ::= <dinit const list> , <data item> |
7131    */
7132   case DINIT_CONST_LIST1:
7133     if (SST_CLBEGG(RHS(3)) != NULL) {
7134       SST_CLENDG(RHS(1))->next = SST_CLBEGG(RHS(3));
7135       SST_CLENDP(LHS, SST_CLENDG(RHS(3)));
7136     }
7137     break;
7138   /*
7139    *      <dinit const list> ::= <data item>
7140    */
7141   case DINIT_CONST_LIST2:
7142     break;
7143 
7144   /* ------------------------------------------------------------------ */
7145   /*
7146    *      <data item> ::= <data constant> |
7147    */
7148   case DATA_ITEM1:
7149     conval = 1; /* default repeat count */
7150     ast = 0;
7151     goto common_data_item;
7152   /*
7153    *      <data item> ::= <data rpt> * <data constant>
7154    */
7155   case DATA_ITEM2:
7156     ast = SST_ASTG(RHS(1));
7157     conval = SST_CVALG(RHS(1));
7158     *RHS(1) = *RHS(3);
7159   common_data_item:
7160     /*
7161      * Check for too many constant initializers here!  Why here and not in
7162      * dinit?  Because for structures and type decl stmts we want the error
7163      * flagged on the structure stmt not the record stmt which may occur
7164      * many times and much later.
7165      */
7166     if (!sem.dinit_data) { /* Don't do this if in DATA stmt */
7167       if (sem.dinit_count < conval) {
7168         if (sem.dinit_count >= 0)
7169           errsev(67);
7170         if (sem.dinit_count <= 0) { /* Error already handled */
7171           SST_CLBEGP(LHS, SST_CLENDP(LHS, NULL));
7172           break;
7173         }
7174         conval = sem.dinit_count; /* Put out as many as possible */
7175         sem.dinit_count = -1;     /* Prevent further error msgs */
7176       }
7177       sem.dinit_count -= conval;
7178     }
7179     if (SST_IDG(RHS(1)) == S_SCONST) {
7180       ict = dinit_struct_vals(SST_ACLG(RHS(1)), SST_DTYPEG(RHS(1)), NOSYM);
7181       if (!ict) {
7182         break;
7183       }
7184       ict->repeatc = ast;
7185       SST_CLBEGP(LHS, SST_CLENDP(LHS, ict));
7186       break;
7187     }
7188 
7189     /* allocate and init an Initializer Constant Tree entry */
7190     ict = GET_ACL(15);
7191     ict->id = AC_AST;
7192     ict->next = NULL;
7193     ict->subc = NULL;
7194     ict->u1.ast = SST_ASTG(RHS(1));
7195     ict->repeatc = ast;
7196     ict->sptr = 0;
7197     ict->dtype = SST_DTYPEG(RHS(1));
7198     SST_CLBEGP(LHS, SST_CLENDP(LHS, ict));
7199     break;
7200 
7201   /* ------------------------------------------------------------------ */
7202   /*
7203    *	<data rpt> ::= <integer> |
7204    */
7205   case DATA_RPT1:
7206     conval = SST_CVALG(RHS(1));
7207     ast = mk_cval(SST_CVALG(RHS(1)), DT_INT4);
7208     goto common_rpt;
7209   /*
7210    *	<data rpt> ::= <int kind const> |
7211    */
7212   case DATA_RPT2:
7213     /* token value of <int kind const> is an ST_CONST entry */
7214     conval = get_int_cval(SST_CVALG(RHS(1)));
7215     ast = mk_cnst(SST_CVALG(RHS(1)));
7216     goto common_rpt;
7217   /*
7218    *	<data rpt> ::= <ident constant>
7219    */
7220   case DATA_RPT3:
7221     dtype = SST_DTYPEG(RHS(1));
7222     if (dtype == DT_INT8 || dtype == DT_LOG8)
7223       conval = get_int_cval(SST_CVALG(RHS(1)));
7224     else
7225       conval = SST_CVALG(RHS(1));
7226     ast = SST_ASTG(RHS(1));
7227   common_rpt:
7228     if (conval < 0) {
7229       errsev(65);
7230       conval = 0;
7231     }
7232     SST_CVALP(LHS, conval);
7233     SST_ASTP(LHS, ast);
7234     break;
7235 
7236   /* ------------------------------------------------------------------ */
7237   /*
7238    *      <data constant> ::= <constant> |
7239    */
7240   case DATA_CONSTANT1:
7241     SST_IDP(LHS, S_CONST);
7242     break;
7243   /*
7244    *      <data constant> ::= <addop> <constant>  |
7245    */
7246   case DATA_CONSTANT2:
7247     SST_IDP(RHS(2), S_CONST);
7248     goto addop_data_constant;
7249   /*
7250    *      <data constant> ::= <ident constant> |
7251    */
7252   case DATA_CONSTANT3:
7253     break;
7254   /*
7255    *      <data constant> ::= <addop> <ident constant> |
7256    */
7257   case DATA_CONSTANT4:
7258   addop_data_constant:
7259     opc = SST_OPTYPEG(RHS(1));
7260     *LHS = *RHS(2);
7261     if (opc == OP_SUB) {
7262       SST_CVALP(LHS, negate_const(SST_CVALG(RHS(2)), (int)SST_DTYPEG(RHS(2))));
7263       ast = mk_unop(OP_SUB, SST_ASTG(RHS(2)), SST_DTYPEG(LHS));
7264       SST_ASTP(LHS, ast);
7265       mk_alias(ast, mk_cval1(SST_CVALG(LHS), (int)SST_DTYPEG(LHS)));
7266     }
7267     break;
7268   /*
7269    *	<data constant> ::= <ident ssa> ( <ssa list> ) |
7270    */
7271   case DATA_CONSTANT5:
7272     sptr = SST_SYMG(RHS(1));
7273     dtype = SST_DTYPEG(RHS(1));
7274     if (sem.in_struct_constr) {
7275       /* create head AC_SCONST for element list */
7276       aclp = GET_ACL(15);
7277       aclp->id = AC_SCONST;
7278       aclp->next = NULL;
7279       aclp->subc = (ACL *)SST_BEGG(RHS(3));
7280       aclp->dtype = dtype = DTYPEG(sem.in_struct_constr);
7281       SST_IDP(LHS, S_SCONST);
7282       SST_DTYPEP(LHS, dtype);
7283       SST_ACLP(LHS, aclp);
7284       if (is_empty_typedef(dtype)) {
7285         error(155, 3, gbl.lineno, "Structure constructor specified"
7286                                   " for empty derived type",
7287               SYMNAME(sptr));
7288       } else
7289         chk_struct_constructor(aclp);
7290       SST_SYMP(LHS, sem.in_struct_constr);  /* use tag as SYM */
7291       sem.in_struct_constr = SST_TMPG(LHS); /*restore old value */
7292       break;
7293     }
7294     sem.in_struct_constr = SST_TMPG(LHS); /* restore old value */
7295 
7296     if (STYPEG(sptr) == ST_PARAM && DTY(dtype) == TY_NCHAR) {
7297       SST *sp;
7298 
7299       itemp = SST_BEGG(RHS(3));
7300       sp = itemp->t.stkp;
7301       if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL ||
7302           itemp->next != ITEM_END) {
7303         error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7304         SST_DTYPEP(LHS, DT_NCHAR);
7305         val[0] = getstring(" ", 1);
7306         val[1] = 0;
7307         SST_CVALP(LHS, getcon(val, DT_NCHAR));
7308         SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS)));
7309         SST_SHAPEP(LHS, 0);
7310         break;
7311       }
7312       SST_IDP(LHS, S_CONST);
7313       SST_CVALP(LHS, CONVAL1G(sptr)); /* get constant sptr */
7314       SST_DTYPEP(LHS, dtype);
7315       SST_ASTP(LHS, CONVAL2G(sptr)); /* constant's ast */
7316       SST_SHAPEP(LHS, 0);
7317       SST_ERRSYMP(LHS, sptr); /* save for error tracing */
7318       ch_substring(LHS, SST_E1G(sp), SST_E2G(sp));
7319       goto check_data_substring;
7320     }
7321     if (STYPEG(sptr) == ST_PARAM && DTY(dtype) == TY_CHAR) {
7322       SST *sp;
7323 
7324       itemp = SST_BEGG(RHS(3));
7325       sp = itemp->t.stkp;
7326       if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL ||
7327           itemp->next != ITEM_END) {
7328         error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7329         SST_DTYPEP(LHS, DT_CHAR);
7330         SST_CVALP(LHS, getstring(" ", 1));
7331         SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS)));
7332         SST_SHAPEP(LHS, 0);
7333         break;
7334       }
7335       SST_IDP(LHS, S_CONST);
7336       SST_CVALP(LHS, CONVAL1G(sptr)); /* get constant sptr */
7337       SST_DTYPEP(LHS, dtype);
7338       SST_ASTP(LHS, CONVAL2G(sptr)); /* constant's ast */
7339       SST_SHAPEP(LHS, 0);
7340       SST_ERRSYMP(LHS, sptr); /* save for error tracing */
7341       ch_substring(LHS, SST_E1G(sp), SST_E2G(sp));
7342       goto check_data_substring;
7343     } else {
7344       errsev(87);
7345       sem.dinit_error = TRUE;
7346     }
7347     break;
7348   /*
7349    *	<data constant> ::= <ident ssa> ( ) |
7350    */
7351   case DATA_CONSTANT6:
7352     if (STYPEG(SST_SYMG(RHS(1))) != ST_PD ||
7353         PDNUMG(SST_SYMG(RHS(1))) != PD_null) {
7354       dtype = SST_DTYPEG(RHS(1));
7355       if (sem.in_struct_constr && is_empty_typedef(dtype)) {
7356         /* Ignore empty struct constructor for an
7357          * empty typedef
7358          */
7359         sem.dinit_error = TRUE;
7360         break;
7361       }
7362       errsev(87);
7363       sem.dinit_error = TRUE;
7364       break;
7365     }
7366     SST_IDP(RHS(1), S_IDENT);
7367     (void)mkvarref(RHS(1), ITEM_END);
7368     break;
7369 
7370   /*
7371    *	<data constant> ::= <substring>
7372    */
7373   case DATA_CONSTANT7:
7374     dtype = SST_DTYPEG(RHS(1));
7375   check_data_substring:
7376     constant_lvalue(RHS(1));
7377     if (SST_IDG(RHS(1)) != S_CONST) {
7378       errsev(87);
7379       sem.dinit_error = TRUE;
7380       if (DTY(dtype) == TY_NCHAR) {
7381         SST_DTYPEP(LHS, DT_NCHAR);
7382         val[0] = getstring(" ", 1);
7383         val[1] = 0;
7384         SST_CVALP(LHS, getcon(val, DT_NCHAR));
7385         SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS)));
7386         SST_SHAPEP(LHS, 0);
7387         break;
7388       }
7389       SST_DTYPEP(LHS, DT_CHAR);
7390       SST_CVALP(LHS, getstring(" ", 1));
7391       SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS)));
7392       SST_SHAPEP(LHS, 0);
7393     }
7394     break;
7395   /*
7396    *      <ident ssa> ::= <ident>
7397    */
7398   case IDENT_SSA1:
7399     sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
7400     dtype = DTYPEG(sptr);
7401     SST_SYMP(LHS, sptr);
7402     SST_DTYPEP(LHS, dtype);
7403     SST_TMPP(LHS, sem.in_struct_constr); /* save old value */
7404     /* set a flag for ssa list processing */
7405     if (STYPEG(sptr) == ST_TYPEDEF && DTY(dtype) == TY_DERIVED) {
7406       sem.in_struct_constr = sptr;
7407     } else
7408       sem.in_struct_constr = 0;
7409     break;
7410 
7411   /*
7412    *      <ident constant> ::= <ident>
7413    */
7414   case IDENT_CONSTANT1:
7415     sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
7416     SST_IDP(LHS, S_CONST);
7417     if (STYPEG(sptr) == ST_PARAM) {
7418       /* resolve constant */
7419       SST_DTYPEP(LHS, DTYPEG(sptr));
7420       SST_CVALP(LHS, CONVAL1G(sptr));
7421       ast = mk_id(sptr);
7422       if (!XBIT(49, 0x10)) /* preserve PARAMETER? */
7423         ast = A_ALIASG(ast);
7424     } else if (flg.standard)
7425       goto ident_constant_error;
7426     else {
7427       np = SYMNAME(sptr);
7428       if (*np == 't') {
7429         if (DTY(stb.user.dt_log) == TY_LOG8) {
7430           if (gbl.ftn_true == -1)
7431             val[0] = val[1] = -1;
7432           else {
7433             val[0] = 0;
7434             val[1] = 1;
7435           }
7436           SST_CVALP(LHS, getcon(val, DT_LOG8));
7437           ast = mk_cval1(SST_CVALG(LHS), DT_LOG);
7438         } else {
7439           SST_CVALP(LHS, SCFTN_TRUE);
7440           ast = mk_cval(SCFTN_TRUE, DT_LOG);
7441         }
7442         SST_DTYPEP(LHS, DT_LOG);
7443       } else if (*np == 'f') {
7444         if (DTY(stb.user.dt_log) == TY_LOG8) {
7445           val[0] = val[1] = 0;
7446           SST_CVALP(LHS, getcon(val, DT_LOG8));
7447           ast = mk_cval1(SST_CVALG(LHS), DT_LOG);
7448         } else {
7449           SST_CVALP(LHS, SCFTN_FALSE);
7450           ast = mk_cval(SCFTN_FALSE, DT_LOG);
7451         }
7452         SST_DTYPEP(LHS, DT_LOG);
7453       } else
7454         goto ident_constant_error;
7455     }
7456     SST_ASTP(LHS, ast);
7457     break;
7458   ident_constant_error:
7459     errsev(87);
7460     SST_CVALP(LHS, stb.i0);
7461     SST_DTYPEP(LHS, DT_INT4);
7462     ast = mk_id(sptr);
7463     sem.dinit_error = TRUE;
7464     break;
7465 
7466   /* ------------------------------------------------------------------ */
7467   /*
7468    *      <ptr list> ::= <ptr list> , <ptr assoc> |
7469    */
7470   case PTR_LIST1:
7471     break;
7472   /*
7473    *      <ptr list> ::= <ptr assoc>
7474    */
7475   case PTR_LIST2:
7476     break;
7477 
7478   /* ------------------------------------------------------------------ */
7479   /*
7480    *      <ptr assoc> ::= ( <ident> , <dcl id> ) |
7481    */
7482   case PTR_ASSOC1:
7483     sptr = declsym((int)SST_SYMG(RHS(2)), ST_VAR, FALSE);
7484     if (flg.standard)
7485       error(171, 2, gbl.lineno, "- Cray POINTER statement", CNULL);
7486     if (XBIT(124, 0x10)) {
7487       /* -i8 */
7488       if (DCLDG(sptr) && DTYPEG(sptr) != DT_INT8)
7489         error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7490       DTYPEP(sptr, DT_INT8);
7491     } else {
7492       if (DCLDG(sptr) && DTYPEG(sptr) != DT_PTR)
7493         error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7494       DTYPEP(sptr, DT_PTR);
7495     }
7496     DCLDP(sptr, TRUE);
7497     PTRVP(sptr, 1);
7498     sptr1 = SST_SYMG(RHS(4));
7499     if (VOLG(sptr1) || SCG(sptr1) != SC_NONE) {
7500       error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr1));
7501       break;
7502     }
7503     SCP(sptr1, SC_BASED);
7504     MIDNUMP(sptr1, sptr);
7505     if (SAVEG(sptr1))
7506       error(39, 2, gbl.lineno, SYMNAME(sptr1), CNULL);
7507     if (STYPEG(sptr1) == ST_ARRAY) {
7508       int dtype;
7509       ADSC *ad;
7510       if (ADJARRG(sptr1) || RUNTIMEG(sptr1)) {
7511         if (entry_seen)
7512           AFTENTP(sptr1, 1);
7513       }
7514     }
7515     while (TRUE) {
7516       if (SCG(sptr) == SC_BASED) {
7517         if (sptr == sptr1) {
7518           error(155, 3, gbl.lineno, "Recursive POINTER declaration of",
7519                 SYMNAME(sptr1));
7520           MIDNUMP(sptr1, 0);
7521           SCP(sptr1, SC_NONE);
7522           break;
7523         }
7524         sptr = MIDNUMG(sptr);
7525       } else
7526         break;
7527     }
7528     break;
7529   /*
7530    *	<ptr assoc> ::= <alloc id>
7531    */
7532   case PTR_ASSOC2:
7533     break;
7534 
7535   /* ------------------------------------------------------------------ */
7536   /*
7537    *	<alloc id list> ::= <alloc id list> , <alloc id> |
7538    */
7539   case ALLOC_ID_LIST1:
7540     break;
7541   /*
7542    *	<alloc id list> ::= <alloc id>
7543    */
7544   case ALLOC_ID_LIST2:
7545     break;
7546 
7547   /* ------------------------------------------------------------------ */
7548   /*
7549    *	<alloc id> ::= <ident> |
7550    */
7551   case ALLOC_ID1:
7552     sptr = SST_SYMG(RHS(1));
7553     sptr = create_var(sptr);
7554     SST_SYMP(LHS, sptr);
7555     if (STYPEG(sptr) == ST_UNKNOWN)
7556       STYPEP(sptr, ST_IDENT);
7557     stype1 = STYPEG(sptr);
7558     if (IS_INTRINSIC(stype1)) {
7559       /* Changing intrinsic symbol to ARRAY */
7560       if ((sptr = newsym(sptr)) == 0)
7561         /* Symbol frozen as an intrinsic, ignore type decl */
7562         break;
7563       SST_SYMP(LHS, sptr);
7564       /* Cause STYPE and DTYPE to change AFTER fixing dtype */
7565       stype1 = ST_UNKNOWN;
7566     } else if (stype1 == ST_ENTRY) {
7567       if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
7568         error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7569         break;
7570       }
7571     } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR &&
7572                stype1 != ST_ARRAY) {
7573       /* Add special handling for procedure pointers
7574        *
7575        * The only two ways we can get here is either through pointer or through
7576        * allocatable declaration. Pointer attribute can be applied to
7577        * procedures, but not allocatable attribute.
7578        */
7579       if ((scn.stmtyp != TK_POINTER) || (stype1 != ST_PROC)) {
7580         error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7581         break;
7582       }
7583     }
7584 
7585     if (scn.stmtyp == TK_POINTER) {
7586       POINTERP(sptr, TRUE);
7587       if (STYPEG(sptr) == ST_PROC) {
7588         LOGICAL declared;
7589         sptr = SST_SYMG(RHS(1));
7590         /* Save "declared" flag to preserve implicit types */
7591         declared = DCLDG(sptr);
7592         /* Generate proper procedure symbol */
7593         sptr = insert_sym(sptr);
7594         sptr = setup_procedure_sym(sptr, proc_interf_sptr, ET_B(ET_POINTER),
7595                                    entity_attr.access);
7596         SST_SYMP(RHS(1), sptr);
7597         /* Restore "declared" flag */
7598         DCLDP(sptr, declared);
7599       }
7600       if (sem.contiguous)
7601         CONTIGATTRP(sptr, 1);
7602       if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
7603         F90POINTERP(sptr, TRUE);
7604       }
7605       if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
7606         dtype = DTYPEG(sptr);
7607         ad = AD_DPTR(dtype);
7608         if (SCG(sptr) != SC_DUMMY) {
7609           if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
7610             error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7611           ALLOCP(sptr, 1);
7612         } else {
7613           if (!AD_DEFER(ad))
7614             error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7615           /* may have assumed the array was assumed-shape;
7616            * now we know better, it's an array pointer */
7617           ASSUMSHPP(sptr, 0);
7618           SDSCS1P(sptr, 0);
7619           AD_ASSUMSHP(ad) = 0;
7620         }
7621         if (!F90POINTERG(sptr)) {
7622           get_static_descriptor(sptr);
7623           get_all_descriptors(sptr);
7624         }
7625       }
7626     } else if ((stype1 != ST_ARRAY && stype1 != ST_IDENT
7627                 /* Allow ST_IDENT here.  It happens when an
7628                  * ALLOCATABLE statement precedes the DIMENSION statement.
7629                  * If the allocatable is still an ST_IDENT in semfin.c,
7630                  * we'll call it an error at that time.
7631                  */
7632                 ) ||
7633                (!ALLOCG(sptr) && stype1 != ST_IDENT) || SCG(sptr) != SC_NONE)
7634       error(84, 3, gbl.lineno, SYMNAME(sptr),
7635             "- must be a deferred shape array");
7636     else
7637       ALLOCATTRP(sptr, 1);
7638 
7639     if (RESULTG(sptr)) {
7640       /* set the type for the entry point as well */
7641       copy_type_to_entry(sptr);
7642     }
7643     break;
7644   /*
7645    *	<alloc id> ::= <ident> <dim beg> <dimension list> )
7646    */
7647   case ALLOC_ID2:
7648     sptr = SST_SYMG(RHS(1));
7649     sptr = create_var(sptr);
7650     SST_SYMP(LHS, sptr);
7651     if (STYPEG(sptr) == ST_UNKNOWN)
7652       STYPEP(sptr, ST_IDENT);
7653     stype1 = STYPEG(sptr);
7654     if (IS_INTRINSIC(stype1)) {
7655       /* Changing intrinsic symbol to ARRAY */
7656       if ((sptr = newsym(sptr)) == 0)
7657         /* Symbol frozen as an intrinsic, ignore type decl */
7658         break;
7659       SST_SYMP(LHS, sptr);
7660       /* Cause STYPE and DTYPE to change AFTER fixing dtype */
7661       stype1 = ST_UNKNOWN;
7662     } else if (stype1 == ST_ENTRY) {
7663       if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
7664         error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7665         break;
7666       }
7667     } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR) {
7668       error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7669       break;
7670     }
7671 
7672     STYPEP(sptr, ST_ARRAY);
7673     dtype = SST_DTYPEG(RHS(3));
7674     ad = AD_DPTR(dtype);
7675     DTY(dtype + 1) = DTYPEG(sptr);
7676     DTYPEP(sptr, dtype);
7677     if (DTY(dtype) == TY_ARRAY) {
7678       int d;
7679       d = DTY(dtype + 1);
7680       if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
7681         error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7682       }
7683     }
7684     if (scn.stmtyp == TK_POINTER) {
7685       if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
7686         error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7687       if (SCG(sptr) != SC_DUMMY)
7688         ALLOCP(sptr, 1);
7689       POINTERP(sptr, TRUE);
7690       if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
7691         F90POINTERP(sptr, TRUE);
7692       }
7693       if (SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
7694         get_static_descriptor(sptr);
7695         get_all_descriptors(sptr);
7696       }
7697     } else if (AD_DEFER(ad) == 0)
7698       error(84, 3, gbl.lineno, SYMNAME(sptr),
7699             "- must be a deferred shape array");
7700     else {
7701       ALLOCP(sptr, 1);
7702       ALLOCATTRP(sptr, 1);
7703       if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
7704         F90POINTERP(sptr, TRUE);
7705       }
7706     }
7707     if (RESULTG(sptr)) {
7708       /* set the type for the entry point as well */
7709       copy_type_to_entry(sptr);
7710     }
7711     break;
7712 
7713   /* ------------------------------------------------------------------ */
7714   /*
7715    *	<opt attr list> ::=  |
7716    */
7717   case OPT_ATTR_LIST1:
7718   /*
7719    *	<opt attr list> ::= , <attr list>
7720    */
7721   case OPT_ATTR_LIST2:
7722     in_entity_typdcl = TRUE;
7723     break;
7724 
7725   /* ------------------------------------------------------------------ */
7726   /*
7727    *	<attr list> ::= <attr list> , <attr> |
7728    */
7729   case ATTR_LIST1:
7730   /* fall thru */
7731   /*
7732    *	<attr list> ::= <attr>
7733    */
7734   case ATTR_LIST2:
7735     if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
7736       if (!(et_type == ET_DIMENSION || et_type == ET_POINTER
7737             || et_type == ET_ACCESS || et_type == ET_ALLOCATABLE ||
7738             et_type == ET_CONTIGUOUS || et_type == ET_KIND ||
7739             et_type == ET_LEN))
7740         error(134, 3, gbl.lineno, et[et_type].name,
7741               "for derived type component");
7742     }
7743     if (entity_attr.exist & ET_B(et_type))
7744       error(134, 3, gbl.lineno, "- duplicate", et[et_type].name);
7745     else if (entity_attr.exist & et[et_type].no)
7746       error(134, 3, gbl.lineno, "- conflict with", et[et_type].name);
7747     else {
7748       entity_attr.exist |= ET_B(et_type);
7749     }
7750     break;
7751 
7752   /* ------------------------------------------------------------------ */
7753   /*
7754    *	<attr> ::= PARAMETER     |
7755    */
7756   case ATTR1:
7757     et_type = ET_PARAMETER;
7758     break;
7759   /*
7760    *	<attr> ::= <access spec> |
7761    */
7762   case ATTR2:
7763     et_type = ET_ACCESS;
7764     break;
7765   /*
7766    *	<attr> ::= ALLOCATABLE   |
7767    */
7768   case ATTR3:
7769     et_type = ET_ALLOCATABLE;
7770     break;
7771   /*
7772    *	<attr> ::= <dimattr> <dim beg> <dimension list> ) |
7773    */
7774   case ATTR4:
7775     et_type = ET_DIMENSION;
7776     entity_attr.dimension = SST_DTYPEG(RHS(3));
7777     /* save bounds information just in case the dimension attribute
7778      * is used more than once
7779      */
7780     BCOPY(entity_attr.bounds, sem.bounds, char, sizeof(sem.bounds));
7781     BCOPY(entity_attr.arrdim, &sem.arrdim, char, sizeof(sem.arrdim));
7782     break;
7783   /*
7784    *	<attr> ::= EXTERNAL      |
7785    */
7786   case ATTR5:
7787     et_type = ET_EXTERNAL;
7788     break;
7789   /*
7790    *	<attr> ::= <intent> |
7791    */
7792   case ATTR6:
7793     et_type = ET_INTENT;
7794     break;
7795   /*
7796    *	<attr> ::= INTRINSIC     |
7797    */
7798   case ATTR7:
7799     et_type = ET_INTRINSIC;
7800     break;
7801   /*
7802    *	<attr> ::= OPTIONAL      |
7803    */
7804   case ATTR8:
7805     et_type = ET_OPTIONAL;
7806     break;
7807   /*
7808    *	<attr> ::= POINTER       |
7809    */
7810   case ATTR9:
7811     et_type = ET_POINTER;
7812     break;
7813   /*
7814    *	<attr> ::= SAVE          |
7815    */
7816   case ATTR10:
7817     et_type = ET_SAVE;
7818     break;
7819   /*
7820    *	<attr> ::= TARGET        |
7821    */
7822   case ATTR11:
7823     et_type = ET_TARGET;
7824     break;
7825   /*
7826    *	<attr> ::= AUTOMATIC     |
7827    */
7828   case ATTR12:
7829     et_type = ET_AUTOMATIC;
7830     break;
7831   /*
7832    *	<attr> ::= STATIC        |
7833    */
7834   case ATTR13:
7835     et_type = ET_STATIC;
7836     break;
7837   /*
7838    *      <attr> ::= BIND <bind attr>        |
7839    */
7840   case ATTR14:
7841     et_type = ET_BIND;
7842     break;
7843   /*
7844    *      <attr> ::= VALUE        |
7845    */
7846   case ATTR15:
7847     et_type = ET_VALUE;
7848     break;
7849   /*
7850    *      <attr> ::= VOLATILE     |
7851    */
7852   case ATTR16:
7853     et_type = ET_VOLATILE;
7854     break;
7855   /*
7856    *	<attr> ::= DEVICE        |
7857    */
7858   case ATTR17:
7859     if (cuda_enabled("device"))
7860       et_type = ET_DEVICE;
7861     else
7862       et_type = 0;
7863     break;
7864   /*
7865    *	<attr> ::= PINNED        |
7866    */
7867   case ATTR18:
7868     if (cuda_enabled("pinned"))
7869       et_type = ET_PINNED;
7870     else
7871       et_type = 0;
7872     break;
7873   /*
7874    *	<attr> ::= SHARED        |
7875    */
7876   case ATTR19:
7877     et_type = 0;
7878 #ifdef CUDAG
7879     if (cuda_enabled("shared")) {
7880       if ((gbl.currsub && CUDAG(gbl.currsub) &&
7881            !(CUDAG(gbl.currsub) & CUDA_HOST)) ||
7882           (gbl.currmod && !gbl.currsub)) {
7883         /* device routine, or module declaration part */
7884         et_type = ET_SHARED;
7885       } else {
7886         error(134, 3, gbl.lineno, et[ET_SHARED].name,
7887               "not allowed in host subprograms");
7888       }
7889     }
7890 #endif
7891     break;
7892   /*
7893    *	<attr> ::= CONSTANT |
7894    */
7895   case ATTR20:
7896     et_type = 0;
7897 #ifdef CUDAG
7898     if (cuda_enabled("constant")) {
7899       if ((gbl.currsub && CUDAG(gbl.currsub) &&
7900            !(CUDAG(gbl.currsub) & CUDA_HOST)) ||
7901           (gbl.currmod && !gbl.currsub)) {
7902         /* device routine, or module declaration part */
7903         et_type = ET_CONSTANT;
7904       } else {
7905         error(134, 3, gbl.lineno, et[ET_CONSTANT].name,
7906               "not allowed in host subprograms");
7907       }
7908     }
7909 #endif
7910     break;
7911   /*
7912    *	<attr> ::= PROTECTED |
7913    */
7914   case ATTR21:
7915     et_type = ET_PROTECTED;
7916     if (!IN_MODULE_SPEC) {
7917       error(155, 3, gbl.lineno,
7918             "PROTECTED may only appear in the specification part of a MODULE",
7919             CNULL);
7920     }
7921     break;
7922   /*
7923    *	<attr> ::= ASYNCHRONOUS
7924    */
7925   case ATTR22:
7926     et_type = ET_ASYNCHRONOUS;
7927     break;
7928   /*
7929    *	<attr> ::= ABSTRACT |
7930    */
7931   case ATTR23:
7932     /* anything here? */
7933     break;
7934   /*
7935    *	<attr> ::= TEXTURE
7936    */
7937   case ATTR24:
7938     if (cuda_enabled("texture"))
7939       et_type = ET_TEXTURE;
7940     else
7941       et_type = 0;
7942     break;
7943 
7944   /*
7945    *      <attr> ::= KIND |
7946    */
7947   case ATTR25:
7948     et_type = ET_KIND;
7949     break;
7950   /*
7951    *      <attr> ::= LEN |
7952    */
7953   case ATTR26:
7954     et_type = ET_LEN;
7955     break;
7956   /*
7957    *	<attr> ::= CONTIGUOUS |
7958    */
7959   case ATTR27:
7960     et_type = ET_CONTIGUOUS;
7961     break;
7962   /*
7963    *	<attr> ::= MANAGED |
7964    */
7965   case ATTR28:
7966     et_type = 0;
7967     if (cuda_enabled("managed")) {
7968 #if defined(TARGET_OSX)
7969       /* not supported */
7970       error(538, 3, gbl.lineno, CNULL, CNULL);
7971 #else
7972       /* supported */
7973       et_type = ET_MANAGED;
7974 #endif
7975     }
7976     break;
7977 
7978   /* ------------------------------------------------------------------ */
7979   /*
7980    *      <bind attr> ::= ( <id name> ) |
7981    */
7982   case BIND_ATTR1:
7983     /* see also FUNC_SUFFIX2 for a copy of this processing */
7984 
7985     bind_attr.exist = -1;
7986     bind_attr.altname = 0;
7987 
7988     np = scn.id.name + SST_CVALG(RHS(2));
7989     if (sem_strcmp(np, "c") != 0) {
7990       error(4, 3, gbl.lineno, "Illegal BIND -", np);
7991     } else {
7992       bind_attr.exist = DA_B(DA_C);
7993     }
7994 
7995     break;
7996   /*
7997    *      <bind attr> ::=  ( <id name> , <id name> = <quoted string> )
7998    */
7999   case BIND_ATTR2:
8000     np = scn.id.name + SST_CVALG(RHS(4));
8001     if (sem_strcmp(np, "name") != 0) {
8002       error(4, 3, gbl.lineno, "Illegal BIND syntax. Expecting: NAME Got:", np);
8003     }
8004 
8005     bind_attr.exist = -1;
8006     bind_attr.altname = 0;
8007 
8008     np = scn.id.name + SST_CVALG(RHS(2));
8009     if (sem_strcmp(np, "c") != 0) {
8010       error(4, 3, gbl.lineno, "Illegal BIND -", np);
8011     } else {
8012       bind_attr.exist = DA_B(DA_C) | DA_B(DA_ALIAS);
8013       bind_attr.altname = SST_SYMG(RHS(6)); // altname may be ""
8014     }
8015 
8016     break;
8017 
8018   /* ------------------------------------------------------------------ */
8019   /*
8020    *      <bind list> ::=  <bind list> , <bind entry> |
8021    */
8022   case BIND_LIST1:
8023     rhstop = 3;
8024     goto add_sym_to_bind_list;
8025     break;
8026   /*
8027    *      <bind list> ::= <bind entry>
8028    */
8029   case BIND_LIST2:
8030     break;
8031 
8032   /* ------------------------------------------------------------------ */
8033   /*
8034    *      <bind entry> ::= <common> |
8035    */
8036   case BIND_ENTRY1:
8037   /* fall through */
8038   /*
8039    *      <bind entry> ::= <id>
8040    */
8041   case BIND_ENTRY2:
8042     rhstop = 1;
8043   add_sym_to_bind_list:
8044     itemp = (ITEM *)getitem(0, sizeof(ITEM));
8045     itemp->next = ITEM_END;
8046     itemp->t.sptr = SST_SYMG(RHS(rhstop));
8047     itemp->ast = SST_ASTG(RHS(rhstop)); /* copied for <access> rules */
8048     if (rhstop == 1)
8049       /* adding first item to list */
8050       SST_BEGP(LHS, itemp);
8051     else
8052       /* adding subsequent items to list */
8053       SST_ENDG(RHS(1))->next = itemp;
8054     SST_ENDP(LHS, itemp);
8055     break;
8056 
8057   /* ------------------------------------------------------------------ */
8058   /*
8059    *	<opt type spec> ::= |
8060    */
8061   case OPT_TYPE_SPEC1:
8062     entity_attr.access = ' ';
8063     SST_CVALP(LHS, 0);
8064     break;
8065   /*
8066    *	<opt type spec> ::= , <type attr list>
8067    */
8068   case OPT_TYPE_SPEC2:
8069     SST_CVALP(LHS, SST_CVALG(RHS(2)));
8070     SST_LSYMP(LHS, SST_LSYMG(RHS(2)));
8071     break;
8072 
8073   /* ------------------------------------------------------------------ */
8074   /*
8075    *	<type attr list> ::= <type attr list> , <type attr> |
8076    */
8077   case TYPE_ATTR_LIST1:
8078     switch (SST_CVALG(RHS(1)) & SST_CVALG(RHS(3))) {
8079     case 0x1:
8080       error(134, 3, gbl.lineno, "- duplicate", et[ET_BIND].name);
8081       SST_CVALP(RHS(3), 0);
8082       break;
8083     case 0x2:
8084       error(134, 3, gbl.lineno, "- duplicate", et[ET_ACCESS].name);
8085       SST_CVALP(RHS(3), 0);
8086       break;
8087     case 0x4: /* type extension */
8088       error(134, 3, gbl.lineno, "- duplicate", et[ET_ACCESS].name);
8089       SST_CVALP(RHS(3), 0);
8090       break;
8091     }
8092     SST_CVALP(LHS, SST_CVALG(RHS(1)) | SST_CVALG(RHS(3)));
8093     if (SST_CVALG(RHS(3)) & 0x4)
8094       SST_LSYMP(LHS, SST_LSYMG(RHS(3)));
8095     break;
8096   /*
8097    *	<type attr list> ::= <type attr>
8098    */
8099   case TYPE_ATTR_LIST2:
8100     break;
8101 
8102   /* ------------------------------------------------------------------ */
8103   /*
8104    *	<type attr> ::= BIND <bind attr> |
8105    */
8106   case TYPE_ATTR1:
8107     /* struct types are already properly aligned for C compatibility;
8108      * pass up presence of BIND so that the type can be marked as
8109      * BIND(C) with the flag CFUNC.
8110      */
8111     SST_CVALP(LHS, 0x1);
8112     break;
8113   /*
8114    *	<type attr> ::= <access spec>
8115    */
8116   case TYPE_ATTR2:
8117     SST_CVALP(LHS, 0x2);
8118     break;
8119   /*
8120    *      <type attr> ::= EXTENDS ( <id> ) |
8121    */
8122   case TYPE_ATTR3:
8123     /* type extension */
8124     SST_CVALP(LHS, 0x4);
8125     sptr = SST_SYMG(RHS(3));
8126     while (STYPEG(sptr) == ST_ALIAS)
8127       sptr = SYMLKG(sptr);
8128     if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) {
8129       sptr = GTYPEG(sptr);
8130     }
8131     if (sptr > NOSYM && STYPEG(sptr) != ST_TYPEDEF) {
8132       int sym = findByNameStypeScope(SYMNAME(sptr), ST_TYPEDEF, -1);
8133       if (sym > NOSYM)
8134         sptr = sym;
8135     }
8136     if (DTY(DTYPEG(sptr)) != TY_DERIVED) {
8137       error(155, 4, gbl.lineno, "Invalid type extension", NULL);
8138     } else {
8139       /* Check for private type extension */
8140 
8141       int tag = DTY(DTYPEG(sptr) + 3);
8142       int tag_scope = SCOPEG(tag);
8143       int host_scope = stb.curr_scope;
8144 
8145       if (PRIVATEG(tag)) {
8146         if (STYPEG(tag_scope) == ST_MODULE && STYPEG(host_scope) != ST_MODULE)
8147           host_scope = SCOPEG(host_scope);
8148         if (tag_scope != host_scope)
8149           error(155, 3, gbl.lineno,
8150                 "Cannot extend type with PRIVATE attribute -", SYMNAME(tag));
8151       }
8152     }
8153     sem.extends = sptr;
8154     SST_LSYMP(LHS, sptr);
8155     break;
8156   /*
8157    *	<type attr> ::= ABSTRACT |
8158    */
8159   case TYPE_ATTR4:
8160     SST_CVALP(LHS, 0x8);
8161     break;
8162 
8163   /* ------------------------------------------------------------------ */
8164   /*
8165    *	<access spec> ::= PUBLIC  |
8166    */
8167   case ACCESS_SPEC1:
8168     entity_attr.access = 'u';
8169     if (!IN_MODULE_SPEC)
8170       ERR310("PUBLIC/PRIVATE may only appear in a MODULE scoping unit", CNULL);
8171     break;
8172   /*
8173    *	<access spec> ::= PRIVATE
8174    */
8175   case ACCESS_SPEC2:
8176     if (sem.type_mode == 2 && IN_MODULE_SPEC) {
8177       /* private seen in type bound procedure "contains" section */
8178       entity_attr.access = '0';
8179     } else
8180       entity_attr.access = 'v';
8181     if (!IN_MODULE_SPEC)
8182       ERR310("PUBLIC/PRIVATE may only appear in a MODULE scoping unit", CNULL);
8183     break;
8184 
8185   /* ------------------------------------------------------------------ */
8186   /*
8187    *	<access list> ::= <access list>, <access> |
8188    */
8189   case ACCESS_LIST1:
8190     rhstop = 3;
8191     goto add_sym_to_list;
8192   /*
8193    *	<access list> ::= <access>
8194    */
8195   case ACCESS_LIST2:
8196     rhstop = 1;
8197     goto add_sym_to_list;
8198 
8199   /* ------------------------------------------------------------------ */
8200   /*
8201    *	<access> ::= <ident> |
8202    */
8203   case ACCESS1:
8204     SST_ASTP(LHS, 0);
8205     break;
8206   /*
8207    *	<access> ::= <id name> ( <operator> ) |
8208    */
8209   case ACCESS2:
8210     np = scn.id.name + SST_CVALG(RHS(1));
8211     if (sem_strcmp(np, "operator") == 0)
8212       SST_SYMP(LHS, SST_LSYMG(RHS(3)));
8213     else {
8214       error(34, 3, gbl.lineno, np, CNULL);
8215       SST_SYMP(LHS, getsymbol(".34"));
8216     }
8217     SST_ASTP(LHS, 1); /* mark this as being from OPERATOR stmt */
8218     break;
8219   /*
8220    *	<access> ::= <id name> ( = )
8221    */
8222   case ACCESS3:
8223     np = scn.id.name + SST_CVALG(RHS(1));
8224     if (sem_strcmp(np, "assignment") == 0) {
8225       sptr = get_intrinsic_opr(OP_ST, 0);
8226       SST_SYMP(LHS, sptr);
8227     } else {
8228       error(34, 3, gbl.lineno, np, CNULL);
8229       SST_SYMP(LHS, getsymbol(".34"));
8230     }
8231     SST_ASTP(LHS, 1); /* treat as if from OPERATOR stmt */
8232     break;
8233 
8234   /* ------------------------------------------------------------------ */
8235   /*
8236    *	<seq> ::= SEQUENCE |
8237    */
8238   case SEQ1:
8239     if (!INSIDE_STRUCT || STSK_ENT(0).type != 'd') {
8240       error(155, 3, gbl.lineno,
8241             "SEQUENCE must appear in a derived type definition", CNULL);
8242     }
8243     SST_CVALP(LHS, 's');
8244     break;
8245   /*
8246    *	<seq> ::= NOSEQUENCE
8247    */
8248   case SEQ2:
8249     error(34, 3, gbl.lineno, "NOSEQUENCE", CNULL);
8250     SST_CVALP(LHS, 'n');
8251     break;
8252 
8253   /* ------------------------------------------------------------------ */
8254   /*
8255    *	<intent> ::= INTENT ( <id name> ) |
8256    */
8257   case INTENT1:
8258     np = scn.id.name + SST_CVALG(RHS(3));
8259     if (sem_strcmp(np, "in") == 0)
8260       entity_attr.intent = INTENT_IN;
8261     else if (sem_strcmp(np, "out") == 0)
8262       entity_attr.intent = INTENT_OUT;
8263     else if (sem_strcmp(np, "inout") == 0)
8264       entity_attr.intent = INTENT_INOUT;
8265     else {
8266       error(81, 3, gbl.lineno, "- illegal intent", np);
8267       entity_attr.intent = INTENT_DFLT;
8268     }
8269     break;
8270   /*
8271    *	<intent> ::= INTENT ( <id name> <id name> )
8272    */
8273   case INTENT2:
8274     np = scn.id.name + SST_CVALG(RHS(3));
8275     if (sem_strcmp(np, "in") == 0) {
8276       np = scn.id.name + SST_CVALG(RHS(4));
8277       if (sem_strcmp(np, "out") == 0)
8278         entity_attr.intent = INTENT_INOUT;
8279       else {
8280         error(81, 3, gbl.lineno, "- illegal intent in", np);
8281         entity_attr.intent = INTENT_DFLT;
8282       }
8283     } else {
8284       error(81, 3, gbl.lineno, "- illegal intent", np);
8285       entity_attr.intent = INTENT_DFLT;
8286     }
8287     break;
8288 
8289   /* ------------------------------------------------------------------ */
8290   /*
8291    *	<entity decl list> ::= <entity decl list> , <entity decl> |
8292    */
8293   case ENTITY_DECL_LIST1:
8294     rhstop = 3;
8295     goto add_entity_to_list;
8296   /*
8297    *	<entity decl list> ::= <entity decl>
8298    */
8299   case ENTITY_DECL_LIST2:
8300     rhstop = 1;
8301   add_entity_to_list:
8302     if (in_entity_typdcl) { /* only pass up list if hpf decls */
8303       SST_BEGP(LHS, ITEM_END);
8304       break;
8305     }
8306     itemp = (ITEM *)getitem(0, sizeof(ITEM));
8307     itemp->next = ITEM_END;
8308     itemp->t.sptr = SST_SYMG(RHS(rhstop));
8309     if (rhstop == 1)
8310       /* adding first item to list */
8311       SST_BEGP(LHS, itemp);
8312     else
8313       /* adding subsequent items to list */
8314       SST_ENDG(RHS(1))->next = itemp;
8315     SST_ENDP(LHS, itemp);
8316     break;
8317 
8318   /* ------------------------------------------------------------------ */
8319   /*
8320    *	<entity decl> ::= <entity id> |
8321    */
8322   case ENTITY_DECL1:
8323     /* only pass up sym if hpf decls */
8324     if (!in_entity_typdcl)
8325       break;
8326 
8327     inited = FALSE;
8328     goto entity_decl_shared;
8329   /*
8330    *	<entity decl> ::= <entity id> <init beg> <expression> |
8331    */
8332   case ENTITY_DECL2:
8333     if (!in_entity_typdcl) {
8334       error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
8335       break;
8336     }
8337     sptr = SST_SYMG(RHS(1));
8338     stype1 = STYPEG(sptr);
8339     if (IS_INTRINSIC(stype1)) {
8340       if ((sptr = newsym(sptr)) == 0)
8341         /* Symbol frozen as an intrinsic, ignore in COMMON */
8342         break;
8343       SST_SYMP(LHS, sptr);
8344     }
8345     inited = TRUE;
8346     sem.dinit_data = FALSE;
8347     goto entity_decl_shared;
8348   /*
8349    *	<entity decl> ::= <entity id> '=>' <id> ( )
8350    */
8351   case ENTITY_DECL3:
8352     if (!in_entity_typdcl) {
8353       error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
8354       break;
8355     }
8356     sptr = SST_SYMG(RHS(1));
8357     stype1 = STYPEG(sptr);
8358     if (IS_INTRINSIC(stype1)) {
8359       if ((sptr = newsym(sptr)) == 0)
8360         /* Symbol frozen as an intrinsic, ignore in COMMON */
8361         break;
8362       SST_SYMP(LHS, sptr);
8363     }
8364     sptr = SST_SYMG(RHS(3));
8365     sptr = refsym(sptr, OC_OTHER);
8366     SST_SYMP(RHS(3), sptr);
8367     SST_IDP(RHS(3), S_IDENT);
8368     sem.dinit_data = TRUE;
8369     (void)mkvarref(RHS(3), ITEM_END);
8370     sem.dinit_data = FALSE;
8371     inited = TRUE;
8372 
8373   entity_decl_shared:
8374     sptr = SST_SYMG(RHS(1));
8375     if (sem.new_param_dt) {
8376       dtype = DTYPEG(sptr);
8377       if (DTY(dtype) == TY_ARRAY) {
8378         DTY(dtype + 1) = sem.new_param_dt;
8379       } else {
8380         DTYPEP(sptr, sem.new_param_dt);
8381       }
8382       fix_type_param_members(sptr, sem.new_param_dt);
8383     }
8384 
8385     if (!sem.interface)
8386       add_type_param_initialize(sptr);
8387 
8388     if (sem.class && sem.type_mode &&
8389         !(entity_attr.exist & (ET_B(ET_ALLOCATABLE) | ET_B(ET_POINTER)))) {
8390       error(155, 3, gbl.lineno, "CLASS component must be "
8391                                 "allocatable or pointer -",
8392             SYMNAME(sptr));
8393     }
8394     sem.gdtype = SST_GDTYPEG(RHS(1));
8395     sem.gty = SST_GTYG(RHS(1));
8396     if (flg.xref)
8397       xrefput(sptr, 'd');
8398     dtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
8399                      lenspec[1].propagated, sptr);
8400     if (DCLDG(sptr) && !RESULTG(sptr) && !IS_INTRINSIC(STYPEG(sptr))) {
8401       switch (STYPEG(sptr)) {
8402       /*  any cases for which a data type does not apply */
8403       case ST_MODULE:
8404       case ST_NML:
8405         error(44, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8406         break;
8407       default:
8408         /* data type for ident has already been specified */
8409         if (DDTG(DTYPEG(sptr)) == dtype)
8410           error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
8411         else
8412           error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8413       }
8414       /* to avoid setting symbol table entry's stype field */
8415       goto entity_decl_end;
8416     } else {
8417       switch (STYPEG(sptr)) {
8418       /* any cases for which a type must be identical to the variable's
8419        * implicit type.
8420        */
8421       case ST_PARAM:
8422         if (!(entity_attr.exist & ET_B(ET_PARAMETER)) && DTYPEG(sptr) != dtype)
8423           error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8424         break;
8425       default:
8426         break;
8427       }
8428     }
8429     /*
8430      * Finalize the dtype of the variable.
8431      * Determine the tentative stype we want give to the variable if
8432      * it's still ST_UNKNOWN or ST_IDENT.
8433      */
8434     DCLDP(sptr, TRUE);
8435     set_char_attributes(sptr, &dtype);
8436 
8437     if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
8438       if (sem.new_param_dt && has_type_parameter(DTY(DTYPEG(sptr) + 1))) {
8439         /* Make sure we use the new parameterized dtype */
8440         dtype = sem.new_param_dt;
8441       }
8442       DTY(DTYPEG(sptr) + 1) = dtype;
8443       if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) &&
8444           DISTMEMG(DTY(dtype + 3))) {
8445         error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8446       }
8447       dtype = DTYPEG(sptr);
8448     } else if (DTY(DTYPEG(sptr)) == TY_PTR &&
8449                DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC) {
8450       /* ptr to a function, set the func return value and the pointer flag */
8451       int func_dtype = DTY(DTYPEG(sptr) + 1);
8452       DTY(func_dtype + 5) = dtype;
8453     } else if (!USELENG(sptr) && !LENG(sptr)) {
8454       /* parameterized derived type TBD: array case???? */
8455       DTYPEP(sptr, (!sem.new_param_dt) ? dtype : sem.new_param_dt);
8456       if (SCG(sptr) == SC_DUMMY) {
8457         put_length_type_param(DTYPEG(sptr), 3);
8458       }
8459     }
8460     if (DTY(dtype) == TY_ARRAY)
8461       is_array = TRUE;
8462     else
8463       is_array = FALSE;
8464     is_member = FALSE;
8465     stype = STYPEG(sptr);
8466     if (stype == ST_MEMBER) {
8467       stype = 0;
8468       is_member = TRUE;
8469     } else if (stype == ST_ENTRY)
8470       stype = 0;
8471     else if (is_array)
8472       stype = ST_ARRAY;
8473     else if (DTY(dtype) == TY_STRUCT)
8474       stype = ST_STRUCT;
8475 
8476     no_init = FALSE;
8477     et_type = 0;
8478     et_bitv = entity_attr.exist;
8479     /* Loop through all assigned attributes */
8480     for (; et_bitv; et_bitv >>= 1, et_type++) {
8481       if ((et_bitv & 0x0001) == 0)
8482         continue;
8483       switch (et_type) {
8484       default:
8485         continue;
8486       case ET_ACCESS:
8487         if (sptr == ST_ARRAY && ADJARRG(sptr))
8488           error(84, 3, gbl.lineno, SYMNAME(sptr),
8489                 "- must not be an automatic array");
8490         else if (is_member) {
8491           if (entity_attr.access == 'v')
8492             PRIVATEP(sptr, 1);
8493           else
8494             PRIVATEP(sptr, 0);
8495         } else {
8496           accessp = (ACCL *)getitem(3, sizeof(ACCL));
8497           accessp->sptr = sptr;
8498           accessp->type = entity_attr.access;
8499           accessp->next = sem.accl.next;
8500           accessp->oper = ' ';
8501           sem.accl.next = accessp;
8502         }
8503         break;
8504       case ET_ALLOCATABLE:
8505         if (is_array) {
8506           ad = AD_DPTR(dtype);
8507           if (AD_DEFER(ad) == 0)
8508             error(84, 3, gbl.lineno, SYMNAME(sptr),
8509                   "- must be a deferred shape array");
8510           else {
8511             if (AD_ASSUMSHP(ad)) {
8512               /* this is an error if it isn't a dummy; the
8513                * declaration could occur before its entry, so
8514                * the check needs to be performed in semfin.
8515                */
8516               ASSUMSHPP(sptr, 1);
8517               if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
8518                 SDSCS1P(sptr, 1);
8519             }
8520             mk_defer_shape(sptr);
8521           }
8522         }
8523         ALLOCP(sptr, 1);
8524         ALLOCATTRP(sptr, 1);
8525         if (STYPEG(sptr) == ST_MEMBER) {
8526           ALLOCFLDP(DTY(ENCLDTYPEG(sptr) + 3), 1);
8527         }
8528 
8529         dtype = DTYPEG(sptr);
8530         if (DTY(dtype) == TY_ARRAY) {
8531           dtype = DTY(dtype + 1);
8532           if (sem.class)
8533             CLASSP(sptr, 1);
8534         }
8535         if (STYPEG(sptr) == ST_MEMBER && DTY(dtype) == TY_DERIVED &&
8536             has_finalized_component(sptr)) {
8537           FINALIZEDP(sptr, 1);
8538         }
8539         if (!(DTY(DTYPEG(sptr)) == TY_ARRAY && STYPEG(sptr) == ST_MEMBER) &&
8540             DTY(dtype) == TY_DERIVED) {
8541           /* Note: Do not execute this case for array
8542            * components since they already have a full array descriptor
8543            * embedded in the derived type.
8544            */
8545           if (sem.class)
8546             CLASSP(sptr, 1);
8547           set_descriptor_rank(TRUE);
8548           get_static_descriptor(sptr);
8549           set_descriptor_rank(FALSE);
8550 
8551           get_all_descriptors(sptr);
8552 
8553           if (SCG(sptr) != SC_DUMMY)
8554             SCP(sptr, SC_BASED);
8555           ALLOCDESCP(sptr, TRUE);
8556         } else if (SCG(sptr) == SC_DUMMY) {
8557           get_static_descriptor(sptr);
8558           get_all_descriptors(sptr);
8559         } else if (!INSIDE_STRUCT && SDSCG(sptr) == 0 &&
8560                    (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
8561                     DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) {
8562           if (SCG(sptr) != SC_DUMMY)
8563             SCP(sptr, SC_BASED); /* Don't change dummy */
8564           get_static_descriptor(sptr);
8565           get_all_descriptors(sptr);
8566           ALLOCDESCP(sptr, TRUE);
8567         } else {
8568           SCP(sptr, SC_BASED);
8569         }
8570         no_init = TRUE;
8571         break;
8572       case ET_CONTIGUOUS:
8573 #ifdef CONTIGATTRP
8574         CONTIGATTRP(sptr, 1);
8575 #endif
8576         break;
8577       case ET_DIMENSION:
8578         break;
8579       case ET_EXTERNAL:
8580         if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
8581           /* conflict with EXTERNAL */
8582           error(134, 3, gbl.lineno, "- array bounds not allowed with external",
8583                 SYMNAME(sptr));
8584         }
8585         /* Produce procedure symbol based on attributes */
8586         sptr = decl_procedure_sym(sptr, 0, entity_attr.exist);
8587         sptr =
8588             setup_procedure_sym(sptr, 0, entity_attr.exist, entity_attr.access);
8589         if (!TYPDG(sptr)) {
8590           TYPDP(sptr, 1);
8591           if (SCG(sptr) == SC_DUMMY) {
8592             IS_PROC_DUMMYP(sptr, 1);
8593           }
8594         }
8595         stype = 0;
8596         no_init = TRUE;
8597         break;
8598       case ET_INTENT:
8599         INTENTP(sptr, entity_attr.intent);
8600         if (sem.interface) {
8601           if (SCG(sptr) != SC_DUMMY) {
8602             error(134, 3, gbl.lineno,
8603                   "- intent specified for nondummy argument", SYMNAME(sptr));
8604           } else if (POINTERG(sptr)) {
8605             error(134, 3, gbl.lineno, "- intent specified for pointer argument",
8606                   SYMNAME(sptr));
8607           } else if (STYPEG(sptr) == ST_PROC) {
8608             error(134, 3, gbl.lineno,
8609                   "- intent specified for dummy subprogram argument",
8610                   SYMNAME(sptr));
8611           }
8612         } else {
8613           /* defer checking of storage class until semfin */
8614           itemp1 = (ITEM *)getitem(3, sizeof(ITEM));
8615           itemp1->next = sem.intent_list;
8616           sem.intent_list = itemp1;
8617           itemp1->t.sptr = sptr;
8618           itemp1->ast = gbl.lineno;
8619         }
8620         break;
8621       case ET_INTRINSIC:
8622         stype = STYPEG(sptr);
8623         if (IS_INTRINSIC(stype)) {
8624           EXPSTP(sptr, 1); /* Freeze as an intrinsic */
8625           TYPDP(sptr, 1);  /* appeared in INTRINSIC statement */
8626         } else
8627           error(126, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8628         stype = 0;
8629         no_init = TRUE;
8630         break;
8631       case ET_OPTIONAL:
8632         OPTARGP(sptr, 1);
8633         break;
8634       case ET_PARAMETER:
8635         break; /* handle after scanning all attributes */
8636       case ET_POINTER:
8637         POINTERP(sptr, TRUE);
8638         if (sem.contiguous)
8639           CONTIGATTRP(sptr, 1);
8640         if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
8641           F90POINTERP(sptr, TRUE);
8642         }
8643         if (is_array) {
8644           ad = AD_DPTR(dtype);
8645           if (AD_DEFER(ad) == 0)
8646             error(84, 3, gbl.lineno, SYMNAME(sptr),
8647                   "- must be a deferred shape array");
8648         }
8649         dtype = DTYPEG(sptr);
8650         if (DTY(dtype) == TY_ARRAY) {
8651           dtype = DTY(dtype + 1);
8652           if (sem.class)
8653             CLASSP(sptr, 1);
8654         }
8655         if (STYPEG(sptr) == ST_MEMBER && DTY(dtype) == TY_DERIVED &&
8656             has_finalized_component(sptr)) {
8657           FINALIZEDP(sptr, 1);
8658         }
8659         if (!(DTY(DTYPEG(sptr)) == TY_ARRAY && STYPEG(sptr) == ST_MEMBER) &&
8660             DTY(dtype) == TY_DERIVED) {
8661           int sav_sc;
8662           if (sem.class)
8663             CLASSP(sptr, TRUE);
8664           set_descriptor_rank(TRUE);
8665           sav_sc = 0;
8666           if (IN_MODULE && sem.savall) {
8667             /* SAVE is set, so we need to set our descriptor
8668              * to SC_STATIC here instead of later (in do_save() of
8669              * semfin.c). Otherwise, we may get unresolved symbol
8670              * link errors because we save descriptor early on in
8671              * the module.
8672              */
8673             /* Note: The SC_STATIC fix is only required for polymorphic
8674              * objects. For non-polymorphic objects, we can safely use
8675              * SC_LOCAL since the type does not mutate.
8676              */
8677             sav_sc = get_descriptor_sc();
8678             set_descriptor_sc(sem.class ? SC_STATIC : SC_LOCAL);
8679           }
8680           if (sem.class || has_tbp_or_final(dtype) ||
8681               STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY) {
8682             ALLOCDESCP(sptr, TRUE);
8683           }
8684           get_static_descriptor(sptr);
8685           set_descriptor_rank(FALSE);
8686           if (IN_MODULE && sem.savall) {
8687             set_descriptor_sc(sav_sc);
8688           }
8689           if (!sem.class)
8690             CCSYMP(SDSCG(sptr), TRUE);
8691         } else if (!INSIDE_STRUCT && SDSCG(sptr) == 0 &&
8692                    (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
8693                     DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) {
8694           if (SCG(sptr) != SC_DUMMY) /* Can't change dummy */
8695             SCP(sptr, SC_BASED);
8696           get_static_descriptor(sptr);
8697           get_all_descriptors(sptr);
8698         }
8699         break;
8700       case ET_SAVE:
8701 /* <ident> must be a variable or an array; it cannot be a dummy
8702  * argument or common block member.
8703  */
8704         if (stype == 0)
8705           error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8706         else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) {
8707           if (ASUMSZG(sptr))
8708             error(155, 3, gbl.lineno,
8709                   "An assumed-size array cannot have the SAVE attribute -",
8710                   SYMNAME(sptr));
8711           else if (SCG(sptr) == SC_DUMMY)
8712             error(155, 3, gbl.lineno,
8713                   "An adjustable array cannot have the SAVE attribute -",
8714                   SYMNAME(sptr));
8715           else
8716             error(155, 3, gbl.lineno,
8717                   "An automatic array cannot have the SAVE attribute -",
8718                   SYMNAME(sptr));
8719         } else if (flg.standard && gbl.currsub && PUREG(gbl.currsub)) {
8720           error(170, 2, gbl.lineno,
8721                 "SAVE attribute for a local variable of a PURE subroutine",
8722                 CNULL);
8723         } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
8724                     SCG(sptr) == SC_BASED) &&
8725                    (stype == ST_VAR || stype == ST_ARRAY ||
8726                     stype == ST_STRUCT || stype == ST_IDENT)) {
8727           sem.savloc = TRUE;
8728           SAVEP(sptr, 1);
8729           /* SCP(sptr, SC_LOCAL);
8730            * SAVE is now an attribute and may appear allocatable; the
8731            * appearance of a variable in a SAVE statement is no longer
8732            * sufficient to define the variable's storage class.
8733            */
8734         } else
8735           error(39, 2, gbl.lineno, SYMNAME(sptr), CNULL);
8736         break;
8737       case ET_TARGET:
8738         TARGETP(sptr, 1);
8739         if( XBIT(58, 0x400000) && SCG(sptr) == SC_DUMMY && ASSUMSHPG(sptr) )
8740              SDSCS1P(sptr,0);
8741         break;
8742       case ET_AUTOMATIC:
8743         /* <ident> must be a variable or an array; it cannot be a dummy
8744          * argument or common block member.
8745          */
8746         if (stype == 0)
8747           error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8748         else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr)))
8749           error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8750         else if (flg.standard)
8751           error(171, 2, gbl.lineno, "AUTOMATIC", CNULL);
8752         else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
8753                   SCG(sptr) == SC_BASED) &&
8754                  (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
8755                   stype == ST_IDENT)) {
8756           if (SCG(sptr) == SC_BASED && MIDNUMG(sptr))
8757             symatterr(2, sptr, "AUTOMATIC");
8758           else if (gbl.rutype != RU_PROG) {
8759             sem.autoloc = TRUE;
8760             /* TBD -- need to resolve SC_BASED vs SC_LOCAL & SCFXD
8761              * DON'T FORGET the AUTOMATIC & STATIC statements.
8762              */
8763             SCP(sptr, SC_LOCAL);
8764             SCFXDP(sptr, 1);
8765           }
8766         } else
8767           symatterr(2, sptr, "AUTOMATIC");
8768         break;
8769       case ET_STATIC:
8770         /* <ident> must be a variable or an array; it cannot be a dummy
8771          * argument or common block member.
8772          */
8773         if (stype == 0)
8774           error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8775         else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr)))
8776           error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8777         else if (flg.standard)
8778           error(171, 2, gbl.lineno, "STATIC", CNULL);
8779         else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
8780                   SCG(sptr) == SC_BASED) &&
8781                  (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
8782                   stype == ST_IDENT)) {
8783           if (SCG(sptr) == SC_BASED && MIDNUMG(sptr))
8784             symatterr(2, sptr, "STATIC");
8785           /* just use the save semantics */
8786           sem.savloc = TRUE;
8787           SAVEP(sptr, 1);
8788         } else
8789           symatterr(2, sptr, "STATIC");
8790         break;
8791       case ET_BIND:
8792         if (!IN_MODULE)
8793           error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
8794         process_bind(sptr);
8795         break;
8796       case ET_VALUE:
8797         if (CLASSG(sptr)) {
8798           error(155, 3, gbl.lineno, "Polymorphic variable"
8799                                     " cannot have VALUE attribute -",
8800                 SYMNAME(sptr));
8801         }
8802         if ((DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR) &&
8803             string_length(DTYPEG(sptr)) != 1) {
8804           error(155, 3, gbl.lineno,
8805                 "Multi-CHARACTER strings can not have the VALUE attribue - ",
8806                 SYMNAME(sptr));
8807         }
8808         PASSBYVALP(sptr, 1);
8809         PASSBYREFP(sptr, 0);
8810         break;
8811       case ET_VOLATILE:
8812         VOLP(sptr, 1);
8813         break;
8814       case ET_ASYNCHRONOUS:
8815 /*
8816  * do we need a specific flag set a flag? OR, just hit it
8817  * with VOLP?  Wait until it really matters.
8818  */
8819 #ifdef ASYNCP
8820         /* Yes, flag is needed so we can check
8821          * characteristics of dummy arguments for type bound
8822          * procedures.
8823          */
8824         ASYNCP(sptr, 1);
8825 #endif
8826         break;
8827       case ET_PROTECTED:
8828         PROTECTEDP(sptr, 1);
8829         break;
8830       case ET_KIND:
8831 #ifdef KINDP
8832         if (!DT_ISINT(DTYPEG(sptr))) {
8833           error(155, 3, gbl.lineno,
8834                 "derived type parameter must be an INTEGER -", SYMNAME(sptr));
8835         }
8836         KINDP(sptr, -1);
8837 #endif
8838         break;
8839       case ET_LEN:
8840 #ifdef KINDP
8841         if (!DT_ISINT(DTYPEG(sptr))) {
8842           error(155, 3, gbl.lineno,
8843                 "derived type parameter must be an INTEGER -", SYMNAME(sptr));
8844         }
8845         KINDP(sptr, -1);
8846         LENPARMP(sptr, 1);
8847 #endif
8848         break;
8849       }
8850     }
8851     if (sem.new_param_dt)
8852       chk_new_param_dt(sptr, sem.new_param_dt);
8853     if ((DTYPEG(sptr) == DT_DEFERCHAR || DTYPEG(sptr) == DT_DEFERNCHAR) &&
8854         (!POINTERG(sptr) && !ALLOCATTRG(sptr))) {
8855       error(155, 3, gbl.lineno, "Object with deferred character length"
8856                                 " (:) must be a pointer or an allocatable -",
8857             SYMNAME(sptr));
8858     }
8859 
8860     if ((entity_attr.exist & ET_B(ET_PARAMETER)) ||
8861         do_fixup_param_vars_for_derived_arrays(inited, sptr,
8862                                                SST_IDG(RHS(3)))) {
8863       if (inited) {
8864         fixup_param_vars(top, RHS(3));
8865         if (DTY(dtype) != TY_DERIVED && (DTY(dtype) != TY_ARRAY)) {
8866           /* don't build ACLs for scalar parameters */
8867           goto entity_decl_end;
8868         }
8869       } else {
8870         error(143, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8871         goto entity_decl_end;
8872       }
8873     }
8874 
8875     if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY) {
8876       /* set the type for the entry point as well */
8877       copy_type_to_entry(sptr);
8878     }
8879     if (stype) {
8880       if (stype != STYPEG(sptr) && STYPEG(sptr) != ST_PARAM) {
8881         if (STYPEG(sptr) == ST_VAR && stype == ST_ARRAY) {
8882           /* HACK: if the item being defined has an initializer
8883            * that contains an intrinsic call that uses the item
8884            * as an argument, then the argument handling may have
8885            * changed the item's STYPE to ST_VAR.  If the item is
8886            * an array, change its STYPE to ST_IDENT so declsym
8887            * will function correctly.
8888            */
8889           STYPEP(sptr, ST_IDENT);
8890         }
8891         sptr = declsym(sptr, stype, TRUE);
8892       }
8893       if (stype == ST_ARRAY && !F90POINTERG(sptr)) {
8894         if (POINTERG(sptr) || MDALLOCG(sptr) ||
8895             (ALLOCATTRG(sptr) && STYPEG(sptr) == ST_MEMBER)) {
8896           int dty = DTYPEG(sptr);
8897           get_static_descriptor(sptr);
8898           get_all_descriptors(sptr);
8899           if (DTY(dty) == TY_ARRAY) {
8900             dty = DTY(dty + 1);
8901           }
8902           if (DTY(dty) == TY_DERIVED && SCG(sptr) != SC_DUMMY) {
8903             /* initialize the type field in the descriptor */
8904             int astnew, type;
8905             type = get_static_type_descriptor(DTY(dty + 3));
8906             astnew = mk_set_type_call(mk_id(SDSCG(sptr)), mk_id(type), FALSE);
8907             add_stmt(astnew);
8908           }
8909         }
8910       }
8911     }
8912     if (INSIDE_STRUCT && XBIT(58, 0x10000) && !F90POINTERG(sptr)) {
8913       /* we are processing a member, and we must handle all pointers */
8914       /* do we need descriptors for this member? */
8915       if (POINTERG(sptr) || ALLOCG(sptr) || ADJARRG(sptr) || RUNTIMEG(sptr)) {
8916         set_preserve_descriptor(ALLOCDESCG(sptr));
8917         get_static_descriptor(sptr);
8918         get_all_descriptors(sptr);
8919         SCP(sptr, SC_BASED);
8920         set_preserve_descriptor(0);
8921       }
8922     }
8923     if (inited) { /* check if symbol is data initialized */
8924       if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
8925         if (no_init) {
8926           error(114, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8927           goto entity_decl_end;
8928         }
8929         stsk = &STSK_ENT(0);
8930         if (SST_IDG(RHS(3)) == S_LVALUE || SST_IDG(RHS(3)) == S_EXPR ||
8931             SST_IDG(RHS(3)) == S_IDENT || SST_IDG(RHS(3)) == S_CONST) {
8932           mkexpr(RHS(3));
8933           ast = SST_ASTG(RHS(3));
8934           if (has_kind_parm_expr(ast, stsk->dtype, 1)) {
8935             if (chk_kind_parm_expr(ast, stsk->dtype, 1, 1)) {
8936               INITKINDP(sptr, 1);
8937               PARMINITP(sptr, ast);
8938             }
8939           } else if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
8940             int dim;
8941             ad = AD_DPTR(DTYPEG(sptr));
8942             for (dim = 0; dim < AD_NUMDIM(ad); ++dim) {
8943               int lb = AD_LWAST(ad, dim);
8944               int ub = AD_UPAST(ad, dim);
8945               if (has_kind_parm_expr(lb, stsk->dtype, 1) ||
8946                   has_kind_parm_expr(ub, stsk->dtype, 1)) {
8947                 INITKINDP(sptr, 1);
8948                 PARMINITP(sptr, ast);
8949                 break;
8950               }
8951             }
8952           }
8953         }
8954         if (!INITKINDG(sptr))
8955           construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
8956         if (!SST_ACLG(RHS(3))) {
8957           goto entity_decl_end;
8958         }
8959 
8960         ict = SST_ACLG(RHS(3));
8961         ict->sptr = sptr; /* field/component sptr */
8962         save_struct_init(ict);
8963         stsk = &STSK_ENT(0);
8964         if (stsk->ict_beg) {
8965           (stsk->ict_end)->next = SST_ACLG(RHS(3));
8966           stsk->ict_end = SST_ACLG(RHS(3));
8967         } else {
8968           stsk->ict_beg = SST_ACLG(RHS(3));
8969           stsk->ict_end = SST_ACLG(RHS(3));
8970         }
8971       } else {
8972         /* Data item (not TYPE component) initialization */
8973         if (no_init) {
8974           error(114, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8975           goto entity_decl_end;
8976         }
8977 
8978         if (DTY(DTYPEG(sptr)) == TY_ARRAY && !POINTERG(sptr)) {
8979           if (ADD_DEFER(DTYPEG(sptr)) || ADD_NOBOUNDS(DTYPEG(sptr))) {
8980             error(155, 3, gbl.lineno, "Cannot initialize deferred-shape array",
8981                   SYMNAME(sptr));
8982             goto entity_decl_end;
8983           }
8984         }
8985         if (POINTERG(sptr)) {
8986           /* have
8987            *   ... :: <ptr> => NULL()
8988            * <ptr>$p, <ptr>$o, <ptr>$sd  will be needed */
8989           dtype = DTYPEG(sptr);
8990           if (DTY(dtype) == TY_ARRAY) {
8991             dtype = DTY(dtype + 1);
8992           }
8993           if ((DTY(DTYPEG(sptr)) != TY_ARRAY || STYPEG(sptr) != ST_MEMBER) &&
8994               DTY(dtype) == TY_DERIVED &&
8995               (sem.class || has_tbp_or_final(dtype) ||
8996                STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY))
8997             set_descriptor_rank(1);
8998           get_static_descriptor(sptr);
8999 
9000           if ((DTY(DTYPEG(sptr)) != TY_ARRAY || STYPEG(sptr) != ST_MEMBER) &&
9001               DTY(dtype) == TY_DERIVED &&
9002               (sem.class || has_tbp_or_final(dtype) ||
9003                STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY))
9004             set_descriptor_rank(0);
9005           get_all_descriptors(sptr);
9006         }
9007 
9008         if (SST_IDG(RHS(3)) == S_ACONST) {
9009           if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
9010             if (AD_NUMDIM(AD_DPTR(DTYPEG(sptr))) !=
9011                 AD_NUMDIM(AD_DPTR(SST_DTYPEG(RHS(3))))) {
9012               if (size_of_array(DTYPEG(sptr)) == 0 &&
9013                   DTY(SST_DTYPEG(RHS(3))) != TY_ARRAY) {
9014                 /* i.e., a(0) == (/integer::/) */
9015                 goto entity_decl_end;
9016               }
9017               error(155, 3, gbl.lineno,
9018                     "Shape of initializer does not match shape of",
9019                     SYMNAME(sptr));
9020               goto entity_decl_end;
9021             }
9022           } else if (POINTERG(sptr) || ALLOCATTRG(sptr)) {
9023             errsev(457);
9024             goto entity_decl_end;
9025           }
9026         }
9027         construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
9028         if (!SST_ACLG(RHS(3))) {
9029           goto entity_decl_end;
9030         }
9031 
9032         dtype = DTYPEG(sptr);
9033         if (STYPEG(sptr) == ST_PARAM) {
9034           if (DTY(dtype) == TY_ARRAY || DTY(dtype) == TY_DERIVED) {
9035             CONVAL2P(sptr, put_getitem_p(save_acl(SST_ACLG(RHS(3)))));
9036             sptr = CONVAL1G(sptr);
9037           }
9038         } else if (DTY(dtype) == TY_DERIVED && !POINTERG(sptr)) {
9039           /* This used to be done in dinit_struct_constr. It is necessary */
9040           /* to get ADDRESS (i.e., offset into STATICS) set */
9041           if (STYPEG(sptr) == ST_IDENT || STYPEG(sptr) == ST_UNKNOWN) {
9042             STYPEP(sptr, ST_VAR);
9043           }
9044           if (SCG(sptr) == SC_NONE)
9045             SCP(sptr, SC_LOCAL);
9046           DINITP(sptr, 1);
9047           sym_is_refd(sptr);
9048         }
9049 
9050         ast = mk_id(sptr);
9051         SST_ASTP(RHS(1), ast);
9052         SST_DTYPEP(RHS(1), DTYPEG(SST_SYMG(RHS(1))));
9053         SST_SHAPEP(RHS(1), A_SHAPEG(ast));
9054         ivl = dinit_varref(RHS(1));
9055         dinit(ivl, SST_ACLG(RHS(3)));
9056       }
9057     } else if (DTY(DDTG(dtype)) == TY_DERIVED && !POINTERG(sptr) &&
9058                !ALLOCG(sptr) && !ADJARRG(sptr)) {
9059       int dt_dtype = DDTG(dtype);
9060 
9061       if (INSIDE_STRUCT) {
9062         /* Uninitialized declaration of a derived type data item.
9063          * Check for and handle any component intializations defined
9064          * for this derived type */
9065         build_typedef_init_tree(sptr, dt_dtype);
9066       } else if (DTY(dt_dtype + 5) && SCOPEG(sptr) &&
9067                  SCOPEG(sptr) == stb.curr_scope &&
9068                  STYPEG(stb.curr_scope) == ST_MODULE) {
9069         /*
9070          * a derived type module variable has component initializers,
9071          * so generate inits.
9072          */
9073         build_typedef_init_tree(sptr, dt_dtype);
9074       }
9075     } else {
9076       if (POINTERG(sptr)) {
9077 
9078         /* have
9079          *   ... :: <ptr>
9080          * <ptr>$p, <ptr>$o, <ptr>$sd  will be needed */
9081         if (!SDSCG(sptr))
9082           get_static_descriptor(sptr);
9083 
9084         if (!PTROFFG(sptr))
9085           get_all_descriptors(sptr);
9086       }
9087     }
9088 
9089   entity_decl_end:
9090     sem.dinit_error = FALSE;
9091     break;
9092 
9093   /* ------------------------------------------------------------------ */
9094   /*
9095    *	<entity id> ::= <ident> <opt len spec>  |
9096    */
9097   case ENTITY_ID1:
9098     set_len_attributes(RHS(2), 1);
9099     stype = ST_IDENT;
9100     dtype = -1;
9101     dtypeset = 0;
9102     sem.dinit_count = 1;
9103     if (entity_attr.exist & ET_B(ET_DIMENSION)) {
9104       if (entity_attr.dimension) {
9105         /* allow just one use of this data type record */
9106         dtype = entity_attr.dimension;
9107         dtypeset = 1;
9108         entity_attr.dimension = 0;
9109       } else {
9110         /* create a new array dtype record from the bounds information
9111          * saved earlier
9112          */
9113         BCOPY(sem.bounds, entity_attr.bounds, char, sizeof(sem.bounds));
9114         BCOPY(&sem.arrdim, entity_attr.arrdim, char, sizeof(sem.arrdim));
9115         dtype = mk_arrdsc();
9116         dtypeset = 1;
9117       }
9118       ad = AD_DPTR(dtype);
9119       if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))
9120         sem.dinit_count = -1;
9121       stype = ST_ARRAY;
9122     } else
9123       ad = NULL;
9124     goto entity_id_shared;
9125   /*
9126    *	<entity id> ::= <ident> <opt len spec> <dim beg> <dimension list> ) <opt
9127    *len spec>
9128    */
9129   case ENTITY_ID2:
9130     /* Send len spec up with ident on semantic stack */
9131     if (SST_SYMG(RHS(6)) != -1) {
9132       if (SST_SYMG(RHS(2)) != -1)
9133         errsev(46);
9134       set_len_attributes(RHS(6), 1);
9135     } else
9136       set_len_attributes(RHS(2), 1);
9137     stype = ST_ARRAY;
9138     dtype = SST_DTYPEG(RHS(4));
9139     dtypeset = 1;
9140     ad = AD_DPTR(dtype);
9141     if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad) || sem.interface)
9142       sem.dinit_count = -1;
9143     else
9144       sem.dinit_count = ad_val_of(sym_of_ast(AD_NUMELM(ad)));
9145   entity_id_shared:
9146     sptr = SST_SYMG(RHS(1));
9147     if (!sem.kind_type_param && !sem.len_type_param &&
9148         sem.type_param_candidate) {
9149       sem.kind_type_param = sem.type_param_candidate;
9150       sem.type_param_candidate = 0;
9151     }
9152     if (INSIDE_STRUCT) {
9153       /* this may be an HPF directive in a derived type */
9154       stsk = &STSK_ENT(0);
9155       if (sem.is_hpf && STYPEG(sptr) == ST_MEMBER &&
9156           ENCLDTYPEG(sptr) == stsk->dtype) {
9157         /* do nothing */
9158       } else {
9159         if (STYPEG(sptr) != ST_UNKNOWN)
9160           SST_SYMP(LHS, (sptr = insert_sym(sptr)));
9161         SYMLKP(sptr, NOSYM);
9162         STYPEP(sptr, ST_MEMBER);
9163         if (!dtypeset)
9164           dtype = sem.gdtype;
9165         DTYPEP(sptr, dtype); /* must be done before link members */
9166         if (sem.kind_type_param) {
9167           USEKINDP(sptr, 1);
9168           if (sem.kind_candidate) {
9169             /* Save kind expression in component */
9170             mkexpr(sem.kind_candidate->t.stkp);
9171             KINDASTP(sptr, SST_ASTG(sem.kind_candidate->t.stkp));
9172           }
9173           KINDP(sptr, sem.kind_type_param);
9174         }
9175         if (sem.len_type_param) {
9176           USELENP(sptr, 1);
9177           LENP(sptr, sem.len_type_param);
9178         }
9179         if (sem.len_candidate) {
9180           int ty = DTY(DTYPEG(sptr));
9181           if (ty == TY_CHAR || ty == TY_NCHAR)
9182           {
9183             ast = SST_ASTG((SST *)sem.len_candidate->t.stkp);
9184             ty = get_type(2, ty, ast);
9185             DTYPEP(sptr, ty);
9186             USELENP(sptr, 1);
9187             sem.len_candidate = 0;
9188             chk_len_parm_expr(ast, stsk->dtype, 1);
9189           }
9190         }
9191         if (DTY(dtype) == TY_ARRAY) {
9192           int d;
9193           d = DTY(dtype + 1);
9194           if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
9195             error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9196           }
9197         }
9198         /* link field-namelist into member list at this level */
9199         link_members(stsk, sptr);
9200         if (stype == ST_ARRAY && STSK_ENT(0).type != 'd' &&
9201             (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))) {
9202           error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9203         }
9204         if (stype == ST_ARRAY) {
9205           if (entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) {
9206             ALLOCP(sptr, 1);
9207           } else if (STSK_ENT(0).type == 'd') {
9208             /* error message wasn't issued above for derived type.
9209              * issue one now
9210              */
9211             if (AD_DEFER(ad)) {
9212               error(84, 3, gbl.lineno, SYMNAME(sptr),
9213                     "- deferred shape array must have the POINTER "
9214                     "or ALLOCATABLE attribute in a derived type");
9215               entity_attr.exist |= ET_B(ET_POINTER);
9216             } else if (AD_ASSUMSZ(ad) || AD_ADJARR(ad)) {
9217               if (AD_ADJARR(ad)) {
9218                 int bndast, bnd_sptr, badArray, offset;
9219                 int numdim = AD_NUMDIM(ad);
9220                 for (badArray = i = 0; i < numdim; i++) {
9221                   bndast = AD_LWAST(ad, i);
9222                   badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
9223                   if (!badArray) {
9224                     bndast = AD_UPAST(ad, i);
9225                     badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
9226                     if (!badArray) {
9227                       ADJARRP(sptr, 1);
9228                       USELENP(sptr, 1);
9229                       break;
9230                     }
9231                   }
9232                 }
9233                 if (badArray) {
9234                   for (badArray = i = 0; i < numdim; i++) {
9235                     bndast = AD_LWAST(ad, i);
9236                     badArray =
9237                         !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
9238                     if (badArray) {
9239                       badArray =
9240                           !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
9241                       if (!badArray) {
9242                         ADJARRP(sptr, 1);
9243                         USELENP(sptr, 1);
9244                         break;
9245                       }
9246                     }
9247                     if (badArray) {
9248                       goto illegal_array;
9249                     }
9250                     bndast = AD_UPAST(ad, i);
9251                     badArray =
9252                         !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
9253                     if (badArray) {
9254                       badArray =
9255                           !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
9256                       if (!badArray) {
9257                         ADJARRP(sptr, 1);
9258                         USELENP(sptr, 1);
9259                         break;
9260                       }
9261                     } else if (A_TYPEG(bndast) != A_ID &&
9262                                A_TYPEG(bndast) != A_CNST) {
9263 
9264                       ADJARRP(sptr, 1);
9265                       USELENP(sptr, 1);
9266                       if (chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0)) {
9267                         USEKINDP(sptr, 1);
9268                       }
9269                       break;
9270                     }
9271                     if (badArray) {
9272                       goto illegal_array;
9273                     }
9274                   }
9275                 }
9276               } else {
9277               illegal_array:
9278                 error(84, 3, gbl.lineno, SYMNAME(sptr),
9279                       "- array must have constant bounds "
9280                       "in a derived type");
9281                 entity_attr.exist |= ET_B(ET_POINTER);
9282               }
9283             }
9284           }
9285           if (DTY(dtype) == TY_ARRAY) {
9286             int d;
9287             d = DTY(dtype + 1);
9288             if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
9289               error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9290             }
9291           }
9292         }
9293         if (DTY(sem.gdtype) == TY_DERIVED && (stsk->type == 'd')) {
9294           /* outer derived type has SEQUENCE, nested one should too */
9295 
9296           if (SEQG(DTY(stsk->dtype + 3)) && DCLDG(DTY(sem.gdtype + 3)) &&
9297               !SEQG(DTY(sem.gdtype + 3))) {
9298             error(155, 3, gbl.lineno,
9299                   "SEQUENCE must be set for nested derived type",
9300                   SYMNAME(DTY(sem.gdtype + 3)));
9301           }
9302           if (DTY(stsk->dtype + 3) == DTY(sem.gdtype + 3)) {
9303             if ((entity_attr.exist & ET_B(ET_POINTER)) == 0) {
9304               error(155, 3, gbl.lineno, "Derived type component must "
9305                                         "have the POINTER attribute -",
9306                     SYMNAME(sptr));
9307             }
9308           } else if ((entity_attr.exist & ET_B(ET_POINTER)) == 0 &&
9309                      !DCLDG(DTY(sem.gdtype + 3)))
9310             error(155, 4, gbl.lineno, "Derived type has not been declared -",
9311                   SYMNAME(DTY(sem.gdtype + 3)));
9312         }
9313       }
9314 
9315     } else {
9316       sptr = create_var(sptr);
9317       if (sem.kind_type_param) {
9318         USEKINDP(sptr, 1);
9319         KINDP(sptr, sem.kind_type_param);
9320       }
9321       if (sem.len_type_param) {
9322         USELENP(sptr, 1);
9323         LENP(sptr, sem.len_type_param);
9324       }
9325       if (DTY(sem.stag_dtype) == TY_DERIVED && sem.class) {
9326         /* TBD - Probably need to fix this condition when we
9327          * support unlimited polymorphic entities.
9328          */
9329         if (SCG(sptr) == SC_DUMMY ||
9330             entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) {
9331           CLASSP(sptr, 1); /* mark polymorphic variable */
9332           if (PASSBYVALG(sptr)) {
9333             error(155, 3, gbl.lineno, "Polymorphic variable cannot have VALUE"
9334                                       " attribute -",
9335                   SYMNAME(sptr));
9336           }
9337           if (DTY(sem.stag_dtype) == TY_DERIVED) {
9338             int tag = DTY(sem.stag_dtype + 3);
9339             if (CFUNCG(tag)) {
9340               error(155, 3, gbl.lineno,
9341                     "Polymorphic variable cannot be declared "
9342                     "with a BIND(C) derived type - ",
9343                     SYMNAME(sptr));
9344             }
9345             if (SEQG(tag)) {
9346               error(155, 3, gbl.lineno,
9347                     "Polymorphic variable cannot be declared "
9348                     "with a SEQUENCE derived type - ",
9349                     SYMNAME(sptr));
9350             }
9351           }
9352 
9353         } else {
9354           error(155, 3, gbl.lineno, "Polymorphic variable must be a pointer, "
9355                                     "allocatable, or dummy object - ",
9356                 SYMNAME(sptr));
9357         }
9358       }
9359       if (DTY(sem.stag_dtype) == TY_DERIVED && sem.which_pass) {
9360         if (!(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) &&
9361             SCG(sptr) != SC_DUMMY && !FVALG(sptr) && gbl.rutype != RU_PROG) {
9362           add_auto_finalize(sptr);
9363         }
9364       }
9365       if (STYPEG(sptr) == ST_PROC && SCOPEG(sptr) &&
9366           SCOPEG(sptr) == stb.curr_scope && sem.which_pass &&
9367           gbl.rutype == RU_FUNC) {
9368         /* sptr is the ST_PROC for an ENTRY statement to appear later.
9369          * make a new sptr */
9370         sptr = insert_sym(sptr);
9371       }
9372       SST_SYMP(LHS, sptr);
9373       stype1 = STYPEG(sptr);
9374       /* Assertion:
9375        *  stype  = stype we want to make symbol {ARRAY or IDENT}
9376        *	stype1 = symbol's current stype
9377        */
9378       if (stype == ST_ARRAY) {
9379         if (IS_INTRINSIC(stype1)) {
9380           /* Changing intrinsic symbol to ARRAY */
9381           if ((sptr = newsym(sptr)) == 0)
9382             /* Symbol frozen as an intrinsic, ignore type decl */
9383             break;
9384           SST_SYMP(LHS, sptr);
9385           /* Cause STYPE and DTYPE to change AFTER fixing dtype */
9386           stype1 = ST_UNKNOWN;
9387         } else if (stype1 == ST_ENTRY) {
9388           if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
9389             error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9390             break;
9391           }
9392         } else if (stype1 == ST_ARRAY) {
9393           /* if symbol is already an array, check if the dimension
9394            * specifiers are identical.
9395            */
9396           ADSC *ad1, *ad2;
9397           int ndim;
9398 
9399           ad1 = AD_DPTR(DTYPEG(sptr));
9400           /* dtype must be set */
9401           assert(dtypeset, "semant: dtype was not set", dtype, 3);
9402           ad2 = AD_DPTR(dtype);
9403           ndim = AD_NUMDIM(ad1);
9404           if (ndim != AD_NUMDIM(ad2)) {
9405             error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9406             break;
9407           }
9408           for (i = 0; i < ndim; i++)
9409             if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) ||
9410                 AD_UPBD(ad1, i) != AD_UPBD(ad2, i))
9411               break;
9412           if (i < ndim) {
9413             error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9414             break;
9415           }
9416           error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
9417         } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT &&
9418                    stype1 != ST_VAR) {
9419           error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9420           break;
9421         }
9422         DTY(dtype + 1) = DTYPEG(sptr);
9423       } else if (IS_INTRINSIC(stype1) &&
9424                  (entity_attr.exist & ET_B(ET_INTRINSIC)) == 0) {
9425         /* Changing intrinsic symbol to IDENT in COMMON */
9426         if (IN_MODULE_SPEC || entity_attr.exist || sem.interface) {
9427           if ((sptr = newsym(sptr)) == 0)
9428             /* Symbol frozen as an intrinsic, ignore in COMMON */
9429             break;
9430           SST_SYMP(LHS, sptr);
9431           /* Cause STYPE and DTYPE to change AFTER fixing dtype */
9432           stype1 = ST_UNKNOWN;
9433           dtype = DTYPEG(sptr);
9434           dtypeset = 1;
9435         }
9436       }
9437       /*
9438        * The symbol's stype and data type can only be changed if
9439        * it is new or if the type is changing from an identifier or
9440        * structure to an array.  The latter can occur because of the
9441        * separation of type/record declarations from DIMENSION/COMMON
9442        * statements.  If the symbol is a record, its stype can change
9443        * only if it's an identifier; note, that its dtype will be
9444        * set (and checked) by the semantic actions for record.
9445        */
9446       if (stype1 == ST_UNKNOWN ||
9447           (stype == ST_ARRAY && (stype1 == ST_IDENT || stype1 == ST_VAR))) {
9448         if (in_entity_typdcl)
9449           STYPEP(sptr, ST_IDENT); /* stype will be filled in later*/
9450         /* ...else stype will be set by the actions for <combined> */
9451 
9452         if (!dtypeset)
9453           dtype = sem.gdtype;
9454         if (dtype > 0)
9455           DTYPEP(sptr, dtype);
9456         if (stype == ST_ARRAY) {
9457           if ((entity_attr.exist & ET_B(ET_POINTER)) || POINTERG(sptr)) {
9458             if (AD_ASSUMSHP(ad))
9459               error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9460             if (SCG(sptr) != SC_DUMMY)
9461               ALLOCP(sptr, 1);
9462           } else if (AD_ASSUMSZ(ad)) {
9463             if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY &&
9464                 SCG(sptr) != SC_BASED)
9465               error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9466             ASUMSZP(sptr, 1);
9467             SEQP(sptr, 1);
9468           }
9469           if (AD_ADJARR(ad)) {
9470             ADJARRP(sptr, 1);
9471             if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY &&
9472                 SCG(sptr) != SC_BASED)
9473               error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9474             else {
9475               /*
9476                * mark the adjustable array if the declaration
9477                * occurs after an ENTRY statement.
9478                */
9479               if (entry_seen)
9480                 AFTENTP(sptr, 1);
9481             }
9482           } else if (!(entity_attr.exist &
9483                        (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) &&
9484                      AD_DEFER(ad)) {
9485             if (SCG(sptr) == SC_CMBLK)
9486               error(43, 3, gbl.lineno, "deferred shape array", SYMNAME(sptr));
9487             if (SCG(sptr) == SC_DUMMY) {
9488               mk_assumed_shape(sptr);
9489               ASSUMSHPP(sptr, 1);
9490               if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
9491                 SDSCS1P(sptr, 1);
9492             } else {
9493               if (AD_ASSUMSHP(ad)) {
9494                 /* this is an error if it isn't a dummy; the
9495                  * declaration could occur before its entry, so
9496                  * the check needs to be performed in semfin.
9497                  */
9498                 ASSUMSHPP(sptr, 1);
9499                 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
9500                   SDSCS1P(sptr, 1);
9501               }
9502               ALLOCP(sptr, 1);
9503               mk_defer_shape(sptr);
9504             }
9505           }
9506         }
9507       } else if (stype == ST_ARRAY) {
9508         if (stype1 == ST_ENTRY) {
9509           if (FVALG(sptr)) {
9510 #if DEBUG
9511             interr("semant1: trying to set data type of ST_ENTRY", sptr, 3);
9512 #endif
9513             sptr = FVALG(sptr);
9514           } else {
9515             error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr));
9516             sptr = insert_sym(sptr);
9517           }
9518         }
9519         if (RESULTG(sptr)) {
9520           assert(dtypeset, "semant: dtype was not set (2)", dtype, 3);
9521           DTYPEP(sptr, dtype);
9522           if ((entity_attr.exist & ET_B(ET_POINTER)) || POINTERG(sptr)) {
9523             if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
9524               error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9525           } else if (AD_ASSUMSZ(ad)) {
9526             ASUMSZP(sptr, 1);
9527             SEQP(sptr, 1);
9528           } else if (AD_ADJARR(ad))
9529             ADJARRP(sptr, 1);
9530           else if (AD_DEFER(ad)) {
9531             mk_assumed_shape(sptr);
9532             ASSUMSHPP(sptr, 1);
9533             if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
9534               SDSCS1P(sptr, 1);
9535             AD_ASSUMSHP(ad) = 1;
9536           }
9537           copy_type_to_entry(sptr);
9538         }
9539       }
9540     }
9541     if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY) {
9542       /* set the type for the entry point as well */
9543       copy_type_to_entry(sptr);
9544     }
9545 
9546     /* store gdtype, gty so that we can retrieve later to get
9547      * dtype for each declared variable, sem.gdtype an sem.gty
9548      * may get overwritten if variable is initialized with f2003
9549      * feature.
9550      */
9551     SST_GDTYPEP(RHS(1), sem.gdtype);
9552     SST_GTYP(RHS(1), sem.gty);
9553 
9554     break;
9555 
9556   /* ------------------------------------------------------------------ */
9557   /*
9558    *	<target list> ::= <target list> , <target> |
9559    */
9560   case TARGET_LIST1:
9561     break;
9562   /*
9563    *	<target list> ::= <target>
9564    */
9565   case TARGET_LIST2:
9566     break;
9567 
9568   /* ------------------------------------------------------------------ */
9569   /*
9570    *	<target> ::= <dcl id>
9571    */
9572   case TARGET1:
9573     TARGETP(SST_SYMG(RHS(1)), 1);
9574     break;
9575 
9576   /* ------------------------------------------------------------------ */
9577   /*
9578    *      <interface> ::= <begininterface> |
9579    */
9580   case INTERFACE1:
9581     push_iface_scope_level();
9582     break;
9583   /*
9584    *	<interface> ::= <begininterface> <generic spec>
9585    */
9586   case INTERFACE2:
9587     push_iface_scope_level();
9588     if (sem.interf_base[sem.interface - 1].abstract) {
9589       error(155, 3, gbl.lineno, "A generic specifier cannot be present in an",
9590             "ABSTRACT INTERFACE");
9591     }
9592     break;
9593 
9594   /* ------------------------------------------------------------------ */
9595   /*
9596    *      <begininterface> ::= <pgm> INTERFACE |
9597    */
9598   case BEGININTERFACE1:
9599     i = 0;
9600     goto begininterf;
9601   /*
9602    *	<begininterface> ::= <pgm> ABSTRACT INTERFACE
9603    */
9604   case BEGININTERFACE2:
9605     i = 1;
9606   begininterf:
9607     if (IN_MODULE_SPEC && get_seen_contains()) {
9608       error(155, 3, gbl.lineno,
9609             "Interface-block may not appear in a"
9610             " module after the CONTAINS statement unless it is inside"
9611             " a module subprogram",
9612             CNULL);
9613     }
9614     NEED(sem.interface + 1, sem.interf_base, INTERF, sem.interf_size,
9615          sem.interf_size + 2);
9616     save_host(&sem.interf_base[sem.interface]);
9617     sem.interf_base[sem.interface].generic = 0;
9618     sem.interf_base[sem.interface].operator= 0;
9619     sem.interf_base[sem.interface].opval = 0;
9620     sem.interf_base[sem.interface].abstract = i;
9621     sem.interf_base[sem.interface].hpfdcl = sem.hpfdcl;
9622     sem.interface++;
9623     break;
9624 
9625   /* ------------------------------------------------------------------ */
9626   /*
9627    *	<generic spec> ::= <generic name> |
9628    */
9629   case GENERIC_SPEC1:
9630     if (scn.stmtyp != TK_ENDINTERFACE) {
9631       /* If we have a previously defined symbol with
9632        * same name as a generic type bound procedure, delay declaring
9633        * the generic type bound procedure until we process the entire
9634        * module (see queue_tbp() function, flag == 3 case for the
9635        * call to declsym).
9636        */
9637       int oldsptr;
9638       sptr = (int)SST_SYMG(RHS(1));
9639       oldsptr = sptr;
9640       if (STYPEG(sptr) == ST_TYPEDEF) {
9641         sptr = insert_sym(sptr); /* Overloaded type */
9642       }
9643       if (!sem.generic_tbp || !STYPEG(sptr) || SCOPEG(sptr) != stb.curr_scope) {
9644         if (STYPEG(sptr) == ST_PROC && VTOFFG(sptr) && !sem.generic_tbp) {
9645           /* Type bound procedure and generic interface can co-exist */
9646           sptr = insert_sym(sptr);
9647         } else if (STYPEG(sptr) && STYPEG(sptr) != ST_USERGENERIC) {
9648           sptr = insert_sym(sptr);
9649         } else if (STYPEG(sptr) == ST_USERGENERIC && IS_TBP(sptr)) {
9650           sptr = insert_sym(sptr);
9651         }
9652         sptr = declsym(sptr, ST_USERGENERIC, FALSE);
9653         if (STYPEG(oldsptr) != ST_TYPEDEF) {
9654           /* Check for the case where we overload the
9655            * type-name with a binding-name in a type bound procedure.
9656            */
9657           int oldsptr2 = oldsptr;
9658           for (; STYPEG(oldsptr2) == ST_ALIAS; oldsptr2 = SYMLKG(oldsptr2))
9659             ;
9660           if (STYPEG(oldsptr2) == ST_PROC && CLASSG(oldsptr2) &&
9661               VTOFFG(oldsptr2)) {
9662             oldsptr2 = findByNameStypeScope(SYMNAME(oldsptr2), ST_TYPEDEF,
9663                                             SCOPEG(oldsptr2));
9664           }
9665           if (STYPEG(oldsptr2) == ST_TYPEDEF)
9666             oldsptr = oldsptr2;
9667         }
9668         if (STYPEG(oldsptr) == ST_TYPEDEF) {
9669           GTYPEP(sptr, oldsptr); /* Store overloaded type */
9670         } else {
9671           /* Check for overloaded type in scope */
9672           oldsptr =
9673               findByNameStypeScope(SYMNAME(oldsptr), ST_TYPEDEF, SCOPEG(sptr));
9674           if (oldsptr)
9675             GTYPEP(sptr, oldsptr);
9676         }
9677       }
9678       if (SCOPEG(sptr) != stb.curr_scope) {
9679         int oldsptr = sptr;
9680         sptr = insert_sym(sptr);
9681         STYPEP(sptr, ST_USERGENERIC);
9682         SCOPEP(sptr, stb.curr_scope);
9683         copy_specifics(oldsptr, sptr);
9684         IGNOREP(oldsptr, TRUE);
9685       }
9686       EXPSTP(sptr, 1);
9687       sem.interf_base[sem.interface - 1].generic = sptr;
9688     }
9689     /*else
9690      * SST_SYMP(LHS, SST_SYMG(RHS(1)));
9691      */
9692     break;
9693   /*
9694    *	<generic spec> ::= OPERATOR ( <operator> )
9695    */
9696   case GENERIC_SPEC2:
9697     if (scn.stmtyp != TK_ENDINTERFACE) {
9698       sem.interf_base[sem.interface - 1].operator= SST_LSYMG(RHS(3));
9699       sem.interf_base[sem.interface - 1].opval = SST_OPTYPEG(RHS(3));
9700     } else {
9701       SST_SYMP(LHS, SST_LSYMG(RHS(3)));
9702     }
9703     break;
9704   /*
9705    *	<generic spec> ::= ASSIGNMENT ( = )
9706    */
9707   case GENERIC_SPEC3:
9708     if (scn.stmtyp != TK_ENDINTERFACE) {
9709       sptr = get_intrinsic_opr(OP_ST, 0);
9710       sem.interf_base[sem.interface - 1].operator= sptr;
9711       sem.interf_base[sem.interface - 1].opval = OP_ST;
9712     } else {
9713       sptr = get_intrinsic_oprsym(OP_ST, 0);
9714       SST_SYMP(LHS, sptr);
9715     }
9716     break;
9717 
9718   /* ------------------------------------------------------------------ */
9719   /*
9720    *	<generic name> ::= <ident> |
9721    */
9722   case GENERIC_NAME1:
9723     break;
9724   /*
9725    *	<generic name> ::= OPERATOR |
9726    */
9727   case GENERIC_NAME2:
9728     sptr = getsymbol("operator");
9729     SST_SYMP(LHS, sptr);
9730     break;
9731   /*
9732    *	<generic name> ::= ASSIGNMENT
9733    */
9734   case GENERIC_NAME3:
9735     sptr = getsymbol("assignment");
9736     SST_SYMP(LHS, sptr);
9737     break;
9738 
9739   /*
9740    *      <generic name> ::= <ident> ( <ident> )
9741    */
9742   case GENERIC_NAME4:
9743     i = sem.defined_io_type;
9744     if (strcmp(SYMNAME(SST_SYMG(RHS(1))), "read") == 0) {
9745       if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "formatted") == 0) {
9746         sem.defined_io_type = 1;
9747       } else if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "unformatted") == 0) {
9748         sem.defined_io_type = 2;
9749       } else {
9750         error(155, 3, gbl.lineno, "(FORMATTED) or (UNFORMATTED) "
9751                                   "must follow defined READ",
9752               CNULL);
9753         sem.defined_io_type = 0;
9754       }
9755     } else if (strcmp(SYMNAME(SST_SYMG(RHS(1))), "write") == 0) {
9756       if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "formatted") == 0) {
9757         sem.defined_io_type = 3;
9758       } else if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "unformatted") == 0) {
9759         sem.defined_io_type = 4;
9760       } else {
9761         error(155, 3, gbl.lineno, "(FORMATTED) or (UNFORMATTED) "
9762                                   "follow defined WRITE",
9763               CNULL);
9764         sem.defined_io_type = 0;
9765       }
9766     } else {
9767       error(155, 3, gbl.lineno, "Invalid generic specification -",
9768             SYMNAME(SST_SYMG(RHS(1))));
9769       sem.defined_io_type = 0;
9770     }
9771     if (i && sem.defined_io_type && i != sem.defined_io_type) {
9772       char *name_cpy;
9773       name_cpy = getitem(0,
9774                          strlen(SYMNAME(SST_SYMG(RHS(1)))) +
9775                              strlen(SYMNAME(SST_SYMG(RHS(3)))) + 1);
9776       sprintf(name_cpy, "%s(%s)", SYMNAME(SST_SYMG(RHS(1))),
9777               SYMNAME(SST_SYMG(RHS(3))));
9778       error(155, 3, gbl.lineno,
9779             "Generic name for INTERFACE statement "
9780             "does not match generic name for END INTERFACE ",
9781             name_cpy);
9782     } else if (!i && sem.defined_io_type) {
9783       sptr = getsymf(".%s", SYMNAME(SST_SYMG(RHS(1))));
9784       IGNOREP(sptr, TRUE);
9785       SST_SYMP(LHS, sptr);
9786     }
9787     break;
9788 
9789   /* ------------------------------------------------------------------ */
9790   /*
9791    *	<operator> ::= <intrinsic op> |
9792    */
9793   case OPERATOR1:
9794     if (scn.stmtyp != TK_ENDINTERFACE)
9795       sptr = get_intrinsic_opr(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1)));
9796     else
9797       sptr = get_intrinsic_oprsym(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1)));
9798     SST_IDP(LHS, 1);
9799     SST_LSYMP(LHS, sptr);
9800     break;
9801   /*
9802    *	<operator> ::= . <ident> .
9803    */
9804   case OPERATOR2:
9805     sptr = SST_SYMG(RHS(2));
9806     if (!sem.generic_tbp || !STYPEG(sptr) || SCOPEG(sptr) != stb.curr_scope) {
9807       if (STYPEG(sptr) == ST_PROC && VTOFFG(sptr) && !sem.generic_tbp) {
9808         /* Type bound procedure and generic operator can co-exist */
9809         sptr = insert_sym(sptr);
9810       }
9811       sptr = declsym(sptr, ST_OPERATOR, FALSE);
9812     }
9813     SST_IDP(LHS, 1);
9814     SST_LSYMP(LHS, sptr);
9815     if (scn.stmtyp == TK_INTERFACE) {
9816       char *anm;
9817       anm = NULL;
9818       if (strcmp(SYMNAME(sptr), "x") == 0)
9819         anm = ".x.";
9820       else if (strcmp(SYMNAME(sptr), "xor") == 0)
9821         anm = ".xor.";
9822       else if (strcmp(SYMNAME(sptr), "o") == 0)
9823         anm = ".o.";
9824       else if (strcmp(SYMNAME(sptr), "n") == 0)
9825         anm = ".n.";
9826       if (anm) {
9827         error(155, 1, gbl.lineno,
9828               "Predefined intrinsic operator loses intrinsic property -", anm);
9829       }
9830     }
9831     break;
9832   /*
9833    *	<operator> ::= <defined op>
9834    */
9835   case OPERATOR3:
9836     sptr = SST_SYMG(RHS(1));
9837     SST_IDP(LHS, 1);
9838     SST_LSYMP(LHS, sptr);
9839     break;
9840 
9841   /* ------------------------------------------------------------------ */
9842   /*
9843    *	<intrinsic op> ::= <addop>   |
9844    */
9845   case INTRINSIC_OP1:
9846     SST_IDP(LHS, 0);
9847     SST_LSYMP(LHS, 3); /* unary and binary */
9848     break;
9849   /*
9850    *	<intrinsic op> ::= <mult op> |
9851    */
9852   case INTRINSIC_OP2:
9853     SST_IDP(LHS, 0);
9854     SST_LSYMP(LHS, 2); /* binary */
9855     break;
9856   /*
9857    *	<intrinsic op> ::= **        |
9858    */
9859   case INTRINSIC_OP3:
9860     SST_IDP(LHS, 0);
9861     SST_OPTYPEP(LHS, OP_XTOI);
9862     SST_LSYMP(LHS, 2); /* binary */
9863     break;
9864   /*
9865    *	<intrinsic op> ::= <n eqv op> |
9866    */
9867   case INTRINSIC_OP4:
9868     break;
9869   /*
9870    *	<intrinsic op> ::= .OR.      |
9871    */
9872   case INTRINSIC_OP5:
9873     SST_IDP(LHS, 0);
9874     SST_OPTYPEP(LHS, OP_LOR);
9875     SST_LSYMP(LHS, 2); /* binary */
9876     break;
9877   /*
9878    *    <intrinsic op> ::= .O.       |
9879    */
9880   case INTRINSIC_OP6:
9881     SST_IDP(LHS, TK_ORX);
9882     SST_OPTYPEP(LHS, OP_LOR);
9883     SST_LSYMP(LHS, 2); /* binary */
9884     break;
9885   /*
9886    *	<intrinsic op> ::= .AND.     |
9887    */
9888   case INTRINSIC_OP7:
9889     SST_IDP(LHS, 0);
9890     SST_OPTYPEP(LHS, OP_LAND);
9891     SST_LSYMP(LHS, 2); /* binary */
9892     break;
9893   /*
9894    *	<intrinsic op> ::= .NOT.     |
9895    */
9896   case INTRINSIC_OP8:
9897     SST_IDP(LHS, 0);
9898     SST_OPTYPEP(LHS, OP_LNOT);
9899     SST_LSYMP(LHS, 1); /* unary */
9900     break;
9901   /*
9902    *    <intrinsic op> ::= .N.       |
9903    */
9904   case INTRINSIC_OP9:
9905     SST_IDP(LHS, TK_NOTX);
9906     SST_OPTYPEP(LHS, OP_LNOT);
9907     SST_LSYMP(LHS, 1); /* unary */
9908     break;
9909   /*
9910    *	<intrinsic op> ::= <relop>   |
9911    */
9912   case INTRINSIC_OP10:
9913     SST_IDP(LHS, 0);
9914     SST_LSYMP(LHS, 2); /* binary */
9915     break;
9916   /*
9917    *	<intrinsic op> ::= '//'
9918    */
9919   case INTRINSIC_OP11:
9920     SST_IDP(LHS, 0);
9921     SST_OPTYPEP(LHS, OP_CAT);
9922     SST_LSYMP(LHS, 2); /* binary */
9923     break;
9924 
9925   /* ------------------------------------------------------------------ */
9926   /*
9927    *	<n eqv op> ::= .EQV. |
9928    */
9929   case N_EQV_OP1:
9930     SST_IDP(LHS, 0);
9931     SST_OPTYPEP(LHS, OP_LEQV);
9932     SST_LSYMP(LHS, 2); /* binary */
9933     break;
9934   /*
9935    *	<n eqv op> ::= .NEQV. |
9936    */
9937   case N_EQV_OP2:
9938     SST_IDP(LHS, 0);
9939     SST_OPTYPEP(LHS, OP_LNEQV);
9940     SST_LSYMP(LHS, 2); /* binary */
9941     break;
9942   /*
9943    *	<n eqv op> ::= .X. |
9944    */
9945   case N_EQV_OP3:
9946     SST_IDP(LHS, TK_XORX);
9947     SST_OPTYPEP(LHS, OP_LNEQV);
9948     SST_LSYMP(LHS, 2); /* binary */
9949     break;
9950   /*
9951    *	<n eqv op> ::= .XOR.
9952    */
9953   case N_EQV_OP4:
9954     SST_IDP(LHS, TK_XOR);
9955     SST_OPTYPEP(LHS, OP_LNEQV);
9956     SST_LSYMP(LHS, 2); /* binary */
9957     break;
9958 
9959   /* ------------------------------------------------------------------ */
9960   /*
9961    *      <end interface> ::= ENDINTERFACE |
9962    */
9963   case END_INTERFACE1:
9964     rhstop = 1;
9965     goto end_interface_shared;
9966   /*
9967    *	<end interface> ::= ENDINTERFACE <generic spec>
9968    */
9969   case END_INTERFACE2:
9970     rhstop = 2;
9971   end_interface_shared:
9972     if (sem.interface == 0) {
9973       error(302, 3, gbl.lineno, "INTERFACE", CNULL);
9974       SST_ASTP(LHS, 0);
9975       break;
9976     }
9977     if (gbl.currsub) {
9978       error(303, 2, gbl.lineno, SYMNAME(gbl.currsub), CNULL);
9979       pop_subprogram();
9980       pop_scope_level(SCOPE_NORMAL);
9981     }
9982     sem.interface--;
9983     restore_host(&sem.interf_base[sem.interface], FALSE);
9984     sptr = sem.interf_base[sem.interface].generic;
9985     if (sptr)
9986       check_generic(sptr);
9987     else if ((sptr = sem.interf_base[sem.interface].operator))
9988       check_generic(sptr);
9989     if (sem.scope_stack[sem.scope_level].kind == SCOPE_INTERFACE) {
9990       pop_scope_level(SCOPE_INTERFACE);
9991     }
9992     if (sptr && rhstop == 2 && !sem.defined_io_type) {
9993       sptr1 = SST_SYMG(RHS(2));
9994       if (strcmp(SYMNAME(sptr), SYMNAME(sptr1)))
9995         error(309, 3, gbl.lineno, SYMNAME(sptr1), CNULL);
9996     }
9997     sem.defined_io_type = 0;
9998     break;
9999   /*
10000    *	<module procedure stmt> ::= MODULE PROCEDURE <ident list> |
10001    *	                            MODULE PROCEDURE :: <ident list>
10002    */
10003   case MODULE_PROCEDURE_STMT1:
10004     rhstop = 3;
10005     goto module_procedure_stmt;
10006   case MODULE_PROCEDURE_STMT2:
10007     rhstop = 4;
10008 module_procedure_stmt:
10009     if (IN_MODULE &&
10010         !sem.interface &&
10011         (itemp = SST_BEGG(RHS(rhstop))) != ITEM_END &&
10012         itemp->next == ITEM_END) {
10013       /* MODULE PROCEDURE <id> - begin separate module subprogram */
10014       sptr = itemp->t.sptr;
10015 
10016       /* C1548: checking MODULE prefix for subprograms that were
10017               declared as separate module procedures */
10018       if (!sem.interface &&
10019           !SEPARATEMPG(sptr) && !SEPARATEMPG(ref_ident(sptr)))
10020           error(1056, ERR_Severe, gbl.lineno, NULL, NULL);
10021 
10022       gbl.currsub = instantiate_interface(sptr);
10023       sem.module_procedure = TRUE;
10024       gbl.rutype = FVALG(sptr) > NOSYM ? RU_FUNC : RU_SUBR;
10025       push_scope_level(sptr, SCOPE_NORMAL);
10026       push_scope_level(sptr, SCOPE_SUBPROGRAM);
10027       sem.pgphase = PHASE_HEADER;
10028       SST_ASTP(LHS, 0);
10029       break;
10030     }
10031     gnr = sem.interf_base[sem.interface - 1].generic;
10032     if (gnr == 0) {
10033       gnr = sem.interf_base[sem.interface - 1].operator;
10034       if (gnr == 0) {
10035         error(195, 3, gbl.lineno,
10036               "- MODULE PROCEDURE requires a generic INTERFACE", CNULL);
10037         break;
10038       }
10039     }
10040     count = 0;
10041     for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; itemp = itemp->next) {
10042       sptr = itemp->t.sptr;
10043       /* make the 'interface' scope 'open' temporarily */
10044       sem.scope_stack[sem.scope_level].open = TRUE;
10045       if (!IN_MODULE) {
10046         sptr = refsym(sptr, OC_OTHER);
10047         if (STYPEG(sptr) != ST_PROC)
10048           error(195, 3, gbl.lineno, "- Unable to access module procedure",
10049                 CNULL);
10050         if (ENCLFUNCG(sptr) == 0 || STYPEG(ENCLFUNCG(sptr)) != ST_MODULE) {
10051           error(454, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10052         }
10053       } else {
10054         if (STYPEG(sptr) == ST_PROC && !sem.which_pass && !INMODULEG(sptr)) {
10055           error(454, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10056         }
10057         sptr = declsym(sptr, ST_MODPROC, FALSE);
10058         if (SYMLKG(sptr) == NOSYM)
10059           SYMLKP(sptr, 0);
10060         /* rescope modproc to 'module' scope */
10061         SCOPEP(sptr, sem.scope_stack[sem.scope_level - 1].sptr);
10062         i = add_symitem(gnr, SYMIG(sptr));
10063         SYMIP(sptr, i);
10064       }
10065       /* close the 'interface' scope again */
10066       sem.scope_stack[sem.scope_level].open = FALSE;
10067       add_overload(gnr, sptr);
10068       if (STYPEG(SCOPEG(sptr)) == ST_MODULE) {
10069         /* make sure we include module name when generating
10070          * the symbol name.
10071          */
10072         INMODULEP(sptr, 1);
10073       }
10074             if (bind_attr.altname && (++count > 1))
10075                 error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
10076         if (bind_attr.exist != -1) {
10077           process_bind(sptr);
10078         }
10079     }
10080     bind_attr.exist = -1;
10081     bind_attr.altname = 0;
10082     break;
10083   /*
10084    *      <procedure stmt> ::= PROCEDURE <ident list> |
10085    *                           PROCEDURE :: <ident list>
10086    */
10087   case PROCEDURE_STMT1:
10088     rhstop = 2;
10089     goto procedure_stmt;
10090   case PROCEDURE_STMT2:
10091     rhstop = 3;
10092 procedure_stmt:
10093     if (sem.interface == 0) {
10094       error(155, 3, gbl.lineno, "PROCEDURE must appear in an INTERFACE", CNULL);
10095       break;
10096     }
10097     gnr = sem.interf_base[sem.interface - 1].generic;
10098     if (gnr == 0) {
10099       gnr = sem.interf_base[sem.interface - 1].operator;
10100       if (gnr == 0) {
10101         error(195, 3, gbl.lineno, "- PROCEDURE requires a generic INTERFACE",
10102               CNULL);
10103         break;
10104       }
10105     }
10106     count = 0;
10107     for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; itemp = itemp->next) {
10108       sptr = itemp->t.sptr;
10109       /* make the 'interface' scope 'open' temporarily */
10110       sem.scope_stack[sem.scope_level].open = TRUE;
10111       sptr = refsym(sptr, OC_OTHER);
10112       if (STYPEG(sptr) != ST_PROC) {
10113         if (STYPEG(sptr) == ST_USERGENERIC) {
10114           sptr = insert_sym(sptr);
10115         }
10116         sptr = declsym(sptr, ST_PROC, FALSE);
10117         if (SYMLKG(sptr) == NOSYM)
10118           SYMLKP(sptr, 0);
10119         /* rescope proc to 'host' scope */
10120         SCOPEP(sptr, sem.scope_stack[sem.scope_level - 1].sptr);
10121         i = add_symitem(gnr, SYMIG(sptr));
10122         SYMIP(sptr, i);
10123       }
10124       /* close the 'interface' scope again */
10125       sem.scope_stack[sem.scope_level].open = FALSE;
10126       add_overload(gnr, sptr);
10127     }
10128     bind_attr.exist = -1;
10129     bind_attr.altname = 0;
10130     break;
10131 
10132   /* ------------------------------------------------------------------ */
10133   /*
10134    *	<use> ::= <get module> |
10135    */
10136   case USE1:
10137     add_use_stmt();
10138     break;
10139   /*
10140    *	<use> ::= <get module> , <rename list> |
10141    */
10142   case USE2:
10143     break;
10144   /*
10145    *	<use> ::= <get module> , <id name> : <only list> |
10146    */
10147   case USE3:
10148   /*  fall thru  */
10149   /*
10150    *      <use> ::= <get module> , <id name> :
10151    */
10152   case USE4:
10153     np = scn.id.name + SST_CVALG(RHS(3));
10154     if (sem_strcmp(np, "only") != 0)
10155       error(34, 3, gbl.lineno, np, CNULL);
10156     break;
10157 
10158   /* ------------------------------------------------------------------  */
10159   /*
10160    *
10161    *      <get module> ::= , <module nature> :: <id> |
10162    */
10163   case GET_MODULE2:
10164 
10165     sptr = SST_SYMG(RHS(4));
10166 
10167     /* Undo context sensitive scanner confusion.  This is a
10168        use statement, even though it contains a TK_INTRINSIC token
10169        This allows  us to move into PHASE_USE.
10170      */
10171     if ((scn.stmtyp == TK_INTRINSIC) || (scn.stmtyp == TK_NON_INTRINSIC))
10172       scn.stmtyp = TK_USE;
10173 
10174     /* check and enable ISO_C_BINDING INTRINSICS HERE? */
10175     if (SST_IDG(RHS(2))) {
10176 /* use, intrinsic :: the only one we support is
10177    iso_c_binding
10178 */
10179 
10180     } else {
10181       if (strcmp(SYMNAME(sptr), "iso_c_binding") == 0)
10182         error(4, 3, gbl.lineno, "invalid non-intrinsic module", SYMNAME(sptr));
10183     }
10184     goto common_module;
10185     break;
10186   /*
10187    *      <get module> ::= :: <id>
10188    */
10189   case GET_MODULE3:
10190     sptr = SST_SYMG(RHS(2));
10191     goto common_module;
10192     break;
10193   /*
10194    *	<get module> ::= <id> |
10195    */
10196   case GET_MODULE1:
10197     sptr = SST_SYMG(RHS(1));
10198   common_module:
10199     sem.use_seen = 1;
10200     init_use_stmts();
10201     if (XBIT(68, 0x1)) {
10202       /* Append "_la" to the names of some modules. */
10203       static const char *names[] = {"ieee_exceptions", "ieee_arithmetic",
10204                                     "cudafor",         "openacc",
10205                                     "accel_lib",       NULL};
10206       int j;
10207       for (j = 0; names[j]; ++j) {
10208         if (strcmp(SYMNAME(sptr), names[j]) == 0) {
10209           sptr = getsymf("%s", SYMNAME(sptr));
10210           break;
10211         }
10212       }
10213     }
10214     if (IN_MODULE && strcmp(SYMNAME(sem.mod_sym), SYMNAME(sptr)) == 0) {
10215       error(4, 3, gbl.lineno, "MODULE cannot contain USE of itself -",
10216             SYMNAME(sptr));
10217       break;
10218     }
10219     if (sptr >= stb.firstusym && STYPEG(sptr) != ST_UNKNOWN &&
10220         STYPEG(sptr) != ST_MODULE) {
10221       int nsptr;
10222       /* see if this is really an error, or just an overloaded symbol */
10223       nsptr = sym_in_scope(sptr, stb.ovclass[ST_MODULE], NULL, NULL, 0);
10224       if (nsptr > 0 && (nsptr < stb.firstusym || STYPEG(nsptr) == ST_UNKNOWN ||
10225                         STYPEG(nsptr) == ST_MODULE)) {
10226         sptr = nsptr;
10227       } else {
10228         sptr = insert_sym(sptr);
10229       }
10230     }
10231     open_module(sptr);
10232     break;
10233 
10234   /* ------------------------------------------------------------------ */
10235   /*
10236    *      <module nature> ::= INTRINSIC |
10237    */
10238   case MODULE_NATURE1:
10239     SST_IDP(LHS, 1);
10240     break;
10241   /*
10242    *      <module nature> ::= NON_INTRINSIC
10243    */
10244   case MODULE_NATURE2:
10245     SST_IDP(LHS, 0);
10246     break;
10247 
10248   /* ------------------------------------------------------------------ */
10249   /*
10250    *	<rename list> ::= <rename list> , <rename> |
10251    */
10252   case RENAME_LIST1:
10253     break;
10254   /*
10255    *	<rename list> ::= <rename>
10256    */
10257   case RENAME_LIST2:
10258     break;
10259 
10260   /* ------------------------------------------------------------------ */
10261   /*
10262    *	<rename> ::= <ident> '=>' <ident> |
10263    */
10264   case RENAME1:
10265     add_use_stmt();
10266     sptr = SST_SYMG(RHS(3));
10267     sptr = add_use_rename((int)SST_SYMG(RHS(1)), sptr, 0);
10268     SST_SYMP(RHS(3), sptr);
10269     break;
10270   /*
10271    *	<rename> ::= <id name> ( <rename operator> ) '=>' <id name> ( <rename
10272    *operator> )
10273    */
10274   case RENAME2:
10275     add_use_stmt();
10276     np = scn.id.name + SST_CVALG(RHS(1));
10277     if (sem_strcmp(np, "operator") == 0) {
10278       np = scn.id.name + SST_CVALG(RHS(6));
10279       if (sem_strcmp(np, "operator")) {
10280         error(34, 3, gbl.lineno, np, CNULL);
10281         break;
10282       }
10283     } else {
10284       error(34, 3, gbl.lineno, np, CNULL);
10285       break;
10286     }
10287     /* local (RHS(3)) => global (RHS(8)) */
10288     sptr = add_use_rename(SST_SYMG(RHS(3)), SST_SYMG(RHS(8)), 1);
10289     break;
10290 
10291   /* ------------------------------------------------------------------ */
10292   /*
10293    *	<rename operator> ::= . <ident> .    |
10294    */
10295   case RENAME_OPERATOR1:
10296     SST_SYMP(LHS, SST_SYMG(RHS(2)));
10297     break;
10298   /*
10299    *	<rename operator> ::= <defined op>
10300    */
10301   case RENAME_OPERATOR2:
10302     break;
10303 
10304   /* ------------------------------------------------------------------ */
10305   /*
10306    *	<only list> ::= <only list> , <only> |
10307    */
10308   case ONLY_LIST1:
10309     break;
10310   /*
10311    *	<only list> ::= <only>
10312    */
10313   case ONLY_LIST2:
10314     break;
10315 
10316   /* ------------------------------------------------------------------ */
10317   /*
10318    *	<only> ::= <ident> |
10319    */
10320   case ONLY1:
10321     sptr = SST_SYMG(RHS(1));
10322     sptr = add_use_rename(0, sptr, 0);
10323     SST_SYMP(RHS(1), sptr);
10324     break;
10325   /*
10326    *	<only> ::= <ident> '=>' <ident> |
10327    */
10328   case ONLY2:
10329     sptr = SST_SYMG(RHS(3));
10330     sptr = add_use_rename((int)SST_SYMG(RHS(1)), sptr, 0);
10331     SST_SYMP(RHS(3), sptr);
10332     break;
10333   /*
10334    *	<only> ::= <id name> ( <only operator> ) |
10335    */
10336   case ONLY3:
10337     np = scn.id.name + SST_CVALG(RHS(1));
10338     if (sem_strcmp(np, "operator") == 0) {
10339       sptr = add_use_rename(0, SST_SYMG(RHS(3)), 1);
10340       SST_SYMP(RHS(3), sptr);
10341     } else
10342       error(34, 3, gbl.lineno, np, CNULL);
10343     break;
10344   /*
10345    *	<only> ::= <id name> ( = )
10346    */
10347   case ONLY4:
10348     np = scn.id.name + SST_CVALG(RHS(1));
10349     if (sem_strcmp(np, "assignment") == 0) {
10350       sptr = get_intrinsic_oprsym(OP_ST, 0);
10351       add_use_rename(0, sptr, 1);
10352     } else
10353       error(34, 3, gbl.lineno, np, CNULL);
10354     break;
10355 
10356   /* ------------------------------------------------------------------ */
10357   /*
10358    *	<only operator> ::= <intrinsic op> |
10359    */
10360   case ONLY_OPERATOR1:
10361     sptr = get_intrinsic_oprsym(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1)));
10362     SST_SYMP(LHS, sptr);
10363     break;
10364   /*
10365    *	<only operator> ::= . <ident> .    |
10366    */
10367   case ONLY_OPERATOR2:
10368     SST_SYMP(LHS, SST_SYMG(RHS(2)));
10369     break;
10370   /*
10371    *	<only operator> ::= <defined op>
10372    */
10373   case ONLY_OPERATOR3:
10374     break;
10375 
10376   /* ------------------------------------------------------------------ */
10377   /*
10378    *	<tp list> ::= <tp list> , <tp item> |
10379    */
10380   case TP_LIST1:
10381     rhstop = 3;
10382     goto add_tp_to_list;
10383   /*
10384    *	<tp list> ::= <tp item>
10385    */
10386   case TP_LIST2:
10387     rhstop = 1;
10388   add_tp_to_list:
10389     itemp = (ITEM *)getitem(0, sizeof(ITEM));
10390     itemp->next = ITEM_END;
10391     itemp->t.sptr = SST_SYMG(RHS(rhstop));
10392     if (rhstop == 1)
10393       /* adding first item to list */
10394       SST_BEGP(LHS, itemp);
10395     else
10396       /* adding subsequent items to list */
10397       SST_ENDG(RHS(1))->next = itemp;
10398     SST_ENDP(LHS, itemp);
10399     break;
10400 
10401   /* ------------------------------------------------------------------ */
10402   /*
10403    *	<tp item> ::= <common> |
10404    */
10405   case TP_ITEM1:
10406     break;
10407   /*
10408    *	<tp item> ::= <ident>
10409    */
10410   case TP_ITEM2:
10411     sptr = refsym(SST_SYMG(RHS(1)), OC_OTHER);
10412     SST_SYMP(LHS, sptr);
10413     break;
10414 
10415   /* ------------------------------------------------------------------ */
10416   /*
10417    *	<dec declaration> ::= ATTRIBUTES <msattr list> :: <cmn ident list> |
10418    */
10419   case DEC_DECLARATION1:
10420     for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
10421       int da_bitv;
10422       sptr = itemp->t.sptr;
10423       if (sptr == 0)
10424         continue;
10425       if (STYPEG(sptr) != ST_CMBLK)
10426         sptr = refsym_inscope(sptr, OC_OTHER);
10427       da_type = 0;
10428       for (da_bitv = dec_attr.exist; da_bitv; da_bitv >>= 1, da_type++) {
10429         if ((da_bitv & 1) == 0)
10430           continue;
10431         switch (da_type) {
10432         case DA_ALIAS:
10433 
10434 #if defined(TARGET_WIN)
10435           /* silently disallow ALIAS of winmain : it conflicts
10436              with our crt0.obj glue
10437            */
10438           if (strcmp(SYMNAME(sptr), "winmain") == 0)
10439             break;
10440 #endif
10441           ALTNAMEP(sptr, dec_attr.altname);
10442           goto global_attrs;
10443         case DA_C:
10444           CFUNCP(sptr, 1);
10445           STDCALLP(sptr, 1); /* args must be passed by value */
10446           if (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY) {
10447             MSCALLP(sptr, 0);
10448           }
10449           goto global_attrs;
10450         case DA_STDCALL:
10451           STDCALLP(sptr, 1);
10452 #ifdef CREFP
10453           CREFP(sptr, 0);
10454           MSCALLP(sptr, 1);
10455 #endif
10456           goto global_attrs;
10457         case DA_REFERENCE:
10458           if ((STYPEG(sptr) == ST_ENTRY) || (STYPEG(sptr) == ST_PROC))
10459             ss = sptr;
10460           else
10461             ss = gbl.currsub;
10462           PASSBYVALP(sptr, 0);
10463           PASSBYREFP(sptr, 1);
10464 #ifdef CREFP
10465           if (CFUNCG(sptr)) {
10466             MSCALLP(sptr, 0);
10467             CREFP(sptr, 1);
10468           }
10469 #endif
10470           goto global_attrs;
10471 
10472         case DA_VALUE:
10473           if ((STYPEG(sptr) == ST_ENTRY) || (STYPEG(sptr) == ST_PROC))
10474             ss = sptr;
10475           else
10476             ss = gbl.currsub;
10477           PASSBYVALP(sptr, 1);
10478           PASSBYREFP(sptr, 0);
10479           goto global_attrs;
10480 
10481         case DA_DLLEXPORT:
10482           if (IN_MODULE && sem.interface == 0 && STYPEG(sptr) != ST_CMBLK) {
10483             sem.mod_dllexport = TRUE;
10484             if (sptr == gbl.currmod)
10485               break;
10486           } else {
10487             DLLP(sptr, DLL_EXPORT);
10488           }
10489           goto global_attrs;
10490         case DA_DLLIMPORT:
10491           DLLP(sptr, DLL_IMPORT);
10492           goto global_attrs;
10493         case DA_DECORATE:
10494           DECORATEP(sptr, 1);
10495           goto global_attrs;
10496         case DA_NOMIXEDSLA:
10497 #ifdef CREFP
10498           NOMIXEDSTRLENP(sptr, 1);
10499 #endif
10500         /*  fall thru  */
10501         global_attrs:
10502           switch (STYPEG(sptr)) {
10503           case ST_CMBLK:
10504           case ST_ENTRY:
10505           case ST_PROC:
10506           case ST_UNKNOWN: /* allow undeclared identifiers */
10507             break;
10508           case ST_IDENT:
10509           case ST_VAR:
10510           case ST_ARRAY:
10511           case ST_STRUCT:
10512             if (da_type == DA_DLLEXPORT) {
10513               if (IN_MODULE && sem.interface == 0) {
10514                 if ((SCG(sptr) == SC_CMBLK && !HCCSYMG(CMBLKG(sptr))) ||
10515                     SCOPEG(sptr) != gbl.currmod) {
10516                   error(84, 3, gbl.lineno, SYMNAME(sptr),
10517                         "- ATTRIBUTES items must be global");
10518                 }
10519                 break;
10520               }
10521             } else if ((da_type == DA_VALUE) || (da_type == DA_REFERENCE)) {
10522               break;
10523             }
10524 
10525           /*  fall thru  */
10526           default:
10527             error(84, 3, gbl.lineno, SYMNAME(sptr),
10528                   "- must be defined for ATTRIBUTES");
10529           }
10530           break;
10531         default:
10532           break;
10533         }
10534       }
10535     }
10536     dec_attr.exist = 0;
10537     break;
10538   /*
10539    *	<dec declaration> ::= ALIAS <ident> , <alt name>
10540    */
10541   case DEC_DECLARATION2:
10542   /*
10543    *	<dec declaration> ::= ALIAS <ident> : <alt name>
10544    */
10545   case DEC_DECLARATION3:
10546     sptr = refsym_inscope((int)SST_SYMG(RHS(2)), OC_OTHER);
10547     ALTNAMEP(sptr, SST_SYMG(RHS(4)));
10548     break;
10549 
10550   /* ------------------------------------------------------------------ */
10551   /*
10552    *	<msattr list> ::= <msattr list> , <msattr> |
10553    */
10554   case MSATTR_LIST1:
10555   /* fall thru */
10556   /*
10557    *	<msattr list> ::= <msattr>
10558    */
10559   case MSATTR_LIST2:
10560     if (da_type == -1)
10561       break;
10562     if (dec_attr.exist & DA_B(da_type))
10563       error(134, 3, gbl.lineno, "- duplicate", da[da_type].name);
10564     else if (dec_attr.exist & da[da_type].no)
10565       error(134, 3, gbl.lineno, "- conflict with", da[da_type].name);
10566     else
10567       dec_attr.exist |= DA_B(da_type);
10568     break;
10569 
10570   /* ------------------------------------------------------------------ */
10571   /*
10572    *	<msattr> ::= <id name> |
10573    */
10574   case MSATTR1:
10575     da_type = -1;
10576     np = scn.id.name + SST_CVALG(RHS(1));
10577     if (strcmp(np, "alias") == 0) {
10578       error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np);
10579     } else if (strcmp(np, "c") == 0)
10580       da_type = DA_C;
10581     else if (strcmp(np, "stdcall") == 0)
10582       da_type = DA_STDCALL;
10583     else if (sem_strcmp(np, "dllexport") == 0)
10584       da_type = DA_DLLEXPORT;
10585     else if (sem_strcmp(np, "dllimport") == 0)
10586       da_type = DA_DLLIMPORT;
10587     else if (sem_strcmp(np, "value") == 0)
10588       da_type = DA_VALUE;
10589     else if (sem_strcmp(np, "reference") == 0)
10590       da_type = DA_REFERENCE;
10591     else if (sem_strcmp(np, "decorate") == 0)
10592       da_type = DA_DECORATE;
10593     else if (sem_strcmp(np, "nomixed_str_len_arg") == 0)
10594       da_type = DA_NOMIXEDSLA;
10595     else
10596       error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np);
10597     break;
10598   /*
10599    *	<msattr> ::= <id name> : <alt name>
10600    */
10601   case MSATTR2:
10602     da_type = -1;
10603     np = scn.id.name + SST_CVALG(RHS(1));
10604     if (strcmp(np, "alias") == 0) {
10605       da_type = DA_ALIAS;
10606       dec_attr.altname = SST_SYMG(RHS(3));
10607     } else
10608       error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np);
10609     break;
10610 
10611   /* ------------------------------------------------------------------ */
10612   /*
10613    *	<alt name> ::= <quoted string> |
10614    */
10615   case ALT_NAME1:
10616     break;
10617   /*
10618    *	<alt name> ::= <id name>
10619    */
10620   case ALT_NAME2:
10621     /* NEED TO UPCASE the name */
10622     for (np = scn.id.name + SST_CVALG(RHS(1)); (i = *np); np++) {
10623       if (i >= 'a' && i <= 'z')
10624         *np = i + ('A' - 'a');
10625     }
10626     np = scn.id.name + SST_CVALG(RHS(1));
10627     sptr = getstring(np, strlen(np));
10628     SST_SYMP(LHS, sptr);
10629     break;
10630 
10631   /* ------------------------------------------------------------------ */
10632   /*
10633    *	<cmn ident list> ::= <cmn ident list> , <cmn ident> |
10634    */
10635   case CMN_IDENT_LIST1:
10636     rhstop = 3;
10637     goto add_cmn_to_list;
10638   /*
10639    *	<cmn ident list> ::= <cmn ident>
10640    */
10641   case CMN_IDENT_LIST2:
10642     rhstop = 1;
10643   add_cmn_to_list:
10644     itemp = (ITEM *)getitem(0, sizeof(ITEM));
10645     itemp->next = ITEM_END;
10646     itemp->t.sptr = SST_SYMG(RHS(rhstop));
10647     if (rhstop == 1)
10648       /* adding first item to list */
10649       SST_BEGP(LHS, itemp);
10650     else
10651       /* adding subsequent items to list */
10652       SST_ENDG(RHS(1))->next = itemp;
10653     SST_ENDP(LHS, itemp);
10654     break;
10655 
10656   /* ------------------------------------------------------------------ */
10657   /*
10658    *	<cmn ident> ::= <common> |
10659    */
10660   case CMN_IDENT1:
10661     sptr = SST_SYMG(RHS(1));
10662     if (sem.which_pass && CMEMFG(sptr) == 0)
10663       error(38, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10664     break;
10665   /*
10666    *	<cmn ident> ::= <ident>
10667    */
10668   case CMN_IDENT2:
10669     sptr = SST_SYMG(RHS(1));
10670     if (STYPEG(sptr) == ST_CMBLK) {
10671       sptr = refsym(sptr, OC_OTHER);
10672       SST_SYMP(LHS, sptr);
10673     }
10674     break;
10675 
10676   /* ------------------------------------------------------------------ */
10677   /*
10678    *	<pragma declaration> ::= <nis> LOCAL ( <ident list> ) |
10679    */
10680   case PRAGMA_DECLARATION1:
10681     break;
10682   /*
10683    *	<pragma declaration> ::= <nis> <ignore tkr> |
10684    */
10685   case PRAGMA_DECLARATION2:
10686     if (!sem.interface && !(IN_MODULE && gbl.currsub)) {
10687       error(155, 3, gbl.lineno,
10688             "IGNORE_TKR can only appear in an interface body"
10689             " or a module procedure",
10690             CNULL);
10691     }
10692     break;
10693   /*
10694    *	<pragma declaration> ::= <nis> DEFAULTKIND <dflt> |
10695    */
10696   case PRAGMA_DECLARATION3:
10697     break;
10698   /*
10699    *	<pragma declaration> ::= <nis> MOVEDESC <id name>
10700    */
10701   case PRAGMA_DECLARATION4:
10702 #if defined(MVDESCP)
10703     np = scn.id.name + SST_CVALG(RHS(3));
10704     if (gbl.currsub && sem_strcmp(np, SYMNAME(gbl.currsub)) == 0) {
10705       MVDESCP(gbl.currsub, 1);
10706     }
10707 #endif
10708     break;
10709 
10710   /* ------------------------------------------------------------------ */
10711   /*
10712    *	<ignore tkr> ::= IGNORE_TKR |
10713    */
10714   case IGNORE_TKR1:
10715     if (sem.interface || (IN_MODULE && gbl.currsub)) {
10716       /* must be in interface -- if not, an error will be reported* later */
10717       count = PARAMCTG(gbl.currsub);
10718       i = DPDSCG(gbl.currsub);
10719       while (count--) {
10720         sptr = *(aux.dpdsc_base + i + count);
10721         /* IGNORE_TKR_ALL includes all of the IGNORE_ values plus
10722          * an indicater except for IGNORE_C
10723          */
10724         IGNORE_TKRP(sptr, IGNORE_TKR_ALL);
10725       }
10726     }
10727     break;
10728   /*
10729    *	<ignore tkr> ::= IGNORE_TKR <tkr id list>
10730    */
10731   case IGNORE_TKR2:
10732     break;
10733 
10734   /* ------------------------------------------------------------------ */
10735   /*
10736    *	<tkr id list> ::= <tkr id list> , <tkr id> |
10737    */
10738   case TKR_ID_LIST1:
10739     break;
10740   /*
10741    *	<tkr id list> ::= <tkr id>
10742    */
10743   case TKR_ID_LIST2:
10744     break;
10745 
10746   /* ------------------------------------------------------------------ */
10747   /*
10748    *	<tkr id> ::= <tkr spec> <ident>
10749    */
10750   case TKR_ID1:
10751     sptr = refsym(SST_SYMG(RHS(2)), OC_OTHER);
10752     if (sem.interface || (IN_MODULE && gbl.currsub)) {
10753       /* must be in interface -- if not, an error will be reported* later */
10754       if (SCG(sptr) == SC_DUMMY)
10755         IGNORE_TKRP(sptr, IGNORE_TKRG(sptr) | SST_CVALG(RHS(1)));
10756       else
10757         error(134, 3, gbl.lineno,
10758               "- IGNORE_TKR specified for nondummy argument", SYMNAME(sptr));
10759     }
10760     break;
10761 
10762   /* ------------------------------------------------------------------ */
10763   /*
10764    *	<tkr spec> ::= |
10765    */
10766   case TKR_SPEC1:
10767     /*  NOT IGNORE_C  */
10768     SST_CVALP(LHS, IGNORE_T | IGNORE_K | IGNORE_R | IGNORE_D | IGNORE_M);
10769     break;
10770   /*
10771    *	<tkr spec> ::= ( <id name> )
10772    */
10773   case TKR_SPEC2:
10774     np = scn.id.name + SST_CVALG(RHS(2));
10775     conval = 0;
10776     count = strlen(np);
10777     for (i = 0; i < count; i++) {
10778       switch (np[i]) {
10779       case 't':
10780       case 'T':
10781         conval |= IGNORE_T;
10782         break;
10783       case 'k':
10784       case 'K':
10785         conval |= IGNORE_K;
10786         break;
10787       case 'r':
10788       case 'R':
10789         conval |= IGNORE_R;
10790         break;
10791       case 'a':
10792       case 'A':
10793         conval |= IGNORE_TKR_ALL;
10794         break;
10795       case 'd':
10796       case 'D':
10797         conval |= IGNORE_D;
10798         break;
10799       case 'm':
10800       case 'M':
10801         conval |= IGNORE_M;
10802         break;
10803       case 'c':
10804       case 'C':
10805         conval |= IGNORE_C;
10806         break;
10807       default:
10808         error(155, 3, gbl.lineno, "Illegal IGNORE_TKR specifier", CNULL);
10809         conval = 0;
10810         goto end_tkr_spec;
10811       }
10812     }
10813   end_tkr_spec:
10814     SST_CVALP(LHS, conval);
10815     break;
10816 
10817   /* ------------------------------------------------------------------ */
10818   /*
10819    *	<dflt> ::= |
10820    */
10821   case DFLT1:
10822 #ifdef DFLTP
10823     if (gbl.currsub) {
10824       DFLTP(gbl.currsub, 1);
10825     }
10826 #endif
10827     break;
10828   /*
10829    *	<dflt> ::= ( <ident list> )
10830    */
10831   case DFLT2:
10832 #ifdef DFLTP
10833     for (itemp = SST_BEGG(RHS(2)); itemp != ITEM_END; itemp = itemp->next) {
10834       sptr = getocsym(itemp->t.sptr, OC_OTHER, FALSE);
10835       if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) {
10836         DFLTP(sptr, 1);
10837       }
10838     }
10839 #endif
10840     break;
10841 
10842   /* ------------------------------------------------------------------ */
10843   /*
10844    *	<import> ::= IMPORT |
10845    */
10846   case IMPORT1:
10847     if (!sem.interface) {
10848       error(155, 3, gbl.lineno, "IMPORT can only appear in an interface body",
10849             CNULL);
10850     } else {
10851       sem.seen_import = TRUE;
10852     }
10853     break;
10854 
10855   /* ------------------------------------------------------------------ */
10856   /*
10857    *	<opt import> ::= |
10858    */
10859   case OPT_IMPORT1:
10860     if (sem.interface) {
10861       /*
10862        * The current context is:
10863        * interface
10864        *    ...
10865        *    subroutine/function  ...
10866        *        INPORT
10867        *    endsubroutine/endfunction
10868        *    ...
10869        * endinterfacie
10870        *
10871        * There should be three scope entries corresponding to this
10872        * context:
10873        *
10874        * scope_level-2 : SCOPE_INTERFACE
10875        * scope_level-1 : SCOPE_NORMAL
10876        * scope_level   : SCOPE_SUBPROGRAM
10877        *
10878        * for IMPORT without a list, just want to open up the SCOPE_NORMAL
10879        * so that host-associated symbols will be fouind.
10880        */
10881       for (i = sem.scope_level - 1; i >= 4; i--) {
10882         if (sem.scope_stack[i].kind == SCOPE_NORMAL) {
10883           sem.scope_stack[i].open = TRUE;
10884           break;
10885         }
10886       }
10887     }
10888     break;
10889   /*
10890    *	<opt import> ::= <opt attr> <import name list>
10891    */
10892   case OPT_IMPORT2:
10893     break;
10894 
10895   /* ------------------------------------------------------------------ */
10896   /*
10897    *	<import name list> ::= <import name list> , <import name> |
10898    */
10899   case IMPORT_NAME_LIST1:
10900     break;
10901   /*
10902    *	<import name list> ::= <import name>
10903    */
10904   case IMPORT_NAME_LIST2:
10905     break;
10906 
10907   /* ------------------------------------------------------------------ */
10908   /*
10909    *	<import name> ::= <ident>
10910    */
10911   case IMPORT_NAME1:
10912     if (sem.interface) {
10913       /*
10914        * The current context is:
10915        * interface
10916        *    ...
10917        *    subroutine/function  ...
10918        *        INPORT xxxx
10919        *    endsubroutine/endfunction
10920        *    ...
10921        * endinterfacie
10922        *
10923        * There should be three scope entries corresponding to this
10924        * context:
10925        *
10926        * scope_level-2 : SCOPE_INTERFACE
10927        * scope_level-1 : SCOPE_NORMAL
10928        * scope_level   : SCOPE_SUBPROGRAM
10929        *
10930        * add the host-associcated symbols to the import list of
10931        * the SCOPE_NORMAL entry.
10932        */
10933       sem_import_sym(SST_SYMG(RHS(1)));
10934     }
10935     break;
10936 
10937   /* ------------------------------------------------------------------ */
10938   /*
10939    *	<procedure declaration> ::= <procedure> <opt attr> <proc dcl list>
10940    */
10941   case PROCEDURE_DECLARATION1:
10942     entity_attr.exist = 0;
10943     bind_attr.exist = -1;
10944     bind_attr.altname = 0;
10945     break;
10946 
10947   /* ------------------------------------------------------------------ */
10948   /*
10949    *	<procedure> ::= PROCEDURE ( <proc interf> ) <opt proc attr>
10950    */
10951   case PROCEDURE1:
10952     break;
10953 
10954   /* ------------------------------------------------------------------ */
10955   /*
10956    *	<proc interf> ::= |
10957    */
10958   case PROC_INTERF1:
10959     sem.gdtype = -1;
10960     proc_interf_sptr = 0;
10961     break;
10962   /*
10963    *	<proc interf> ::= <id> |
10964    */
10965   case PROC_INTERF2:
10966     proc_interf_sptr = resolve_sym_aliases(SST_SYMG(RHS(1)));
10967     break;
10968   /*
10969    *	<proc interf> ::= <data type>
10970    */
10971   case PROC_INTERF3:
10972     proc_interf_sptr = 0;
10973     break;
10974 
10975   /* ------------------------------------------------------------------ */
10976   /*
10977    *	<opt proc attr> ::= |
10978    */
10979   case OPT_PROC_ATTR1:
10980     break;
10981   /*
10982    *	<opt proc attr> ::= , <proc attr list>
10983    */
10984   case OPT_PROC_ATTR2:
10985     if ((entity_attr.exist & ET_B(ET_PROTECTED)) &&
10986         !(entity_attr.exist & ET_B(ET_POINTER)))
10987       error(134, 3, gbl.lineno, et[ET_PROTECTED].name, "for procedure");
10988     break;
10989 
10990   /* ------------------------------------------------------------------ */
10991   /*
10992    *	<proc attr list> ::= <proc attr list> , <proc attr> |
10993    */
10994   case PROC_ATTR_LIST1:
10995   /*
10996    *	<proc attr list> ::= <proc attr>
10997    */
10998   case PROC_ATTR_LIST2:
10999     if (entity_attr.exist & ET_B(et_type))
11000       error(134, 3, gbl.lineno, "- duplicate", et[et_type].name);
11001     if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
11002       if (ET_B(et_type) &
11003           ~(ET_B(ET_POINTER) | ET_B(ET_PASS) | ET_B(ET_NOPASS) |
11004             ET_B(ET_ACCESS))) {
11005         error(134, 3, gbl.lineno, et[et_type].name, "for procedure component");
11006       } else
11007         entity_attr.exist |= ET_B(et_type);
11008     } else {
11009       if (ET_B(et_type) &
11010           ~(ET_B(ET_ACCESS) | ET_B(ET_BIND) | ET_B(ET_INTENT) |
11011             ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_SAVE) |
11012             ET_B(ET_PROTECTED)))
11013         error(134, 3, gbl.lineno, et[et_type].name, "for procedure");
11014       else
11015         entity_attr.exist |= ET_B(et_type);
11016     }
11017     break;
11018 
11019   /* ------------------------------------------------------------------ */
11020   /*
11021    *	<proc attr> ::= <access spec> |
11022    */
11023   case PROC_ATTR1:
11024     et_type = ET_ACCESS;
11025     break;
11026   /*
11027    *	<proc attr> ::= BIND <bind attr> |
11028    */
11029   case PROC_ATTR2:
11030     et_type = ET_BIND;
11031     break;
11032   /*
11033    *	<proc attr> ::= <intent> |
11034    */
11035   case PROC_ATTR3:
11036     et_type = ET_INTENT;
11037     break;
11038   /*
11039    *	<proc attr> ::= OPTIONAL |
11040    */
11041   case PROC_ATTR4:
11042     et_type = ET_OPTIONAL;
11043     break;
11044   /*
11045    *	<proc attr> ::= POINTER |
11046    */
11047   case PROC_ATTR5:
11048     et_type = ET_POINTER;
11049     break;
11050   /*
11051    *	<proc attr> ::= SAVE |
11052    */
11053   case PROC_ATTR6:
11054     et_type = ET_SAVE;
11055     break;
11056   /*
11057    *	<proc attr> ::= PASS |
11058    */
11059   case PROC_ATTR7:
11060     et_type = ET_PASS;
11061     entity_attr.pass_arg = 0; /* PASS without argname */
11062     break;
11063   /*
11064    *	<proc attr> ::= PASS ( <ident> ) |
11065    */
11066   case PROC_ATTR8:
11067     et_type = ET_PASS;
11068     entity_attr.pass_arg = SST_SYMG(RHS(3)); /* PASS with argname */
11069     break;
11070   /*
11071    *	<proc attr> ::= NOPASS |
11072    */
11073   case PROC_ATTR9:
11074     et_type = ET_NOPASS;
11075     break;
11076   /*
11077    *	<proc attr> ::= PROTECTED
11078    */
11079   case PROC_ATTR10:
11080     et_type = ET_PROTECTED;
11081     break;
11082 
11083   /* ------------------------------------------------------------------ */
11084   /*
11085    *	<proc dcl list> ::= <proc dcl list> , <proc dcl> |
11086    */
11087   case PROC_DCL_LIST1:
11088     break;
11089   /*
11090    *	<proc dcl list> ::= <proc dcl>
11091    */
11092   case PROC_DCL_LIST2:
11093     break;
11094 
11095   /* ------------------------------------------------------------------ */
11096   /*
11097    *	<proc dcl> ::= <ident> |
11098    */
11099   case PROC_DCL1:
11100     inited = FALSE;
11101     goto proc_dcl_shared;
11102   /*
11103    *	<proc dcl> ::= <ident> '=>' <id> ( )
11104    */
11105   case PROC_DCL2:
11106     sptr = SST_SYMG(RHS(3));
11107     sptr = refsym(sptr, OC_OTHER);
11108     SST_SYMP(RHS(3), sptr);
11109     SST_IDP(RHS(3), S_IDENT);
11110     sem.dinit_data = TRUE;
11111     (void)mkvarref(RHS(3), ITEM_END);
11112     sem.dinit_data = FALSE;
11113     inited = TRUE;
11114 
11115   proc_dcl_shared:
11116     sptr = SST_SYMG(RHS(1));
11117     {
11118       /* Hide, so we can modify attribute list without exposing it */
11119       int attr = entity_attr.exist;
11120       if (!POINTERG(sptr) && !(attr & ET_B(ET_POINTER)) &&
11121           proc_interf_sptr > NOSYM && SCG(sptr) == SC_DUMMY) {
11122         IS_PROC_DUMMYP(sptr, 1);
11123       }
11124       if (POINTERG(sptr)) {
11125         attr |= ET_B(ET_POINTER);
11126       }
11127       sptr = decl_procedure_sym(sptr, proc_interf_sptr, attr);
11128       sptr =
11129           setup_procedure_sym(sptr, proc_interf_sptr, attr, entity_attr.access);
11130     }
11131 
11132     /* Error while creating proc symbol */
11133     if (sptr == 0)
11134       break;
11135 
11136     SST_SYMP(RHS(1), sptr);
11137 
11138     stype = STYPEG(sptr);
11139 
11140     if (inited) { /* check if symbol is data initialized */
11141       if (stype == ST_PROC) {
11142         error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
11143         goto proc_decl_end;
11144       }
11145       if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
11146         get_static_descriptor(sptr);
11147         get_all_descriptors(sptr);
11148         SCP(sptr, SC_BASED);
11149         construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
11150         if (!SST_ACLG(RHS(3))) {
11151           goto proc_decl_end;
11152         }
11153 
11154         ict = SST_ACLG(RHS(3));
11155         ict->sptr = sptr; /* field/component sptr */
11156         save_struct_init(ict);
11157         stsk = &STSK_ENT(0);
11158         if (stsk->ict_beg) {
11159           (stsk->ict_end)->next = SST_ACLG(RHS(3));
11160           stsk->ict_end = SST_ACLG(RHS(3));
11161         } else {
11162           stsk->ict_beg = SST_ACLG(RHS(3));
11163           stsk->ict_end = SST_ACLG(RHS(3));
11164         }
11165       } else {
11166         /* Data item (not TYPE component) initialization */
11167         /* have
11168          *   ... :: <ptr> => NULL()
11169          * <ptr>$p, <ptr>$o, <ptr>$sd  will be needed */
11170         get_static_descriptor(sptr);
11171         get_all_descriptors(sptr);
11172         construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
11173         if (!SST_ACLG(RHS(3))) {
11174           goto proc_decl_end;
11175         }
11176         ast = mk_id(sptr);
11177         SST_ASTP(RHS(1), ast);
11178         SST_DTYPEP(RHS(1), DTYPEG(SST_SYMG(RHS(1))));
11179         SST_SHAPEP(RHS(1), 0);
11180         ivl = dinit_varref(RHS(1));
11181 
11182         dinit(ivl, SST_ACLG(RHS(3)));
11183       }
11184     } else if (POINTERG(sptr)) {
11185         get_static_descriptor(sptr);
11186         get_all_descriptors(sptr);
11187     }
11188 
11189   proc_decl_end:
11190 
11191     if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER &&
11192         RESULTG(sptr)) {
11193       /* set the type for the entry point as well */
11194       copy_type_to_entry(sptr);
11195     }
11196     sem.dinit_error = FALSE;
11197 
11198     break;
11199 
11200   /* ------------------------------------------------------------------ */
11201   /*
11202    *	<type bound procedure> ::= <tprocedure> <opt attr> <binding name list>
11203    */
11204   case TYPE_BOUND_PROCEDURE1:
11205     dtype = /*sem.stag_dtype*/ stsk->dtype;
11206     if (SST_FIRSTG(RHS(1)) & 0x2) { /* nopass */
11207       queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_NOPASS);
11208     }
11209     if (SST_FIRSTG(RHS(1)) & 0x4) { /* non_overridable */
11210       queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_NONOVERRIDABLE);
11211     }
11212     if (SST_FIRSTG(RHS(1)) & 0x8) { /* deferred */
11213       if (!ABSTRACTG(DTY(dtype + 3))) {
11214         error(155, 3, gbl.lineno,
11215               "Specifying a deferred type bound procedure in "
11216               "non-abstract type",
11217               SYMNAME(DTY(dtype + 3)));
11218       }
11219       if (!sem.tbp_interface) {
11220         error(155, 3, gbl.lineno,
11221               "Specifying a deferred type bound procedure without"
11222               " an interface-name in",
11223               SYMNAME(DTY(dtype + 3)));
11224       }
11225       queue_tbp(sem.tbp_interface, SST_SYMG(RHS(3)), 0, dtype, TBP_DEFERRED);
11226     }
11227     if (SST_FIRSTG(RHS(1)) & 0x10) { /* private */
11228       queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_PRIVATE);
11229     } else if (SST_FIRSTG(RHS(1)) & 0x20) { /* public */
11230       queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_PUBLIC);
11231     }
11232     if (SST_FIRSTG(RHS(1)) & 0x1) {
11233       sptr = SST_LSYMG(RHS(1));
11234       if (sptr) { /* pass */
11235         sptr = getsym(LOCAL_SYMNAME(sptr), strlen(SYMNAME(sptr)));
11236         if (STYPEG(sptr) != ST_IDENT || DTYPEG(sptr) != dtype) {
11237           sptr = insert_sym(sptr);
11238           sptr = declsym(sptr, ST_IDENT, TRUE);
11239           DTYPEP(sptr, dtype);
11240           SCP(sptr, SC_DUMMY);
11241           IGNOREP(sptr, TRUE);
11242         }
11243         queue_tbp(sptr, SST_SYMG(RHS(3)), 0, dtype, TBP_PASS);
11244       }
11245     }
11246     sem.tbp_interface = 0;
11247     break;
11248 
11249   /* ------------------------------------------------------------------ */
11250   /*
11251    *	<tprocedure> ::= TPROCEDURE <opt interface name> <opt binding attr list>
11252    */
11253   case TPROCEDURE1:
11254     SST_FIRSTP(LHS, SST_FIRSTG(RHS(3)));
11255     if (SST_FIRSTG(RHS(3)) & 0x1)
11256       SST_LSYMP(LHS, SST_LSYMG(RHS(3)));
11257     SST_ASTP(LHS, 0);
11258     break;
11259 
11260   /* ------------------------------------------------------------------ */
11261   /*
11262    *	<opt interface name> ::= |
11263    */
11264   case OPT_INTERFACE_NAME1:
11265     break;
11266   /*
11267    *	<opt interface name> ::= ( <id> )
11268    */
11269   case OPT_INTERFACE_NAME2:
11270     sem.tbp_interface = SST_SYMG(RHS(2));
11271     dtype = /*sem.stag_dtype*/ stsk->dtype;
11272     queue_tbp(SST_SYMG(RHS(2)), 0, 0, dtype, TBP_ADD_INTERFACE);
11273     break;
11274 
11275   /* ------------------------------------------------------------------ */
11276   /*
11277    *	<opt binding attr list> ::= |
11278    */
11279   case OPT_BINDING_ATTR_LIST1:
11280     SST_FIRSTP(LHS, 0);
11281     SST_LSYMP(LHS, 0);
11282     break;
11283   /*
11284    *	<opt binding attr list> ::= , <binding attr list>
11285    */
11286   case OPT_BINDING_ATTR_LIST2:
11287     SST_FIRSTP(LHS, SST_FIRSTG(RHS(2)));
11288     if (SST_FIRSTG(RHS(2)) & 0x1) {
11289       SST_LSYMP(LHS, SST_LSYMG(RHS(2)));
11290     }
11291     break;
11292 
11293   /* ------------------------------------------------------------------ */
11294   /*
11295    *	<binding attr list> ::= <binding attr list> , <binding attr> |
11296    */
11297   case BINDING_ATTR_LIST1:
11298     switch (SST_FIRSTG(RHS(1)) & SST_FIRSTG(RHS(3))) {
11299     case 0x1:
11300       error(134, 3, gbl.lineno, "- duplicate", "PASS");
11301       break;
11302     case 0x2:
11303       error(134, 3, gbl.lineno, "- duplicate", "NOPASS");
11304       break;
11305     case 0x4:
11306       error(134, 3, gbl.lineno, "- duplicate", "NON_OVERRIDABLE");
11307       break;
11308     case 0x8:
11309       error(134, 3, gbl.lineno, "- duplicate", "DEFERRED");
11310       break;
11311     case 0x10:
11312       error(134, 3, gbl.lineno, "- duplicate", "PRIVATE");
11313       break;
11314     case 0x20:
11315       error(134, 3, gbl.lineno, "- duplicate", "PUBLIC");
11316       break;
11317     }
11318 
11319     if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x1) &&
11320         ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x2)) {
11321 
11322       error(155, 3, gbl.lineno, "PASS and NOPASS may not appear "
11323                                 "in same type bound procedure",
11324             CNULL);
11325     } else if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x4) &&
11326                ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x8)) {
11327       error(155, 3, gbl.lineno, "DEFERRED and NON_OVERRIDABLE "
11328                                 "may not appear in same type bound procedure",
11329             CNULL);
11330     } else if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x10) &&
11331                ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x20)) {
11332       error(155, 3, gbl.lineno, "PRIVATE and PUBLIC "
11333                                 "may not appear in same type bound procedure",
11334             CNULL);
11335     }
11336 
11337     SST_FIRSTP(LHS, SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3)));
11338 
11339     if (SST_FIRSTG(RHS(3)) & 0x1 && SST_LSYMG(RHS(3)))
11340       SST_LSYMP(RHS(1), SST_LSYMG(RHS(3)));
11341 
11342   /*
11343    *	<binding attr list> ::= <binding attr>
11344    */
11345   case BINDING_ATTR_LIST2:
11346     if (SST_FIRSTG(RHS(1)) & 0x1)
11347       SST_LSYMP(LHS, SST_LSYMG(RHS(1)));
11348     break;
11349 
11350   /* ------------------------------------------------------------------ */
11351   /*
11352    *	<binding attr> ::= <id name> |
11353    */
11354   case BINDING_ATTR1:
11355     /*
11356      * Not using keywords to enumerate the attributes; <id name> may be:
11357      * PASS NOPASS NON_OVERRIDABLE DEFERRED PRIVATE PUBLIC
11358      */
11359     SST_LSYMP(LHS, 0);
11360     np = scn.id.name + SST_CVALG(RHS(1));
11361     if (sem_strcmp(np, "pass") == 0) {
11362       SST_FIRSTP(LHS, 0x1);
11363     } else if (sem_strcmp(np, "nopass") == 0) {
11364       SST_FIRSTP(LHS, 0x2);
11365     } else if (sem_strcmp(np, "non_overridable") == 0) {
11366       SST_FIRSTP(LHS, 0x4);
11367     } else if (sem_strcmp(np, "deferred") == 0) {
11368       SST_FIRSTP(LHS, 0x8);
11369     } else if (sem_strcmp(np, "private") == 0) {
11370       SST_FIRSTP(LHS, 0x10);
11371     } else if (sem_strcmp(np, "public") == 0) {
11372       SST_FIRSTP(LHS, 0x20);
11373     } else {
11374       error(34, 3, gbl.lineno, np, CNULL);
11375     }
11376     break;
11377   /*
11378    *	<binding attr> ::= <id name> ( <id> )
11379    */
11380   case BINDING_ATTR2:
11381     /*
11382      * Not using keywords to enumerate the attributes; this must be
11383      *    PASS ( arg-name )
11384      */
11385     np = scn.id.name + SST_CVALG(RHS(1));
11386     if (sem_strcmp(np, "pass") == 0) {
11387       SST_FIRSTP(LHS, 0x1);
11388       SST_LSYMP(LHS, SST_SYMG(RHS(3)));
11389     } else {
11390       error(34, 3, gbl.lineno, np, CNULL);
11391     }
11392     break;
11393 
11394   /* ------------------------------------------------------------------ */
11395   /*
11396    *	<binding name list> ::= <binding name list> , <binding name> |
11397    */
11398   case BINDING_NAME_LIST1:
11399     break;
11400   /*
11401    *	<binding name list> ::= <binding name>
11402    */
11403   case BINDING_NAME_LIST2:
11404     break;
11405 
11406   /* ------------------------------------------------------------------ */
11407   /*
11408    *	<binding name> ::=  <id> |
11409    */
11410   case BINDING_NAME1:
11411     rhstop = 1;
11412     goto binding_name_common;
11413   /*
11414    *	<binding name> ::= <id> '=>' <id>
11415    */
11416   case BINDING_NAME2: {
11417     SPTR tag, sptr3, sptr2, orig_sptr;
11418     char *name, *name_cpy, *name_cpy2;
11419     DTYPE parent;
11420     SPTR sym;
11421     int vtoff, len;
11422     int stype;
11423 
11424     if (strcmp(SYMNAME(SST_SYMG(RHS(1))), SYMNAME(SST_SYMG(RHS(3)))) == 0) {
11425       rhstop = 1;
11426     } else {
11427       rhstop = 3;
11428     }
11429 
11430   binding_name_common:
11431 
11432     tag = DTY(stsk->dtype + 3);
11433     orig_sptr = sptr = SST_SYMG(RHS(1));
11434     if (sem.tbp_interface > NOSYM) {
11435       sptr2 = sem.tbp_interface;
11436     } else {
11437       sptr2 = refsym(SST_SYMG(RHS(rhstop)), OC_OTHER);
11438     }
11439 
11440     if (SEPARATEMPG(sptr2))
11441       TBP_BOUND_TO_SMPP(sptr2, TRUE);
11442 
11443     if (bindingNameRequiresOverloading(sptr)) {
11444       sptr = insert_sym(sptr);
11445     }
11446 
11447     parent = DTYPEG(PARENTG(tag));
11448     vtoff = 0;
11449     for (sym = get_struct_members(parent); sym > NOSYM; sym = SYMLKG(sym)) {
11450       if (is_tbp(sym)) {
11451         len = strlen(SYMNAME(BINDG(sym))) + 1;
11452         name_cpy = getitem(0, len);
11453         strcpy(name_cpy, SYMNAME(BINDG(sym)));
11454         name = strstr(name_cpy, "$tbp");
11455         if (name)
11456           *name = '\0';
11457         if (strcmp(name_cpy, SYMNAME(sptr)) == 0) {
11458           vtoff = VTOFFG(BINDG(sym));
11459           VTOFFP(sptr, vtoff);
11460           break;
11461         }
11462       }
11463     }
11464     if (rhstop == 1) {
11465       if (STYPEG(sptr2) && STYPEG(sptr2) != ST_PROC) {
11466         sptr2 = insert_sym(sptr2);
11467       }
11468       sptr = getsymf("%s$tbp", SYMNAME(sptr));
11469       if (STYPEG(sptr) > 0) {
11470         sptr = insert_sym(sptr);
11471       }
11472     }
11473 
11474     if (TBPLNKG(sptr) && !eq_dtype2(TBPLNKG(sptr), stsk->dtype, 1)) {
11475       sptr3 = insert_sym(sptr);
11476       STYPEP(sptr3, STYPEG(sptr));
11477       IGNOREP(sptr3, IGNOREG(sptr));
11478       sptr = sptr3;
11479       parent = DTYPEG(PARENTG(tag));
11480       sym = DTY(parent + 1);
11481       vtoff = 0;
11482       for (sym = get_struct_members(parent); sym > NOSYM; sym = SYMLKG(sym)) {
11483         if (CCSYMG(sym) && BINDG(sym)) {
11484 
11485           len = strlen(SYMNAME(BINDG(sym))) + 1;
11486           name_cpy = getitem(0, len);
11487           strcpy(name_cpy, SYMNAME(BINDG(sym)));
11488           name = strstr(name_cpy, "$tbp");
11489           if (name)
11490             *name = '\0';
11491 
11492           len = strlen(SYMNAME(sptr)) + 1;
11493           name_cpy2 = getitem(0, len);
11494           strcpy(name_cpy2, SYMNAME(sptr));
11495           name = strstr(name_cpy2, "$tbp");
11496           if (name)
11497             *name = '\0';
11498 
11499           if (strcmp(name_cpy, name_cpy2) == 0) {
11500             vtoff = VTOFFG(BINDG(sym));
11501             VTOFFP(sptr, vtoff);
11502             break;
11503           }
11504         }
11505       }
11506     }
11507     /* Ignore temporary binding name only if we're overloading
11508      * a binding name with a derived type name or if stype is 0.
11509      */
11510 
11511     if (STYPEG(orig_sptr) != ST_PD && STYPEG(sptr) != ST_PROC) {
11512       /* when found a binding name has a parameter attribute, don't ignore it
11513        * as we need to export this sptr into a *.mod file.
11514        */
11515       if (STYPEG(orig_sptr) != ST_PARAM)
11516         IGNOREP(sptr, TRUE);
11517       sptr = insert_sym(sptr);
11518       sptr = declsym(sptr, ST_PROC, FALSE);
11519       IGNOREP(sptr, TRUE); /* Needed for overloading */
11520     }
11521 
11522     if (vtoff) {
11523       VTOFFP(sptr, vtoff);
11524     }
11525 
11526     if (!VTOFFG(tag) && PARENTG(tag) && VTOFFG(PARENTG(tag))) {
11527       VTOFFP(tag, VTOFFG(PARENTG(tag))); /*initialize offset*/
11528     }
11529     if (!VTOFFG(sptr) && !VTOFFG(tag) &&
11530         (vtoff = get_vtoff(0, stsk->dtype)) > 0) {
11531       /* Set vtable offset based on dtype and its parents */
11532       VTOFFP(sptr, vtoff + 1);
11533       VTOFFP(tag, vtoff + 1);
11534       CLASSP(sptr, 1);
11535     }
11536     if (!VTOFFG(sptr)) {
11537       /* Give this type bound procedure (tbp) an offset by incrementing
11538        * the tag's offset count and storing it in the tbp's PARENT field.
11539        */
11540       VTOFFP(tag, VTOFFG(tag) + 1);
11541       VTOFFP(sptr, VTOFFG(tag));
11542       CLASSP(sptr, 1);
11543     }
11544 
11545     /* keep track of pass object type in tbp by storing the "least extended"
11546      * type extension in TBPLNK field.
11547      */
11548     if (!TBPLNKG(sptr)) {
11549       TBPLNKP(sptr, /*sem.stag_dtype*/ stsk->dtype);
11550     } else if (eq_dtype2(/*DTYPEG*/ (TBPLNKG(sptr)),
11551                          /*sem.stag_dtype*/ stsk->dtype, 1)) {
11552       TBPLNKP(sptr, /*sem.stag_dtype*/ stsk->dtype);
11553     }
11554     queue_tbp(sptr2, sptr, VTOFFG(sptr), /*sem.stag_dtype*/ stsk->dtype,
11555               (rhstop == 1) ? TBP_ADD_SIMPLE : TBP_ADD_IMPL);
11556 
11557     /* If we pushed the binding name into the symbol table,
11558      * we might have to remove it now, as it might be masking
11559      * a previous name (e.g., a parameter).
11560      */
11561     if (!STYPEG(sptr) ||
11562         (orig_sptr > NOSYM &&
11563          HASHLKG(sptr) == orig_sptr &&
11564          STYPEG(orig_sptr))) {
11565       pop_sym(sptr);
11566     }
11567   } break;
11568   /* ------------------------------------------------------------------ */
11569   /*
11570    *      <accel decl begin> ::=
11571    */
11572   case ACCEL_DECL_BEGIN1:
11573     parstuff_init();
11574     break;
11575   /* ------------------------------------------------------------------ */
11576   /*
11577    *	<accel decl list> ::= <accel decl list> <opt comma> <accel decl attr> |
11578    */
11579   case ACCEL_DECL_LIST1:
11580     break;
11581   /*
11582    *	<accel decl list> ::= <accel decl attr>
11583    */
11584   case ACCEL_DECL_LIST2:
11585     break;
11586   /* ------------------------------------------------------------------ */
11587   /*
11588    *	<accel decl attr> ::= COPYIN ( <accel decl data list> ) |
11589    */
11590   case ACCEL_DECL_ATTR1:
11591     break;
11592   /*
11593    *	<accel decl attr> ::= COPYOUT ( <accel decl data list> ) |
11594    */
11595   case ACCEL_DECL_ATTR2:
11596     break;
11597   /*
11598    *	<accel decl attr> ::= LOCAL ( <accel decl data list> ) |
11599    */
11600   case ACCEL_DECL_ATTR3:
11601     break;
11602   /*
11603    *	<accel decl attr> ::= COPY ( <accel decl data list> ) |
11604    */
11605   case ACCEL_DECL_ATTR4:
11606     break;
11607   /*
11608    *	<accel decl attr> ::= MIRROR ( <accel mdecl data list> ) |
11609    */
11610   case ACCEL_DECL_ATTR5:
11611     break;
11612   /*
11613    *	<accel decl attr> ::= REFLECTED ( <accel mdecl data list> ) |
11614    */
11615   case ACCEL_DECL_ATTR6:
11616     break;
11617   /*
11618    *	<accel decl attr> ::= CREATE ( <accel decl data list> ) |
11619    */
11620   case ACCEL_DECL_ATTR7:
11621     break;
11622   /*
11623    *	<accel decl attr> ::= PRESENT ( <accel decl data list> ) |
11624    */
11625   case ACCEL_DECL_ATTR8:
11626     break;
11627   /*
11628    *	<accel decl attr> ::= PCOPY ( <accel decl data list> ) |
11629    */
11630   case ACCEL_DECL_ATTR9:
11631     break;
11632   /*
11633    *	<accel decl attr> ::= PCOPYIN ( <accel decl data list> ) |
11634    */
11635   case ACCEL_DECL_ATTR10:
11636     break;
11637   /*
11638    *	<accel decl attr> ::= PCOPYOUT ( <accel decl data list> ) |
11639    */
11640   case ACCEL_DECL_ATTR11:
11641     break;
11642   /*
11643    *	<accel decl attr> ::= PLOCAL ( <accel decl data list> ) |
11644    */
11645   case ACCEL_DECL_ATTR12:
11646     break;
11647   /*
11648    *	<accel decl attr> ::= PCREATE ( <accel decl data list> ) |
11649    */
11650   case ACCEL_DECL_ATTR13:
11651     break;
11652   /*
11653    *	<accel decl attr> ::= DEVICEPTR ( <accel decl data list> ) |
11654    */
11655   case ACCEL_DECL_ATTR14:
11656     break;
11657   /*
11658    *	<accel decl attr> ::= DEVICE_RESIDENT ( <accel decl data list> ) |
11659    */
11660   case ACCEL_DECL_ATTR15:
11661     break;
11662   /*
11663    *	<accel decl attr> ::= LINK ( <accel decl data list> ) |
11664    */
11665   case ACCEL_DECL_ATTR16:
11666     break;
11667 
11668   /* ------------------------------------------------------------------ */
11669   /*
11670    *	<accel decl data list> ::= <accel decl data list> , <accel decl data> |
11671    */
11672   case ACCEL_DECL_DATA_LIST1:
11673   accel_decl_data_list1:
11674     itemp = (ITEM *)getitem(0, sizeof(ITEM));
11675     itemp->next = ITEM_END;
11676     itemp->ast = SST_ASTG(RHS(3));
11677     SST_ENDG(RHS(1))->next = itemp;
11678     SST_ENDP(LHS, itemp);
11679     break;
11680   /*
11681    *	<accel decl data list> ::= <accel decl data>
11682    */
11683   case ACCEL_DECL_DATA_LIST2:
11684   accel_decl_data_list2:
11685     itemp = (ITEM *)getitem(0, sizeof(ITEM));
11686     itemp->next = ITEM_END;
11687     itemp->ast = SST_ASTG(RHS(1));
11688     SST_BEGP(LHS, itemp);
11689     SST_ENDP(LHS, itemp);
11690     break;
11691 
11692   /* ------------------------------------------------------------------ */
11693   /*
11694    *	<accel decl data> ::= <accel decl data name> ( <accel decl sub list> ) |
11695    */
11696   case ACCEL_DECL_DATA1:
11697   /*###*/
11698   accel_decl_data1:
11699     sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
11700     switch (STYPEG(sptr)) {
11701     case ST_ARRAY:
11702       itemp = SST_BEGG(RHS(3));
11703       (void)mkvarref(RHS(1), itemp);
11704       SST_PARENP(LHS, 0); /* ? */
11705       break;
11706     default:
11707       error(155, 3, gbl.lineno, "Unknown symbol used in data clause -",
11708             SYMNAME(sptr));
11709       break;
11710     }
11711     break;
11712   /*
11713    *	<accel decl data> ::= <accel decl data name> |
11714    */
11715   /*###*/
11716   case ACCEL_DECL_DATA2:
11717   accel_decl_data2:
11718     sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
11719     mkident(LHS);
11720     SST_SYMP(LHS, sptr);
11721     SST_DTYPEP(LHS, DTYPEG(sptr));
11722     SST_ASTP(LHS, mk_id(sptr));
11723     break;
11724   /*
11725    *	<accel decl data> ::= <constant> |
11726    */
11727   case ACCEL_DECL_DATA3:
11728     /*###*/
11729     break;
11730   /*
11731    *	<accel decl data> ::= <common>
11732    */
11733   case ACCEL_DECL_DATA4:
11734     sptr = SST_SYMG(RHS(1));
11735     SST_SYMP(LHS, sptr);
11736     SST_DTYPEP(LHS, 0);
11737     SST_ASTP(LHS, mk_id(sptr));
11738     break;
11739   /* ------------------------------------------------------------------ */
11740   /*
11741    *	<accel mdecl data> ::= <accel mdecl data name> ( <accel decl sub list> )
11742    *|
11743    */
11744   case ACCEL_MDECL_DATA1:
11745     goto accel_decl_data1;
11746   /*
11747    *	<accel mdecl data> ::= <accel mdecl data name>
11748    */
11749   case ACCEL_MDECL_DATA2:
11750     goto accel_decl_data2;
11751   /*
11752    *	<accel mdecl data> ::= <constant>
11753    */
11754   case ACCEL_MDECL_DATA3:
11755     break;
11756 
11757   /* ------------------------------------------------------------------ */
11758   /*
11759    *	<accel mdecl data list> ::= <accel mdecl data list> , <accel mdecl data>
11760    *|
11761    */
11762   case ACCEL_MDECL_DATA_LIST1:
11763     goto accel_decl_data_list1;
11764   /*
11765    *	<accel mdecl data list> ::= <accel mdecl data>
11766    */
11767   case ACCEL_MDECL_DATA_LIST2:
11768     goto accel_decl_data_list2;
11769 
11770   /* ------------------------------------------------------------------ */
11771   /*
11772    *	<accel decl sub list> ::= <accel decl sub list> , <accel decl sub> |
11773    */
11774   case ACCEL_DECL_SUB_LIST1:
11775     itemp = (ITEM *)getitem(0, sizeof(ITEM));
11776     itemp->next = ITEM_END;
11777     itemp->t.stkp = SST_E1G(RHS(3));
11778     SST_ENDG(RHS(1))->next = itemp;
11779     SST_ENDP(LHS, itemp);
11780     break;
11781   /*
11782    *	<accel decl sub list> ::= <accel decl sub>
11783    */
11784   case ACCEL_DECL_SUB_LIST2:
11785     itemp = (ITEM *)getitem(0, sizeof(ITEM));
11786     itemp->next = ITEM_END;
11787     itemp->t.stkp = SST_E1G(RHS(1));
11788     SST_BEGP(LHS, itemp);
11789     SST_ENDP(LHS, itemp);
11790     break;
11791   /* ------------------------------------------------------------------ */
11792   /*
11793    *      <generic type procedure> ::=  GENERIC <opt gen access spec> ::
11794    * <generic binding>
11795    */
11796   case GENERIC_TYPE_PROCEDURE1:
11797     sptr = sem.interf_base[sem.interface - 1].generic;
11798     if (!sptr) {
11799       sptr = sem.interf_base[sem.interface - 1].operator;
11800       sem.generic_tbp = ST_OPERATOR;
11801     } else {
11802       sem.generic_tbp = ST_USERGENERIC;
11803     }
11804 
11805     switch (SST_FIRSTG(RHS(2))) {
11806     case 0x10:
11807       i = TBP_CHECK_PRIVATE; /* private */
11808       break;
11809     case 0x20:
11810       i = TBP_CHECK_PUBLIC; /* public */
11811       break;
11812     case 0x0:
11813     default:
11814       i = TBP_CHECK_CHILD;
11815     }
11816     for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
11817       int tag;
11818       dtype = stsk->dtype;
11819       tag = DTY(dtype + 3);
11820 
11821       if (!VTOFFG(sptr)) {
11822         int vt = VTOFFG(tag);
11823         if (!vt && PARENTG(tag) && VTOFFG(PARENTG(tag))) {
11824           /* Seed the vtable offset field of derived type tag with its parent's
11825            * vtable offset. It will get updated in
11826            * <binding name> ::= <id> '=>' <id> production.
11827            */
11828           vt = VTOFFG(PARENTG(tag));
11829           VTOFFP(tag, vt);
11830         }
11831         /* Set offset of binding name to next offset. */
11832         VTOFFP(sptr, vt + 1);
11833         if (STYPEG(sptr) == ST_OPERATOR) {
11834 /* Set CLASS flag so we can properly handle its
11835  * access in semfin.c do_access(). We don't set it for
11836  * ST_USERGENERIC here because a USERGENERIC can overload
11837  * a type name (including the type name of the type defining
11838  * the generic tbp).
11839  */
11840           CLASSP(sptr, 1);
11841         }
11842       }
11843       /* offset needs to be same as overloaded tbp */
11844       queue_tbp(itemp->t.sptr, sptr, VTOFFG(sptr), stsk->dtype, i);
11845     }
11846     sem.interface--;
11847     sem.generic_tbp = 0;
11848     sem.defined_io_type = 0;
11849     break;
11850 
11851   /*
11852    *      <opt gen access spec> ::= |
11853    */
11854   case OPT_GEN_ACCESS_SPEC1:
11855     SST_FIRSTP(LHS, 0x0);
11856     goto gen_access_spec_common;
11857   /*
11858    *      <opt gen access spec> ::= , <gen access spec>
11859    */
11860   case OPT_GEN_ACCESS_SPEC2:
11861     SST_FIRSTP(LHS, SST_FIRSTG(RHS(2)));
11862   gen_access_spec_common:
11863     sem.generic_tbp = 1;
11864     NEED(sem.interface + 1, sem.interf_base, INTERF, sem.interf_size,
11865          sem.interf_size + 2);
11866     sem.interf_base[sem.interface].generic = 0;
11867     sem.interf_base[sem.interface].operator= 0;
11868     sem.interf_base[sem.interface].opval = 0;
11869     sem.interf_base[sem.interface].abstract = 0;
11870     sem.interf_base[sem.interface].hpfdcl = sem.hpfdcl;
11871     sem.interface++;
11872     break;
11873 
11874   /*
11875    *      <gen access spec> ::= <id name>
11876    */
11877   case GEN_ACCESS_SPEC1:
11878     np = scn.id.name + SST_CVALG(RHS(1));
11879     sptr = getsymbol(np);
11880     if (strcmp(SYMNAME(sptr), "private") == 0)
11881       SST_FIRSTP(LHS, 0x10);
11882     else if (strcmp(SYMNAME(sptr), "public") == 0)
11883       SST_FIRSTP(LHS, 0x20);
11884     else
11885       error(155, 3, gbl.lineno, "Invalid access specifier in generic"
11886                                 " type bound procedure",
11887             CNULL);
11888     break;
11889 
11890   /* ------------------------------------------------------------------ */
11891   /*
11892    *	<accel decl sub> ::= <opt sub> : <opt sub> |
11893    */
11894   case ACCEL_DECL_SUB1:
11895     e1 = (SST *)getitem(sem.ssa_area, sizeof(SST));
11896     SST_IDP(e1, S_TRIPLE);
11897     SST_E1P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST)));
11898     *(SST_E1G(e1)) = *RHS(1);
11899     SST_E2P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST)));
11900     *(SST_E2G(e1)) = *RHS(3);
11901     SST_E3P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST)));
11902     SST_IDP(SST_E3G(e1), S_NULL);
11903     SST_E1P(LHS, e1);
11904     SST_E2P(LHS, 0);
11905     break;
11906   /*
11907    *	<accel decl sub> ::= <expression>
11908    */
11909   case ACCEL_DECL_SUB2:
11910     e1 = (SST *)getitem(sem.ssa_area, sizeof(SST));
11911     *e1 = *RHS(1);
11912     SST_E1P(LHS, e1);
11913     SST_E2P(LHS, 0);
11914     break;
11915 
11916   /* ------------------------------------------------------------------ */
11917   /*
11918    *	<accel routine list> ::= |
11919    */
11920   case ACCEL_ROUTINE_LIST1:
11921   break;
11922   /*
11923    *	<accel routine list> ::= <accel routine list> <opt comma> GANG |
11924    */
11925   case ACCEL_ROUTINE_LIST2:
11926   break;
11927   /*
11928    *	<accel routine list> ::= <accel routine list> <opt comma> WORKER |
11929    */
11930   case ACCEL_ROUTINE_LIST3:
11931   break;
11932   /*
11933    *	<accel routine list> ::= <accel routine list> <opt comma> VECTOR |
11934    */
11935   case ACCEL_ROUTINE_LIST4:
11936   break;
11937   /*
11938    *	<accel routine list> ::= <accel routine list> <opt comma> SEQ |
11939    */
11940   case ACCEL_ROUTINE_LIST5:
11941   break;
11942   /*
11943    *	<accel routine list> ::= <accel routine list> <opt comma> NOHOST |
11944    */
11945   case ACCEL_ROUTINE_LIST6:
11946   break;
11947   /*
11948    *	<accel routine list> ::= <accel routine list> <opt comma> BIND ( <ident>
11949    *) |
11950    */
11951   case ACCEL_ROUTINE_LIST7:
11952   break;
11953   /*
11954    *	<accel routine list> ::= <accel routine list> <opt comma> BIND ( <quoted
11955    *string> ) |
11956    */
11957   case ACCEL_ROUTINE_LIST8:
11958   break;
11959   /*
11960    *	<accel routine list> ::= <accel routine list> <opt comma> DEVICE_TYPE (
11961    *<devtype list> )
11962    */
11963   case ACCEL_ROUTINE_LIST9:
11964   break;
11965   /*
11966    *	<accel routine list> ::= <accel routine list> <opt comma> GANG ( <ident>
11967    *: <expression> )
11968    */
11969   case ACCEL_ROUTINE_LIST10:
11970   break;
11971   /*
11972    *	<accel routine list> ::= <accel routine list> <opt comma> EXCLUDE
11973    */
11974   case ACCEL_ROUTINE_LIST11:
11975   break;
11976 
11977   /* ------------------------------------------------------------------ */
11978   /*
11979    *	<devtype list> ::= <devtype list> , <devtype attr> |
11980    */
11981   case DEVTYPE_LIST1:
11982   break;
11983   /*
11984    *	<devtype list> ::= <devtype attr>
11985    */
11986   case DEVTYPE_LIST2:
11987     break;
11988 
11989   /* ------------------------------------------------------------------ */
11990   /*
11991    *	<devtype attr> ::= * |
11992    */
11993   case DEVTYPE_ATTR1:
11994     break;
11995   /*
11996    *	<devtype attr> ::= <ident>
11997    */
11998   case DEVTYPE_ATTR2:
11999   break;
12000 
12001   /* ------------------------------------------------------------------ */
12002   /*
12003    *      <generic binding> ::= <generic spec> '=>' <generic binding list>
12004    */
12005   case GENERIC_BINDING1:
12006     sptr = sem.interf_base[sem.interface - 1].generic;
12007     if (!sptr) {
12008       sptr = sem.interf_base[sem.interface - 1].operator;
12009     }
12010     TBPLNKP(sptr, stsk->dtype);
12011     SST_BEGP(LHS, SST_BEGG(RHS(3)));
12012     break;
12013 
12014   /* ------------------------------------------------------------------ */
12015   /*
12016    *      <generic binding name> ::= <id>
12017    */
12018   case GENERIC_BINDING_NAME1:
12019     break;
12020 
12021   /* ------------------------------------------------------------------ */
12022   /*
12023    *      <generic binding list> ::= <generic binding name> |
12024    */
12025   case GENERIC_BINDING_LIST1:
12026     rhstop = 1;
12027     goto shared_generic_binding;
12028   /*
12029    *      <generic binding list> ::= <generic binding list>, <generic binding
12030    * name>
12031    */
12032   case GENERIC_BINDING_LIST2:
12033     rhstop = 3;
12034   shared_generic_binding:
12035     sptr = SST_SYMG(RHS(rhstop));
12036     itemp = (ITEM *)getitem(0, sizeof(ITEM));
12037     itemp->next = ITEM_END;
12038     itemp->t.sptr = sptr;
12039     if (rhstop == 1)
12040       /* adding first item to list */
12041       SST_BEGP(LHS, itemp);
12042     else
12043       /* adding subsequent items to list */
12044       SST_ENDG(RHS(1))->next = itemp;
12045     SST_ENDP(LHS, itemp);
12046     break;
12047 
12048   /* ------------------------------------------------------------------ */
12049   /*
12050    *	<final subroutines> ::= FINAL <opt attr> <final list>
12051    */
12052   case FINAL_SUBROUTINES1:
12053     if (sem.type_mode < 2) {
12054       error(155, 3, gbl.lineno,
12055             "a FINAL subroutine statement can only appear"
12056             " within the type bound procedure part of a derived type",
12057             CNULL);
12058     }
12059     for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) {
12060       int tag;
12061       dtype = stsk->dtype;
12062       sptr = itemp->t.sptr;
12063       queue_tbp(sptr, 0, 0, dtype, TBP_ADD_FINAL);
12064       /*queue_tbp(sptr, 0, 0, dtype, TBP_ADD_TO_DTYPE);*/
12065     }
12066     break;
12067   /* ------------------------------------------------------------------ */
12068   /*
12069    *      <final list> ::= <final>
12070    */
12071   case FINAL_LIST2:
12072     rhstop = 1;
12073     goto shared_final_sub;
12074 
12075   /* ------------------------------------------------------------------ */
12076   /*
12077    *	<final list> ::= <final list> , <final> |
12078    */
12079   case FINAL_LIST1:
12080     rhstop = 3;
12081   shared_final_sub:
12082     sptr = SST_SYMG(RHS(rhstop));
12083     itemp = (ITEM *)getitem(0, sizeof(ITEM));
12084     itemp->next = ITEM_END;
12085     itemp->t.sptr = sptr;
12086     if (rhstop == 1)
12087       /* adding first item to list */
12088       SST_BEGP(LHS, itemp);
12089     else
12090       /* adding subsequent items to list */
12091       SST_ENDG(RHS(1))->next = itemp;
12092     SST_ENDP(LHS, itemp);
12093     break;
12094 
12095   /* ------------------------------------------------------------------ */
12096   /*
12097    *	<mp decl begin> ::=
12098    */
12099   case MP_DECL_BEGIN1:
12100     break;
12101 
12102   /* ------------------------------------------------------------------ */
12103   /*
12104    *	<mp decl> ::= <mp declaresimd> <declare simd> |
12105    */
12106   case MP_DECL1:
12107 #ifdef OMP_OFFLOAD_LLVM
12108     if(flg.omptarget) {
12109       error(1200, ERR_Severe, gbl.lineno, "declare simd",
12110             NULL);
12111     }
12112 #endif
12113     break;
12114   /*
12115    *	<mp decl> ::= <declare target> <opt par list> |
12116    */
12117   case MP_DECL2:
12118 #ifdef OMP_OFFLOAD_LLVM
12119     if(flg.omptarget) {
12120       error(1200, ERR_Severe, gbl.lineno, "declare target",
12121             NULL);
12122     }
12123 #endif
12124     break;
12125   /*
12126    *	<mp decl> ::= <declarered begin> <declare reduction>
12127    */
12128   case MP_DECL3:
12129     break;
12130 
12131   /* ------------------------------------------------------------------ */
12132   /*
12133    *	<declarered begin> ::= <mp declarereduction>
12134    */
12135   case DECLARERED_BEGIN1:
12136     if (sem.which_pass == 0)
12137       error(155, 2, gbl.lineno, "Unimplemented feature - DECLARE REDUCTION",
12138             NULL);
12139     sem.ignore_stmt = TRUE;
12140     break;
12141 
12142   /* ------------------------------------------------------------------ */
12143   /*
12144    *	<declare reduction> ::= ( <reduc op> : <type list> : <red comb> ) <opt
12145    *red init>
12146    */
12147   case DECLARE_REDUCTION1:
12148     break;
12149 
12150   /* ------------------------------------------------------------------ */
12151   /*
12152    *	<type list> ::= <type list> , <red type> |
12153    */
12154   case TYPE_LIST1:
12155     break;
12156   /*
12157    *	<type list> ::= <red type>
12158    */
12159   case TYPE_LIST2:
12160     break;
12161 
12162   /* ------------------------------------------------------------------ */
12163   default:
12164     interr("semant1:bad rednum", rednum, 3);
12165     break;
12166   }
12167 }
12168 
12169 static void
gen_dinit(int sptr,SST * stkptr)12170 gen_dinit(int sptr, SST *stkptr)
12171 {
12172   switch (STYPEG(sptr)) { /* change symbol type if necessary */
12173   case ST_UNKNOWN:
12174   case ST_IDENT:
12175     STYPEP(sptr, ST_VAR);
12176   case ST_VAR:
12177   case ST_ARRAY:
12178     if (SCG(sptr) == SC_NONE)
12179       SCP(sptr, SC_LOCAL);
12180     if (!dinit_ok(sptr))
12181       return;
12182     break;
12183   case ST_STAG:
12184   case ST_STRUCT:
12185   case ST_MEMBER:
12186     break;
12187   case ST_GENERIC:
12188   case ST_INTRIN:
12189   case ST_PD:
12190     if ((sptr = newsym(sptr)) == 0)
12191       /* Symbol frozen as an intrinsic, ignore data initialization */
12192       return;
12193     break;
12194   default:
12195     error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
12196     return;
12197   }
12198 
12199   if (flg.xref)
12200     xrefput(sptr, 'i');
12201 
12202   if (SCG(sptr) == SC_DUMMY) {
12203     /* Dummy variables may not be initialized */
12204     error(41, 3, gbl.lineno, SYMNAME(sptr), CNULL);
12205     sem.dinit_error = TRUE;
12206   }
12207 
12208   if (sem.dinit_count > 0) {
12209     errsev(66);
12210     sem.dinit_error = TRUE;
12211   }
12212 
12213   /* Call dinit to generate dinit records */
12214   if (INSIDE_STRUCT) {
12215     /* In structure so accumulate Initializer Constant Tree
12216      * in the structure stack.
12217      */
12218     /* Set first constant to point to variable needing init'd */
12219     (SST_CLBEGG(stkptr))->sptr = sptr;
12220     stsk = &STSK_ENT(0);
12221     if (stsk->ict_beg) {
12222       (stsk->ict_end)->next = SST_CLBEGG(stkptr);
12223       stsk->ict_end = SST_CLENDG(stkptr);
12224     } else {
12225       stsk->ict_beg = SST_CLBEGG(stkptr);
12226       stsk->ict_end = SST_CLENDG(stkptr);
12227     }
12228   } else {
12229     /* Not in structure so generate dinit records */
12230     if (!sem.dinit_error) {
12231       SST tmpsst;
12232       VAR *ivl;
12233       mkident(&tmpsst);
12234       SST_SYMP(&tmpsst, sptr);
12235       SST_DTYPEP(&tmpsst, DTYPEG(sptr));
12236       SST_SHAPEP(&tmpsst, 0);
12237       SST_ASTP(&tmpsst, mk_id(sptr));
12238       SST_SHAPEP(&tmpsst, A_SHAPEG(SST_ASTG(&tmpsst)));
12239       ivl = dinit_varref(&tmpsst);
12240       dinit(ivl, SST_CLBEGG(stkptr));
12241     }
12242     sem.dinit_error = FALSE;
12243   }
12244 }
12245 
12246 static void
pop_subprogram(void)12247 pop_subprogram(void)
12248 {
12249   int scope;
12250   if (sem.none_implicit) {
12251     int i, arg;
12252     int *dscptr;
12253 
12254     dscptr = aux.dpdsc_base + DPDSCG(gbl.currsub);
12255     for (i = PARAMCTG(gbl.currsub); i > 0; i--)
12256       if ((arg = *dscptr++)) {
12257         /* any implicit typing needs to be explicit */
12258         switch (STYPEG(arg)) {
12259         case ST_VAR:
12260         case ST_ARRAY:
12261           DCLCHK(arg);
12262           DCLDP(arg, TRUE);
12263           break;
12264         case ST_PROC:
12265           if (FUNCG(arg)) {
12266             DCLCHK(arg);
12267             DCLDP(arg, TRUE);
12268           }
12269           break;
12270         default:
12271           break;
12272         }
12273       }
12274   }
12275   if (gbl.rutype == RU_FUNC) {
12276     DCLCHK(gbl.currsub);
12277     DCLDP(gbl.currsub, TRUE); /* any implicit typing needs to be explicit */
12278   }
12279 
12280   STYPEP(gbl.currsub, ST_PROC);
12281   if (sem.interface && SCG(gbl.currsub) == SC_DUMMY) {
12282     /* if this is a interface block definition of a subprogram
12283      * for a dummy argument, force it to appear in an external statement */
12284     TYPDP(gbl.currsub, 1);
12285     IS_PROC_DUMMYP(gbl.currsub, 1);
12286   }
12287   /* if this is an interface block for the program we are compiling,
12288    * ignore this symbol henceforth */
12289   scope = SCOPEG(gbl.currsub);
12290   if (scope && NMPTRG(gbl.currsub) == NMPTRG(scope)) {
12291     IGNOREP(gbl.currsub, TRUE);
12292     pop_sym(gbl.currsub);
12293   }
12294   gbl.currsub = 0;
12295   gbl.rutype = 0;
12296   sem.module_procedure = FALSE;
12297   sem.pgphase = PHASE_INIT;
12298   symutl.none_implicit = sem.none_implicit = flg.dclchk;
12299   seen_implicit = FALSE;
12300   seen_parameter = FALSE;
12301 }
12302 
12303 static void
set_len_attributes(SST * stkptr,int lvl)12304 set_len_attributes(SST *stkptr, int lvl)
12305 {
12306   /* lenspec[].kind */ /* 0 - length not present
12307                         * 1 - constant length
12308                         * 2 - length is '*'
12309                         * 3 - length is zero
12310                         * 4 - length is adjustable
12311                         * 5 - length is ':'
12312                         */
12313   /* lenspec[].len */  /* -1 if length not present;
12314                         * -2 if zero length;
12315                         * -3 if ':';
12316                         * 0 if '*';
12317                         * constant value if length is constant;
12318                         * ast of adjustable length expression.
12319                         */
12320   if (SST_IDG(stkptr) == 0) {
12321     lenspec[lvl].len = SST_SYMG(stkptr);
12322     switch (lenspec[lvl].len) {
12323     case -1:
12324       lenspec[lvl].kind = 0;
12325       break;
12326     case -2:
12327       lenspec[lvl].kind = _LEN_ZERO;
12328       break;
12329     default:
12330       lenspec[lvl].kind = _LEN_CONST;
12331     }
12332   } else {
12333     lenspec[lvl].len = SST_ASTG(stkptr);
12334     if (lenspec[lvl].len == 0 && SST_SYMG(stkptr) == -1) {
12335       lenspec[lvl].kind = _LEN_DEFER;
12336     } else if (lenspec[lvl].len == 0)
12337       lenspec[lvl].kind = _LEN_ASSUM;
12338     else
12339       lenspec[lvl].kind = _LEN_ADJ;
12340   }
12341   if (lvl == 0 || (lenspec[1].kind == 0 && lenspec[0].kind)) {
12342     /* propagate the global length attributes if:
12343      * 1.  the global attributes are being set, or
12344      * 2.  the augmented attributes were not present and the global
12345      *     attributes were present.
12346      */
12347     lenspec[1] = lenspec[0];
12348     lenspec[1].propagated = 1;
12349   } else {
12350     lenspec[lvl].propagated = 0;
12351   }
12352 }
12353 
12354 static void
set_char_attributes(int sptr,int * pdtype)12355 set_char_attributes(int sptr, int *pdtype)
12356 {
12357   int dtype;
12358   dtype = *pdtype;
12359   if (DTY(dtype) != TY_CHAR && DTY(dtype) != TY_NCHAR)
12360     return;
12361   if (lenspec[1].kind == _LEN_ADJ) {
12362     ADJLENP(sptr, 1);
12363   }
12364   if (lenspec[1].kind == _LEN_ASSUM) {
12365     ASSUMLENP(sptr, 1);
12366   }
12367 }
12368 
12369 static void
set_aclen(SST * stkptr,int ivl,int flag)12370 set_aclen(SST *stkptr, int ivl, int flag)
12371 {
12372   static int kind0, kind1, propagate0, propagate1;
12373   static INT len0, len1;
12374 
12375   if (flag) {
12376     len0 = lenspec[0].len;
12377     kind0 = lenspec[0].kind;
12378     propagate0 = lenspec[0].propagated;
12379     len1 = lenspec[1].len;
12380     kind1 = lenspec[1].kind;
12381     propagate1 = lenspec[1].propagated;
12382     lenspec[0].len = 0;
12383     lenspec[0].kind = 0;
12384     lenspec[0].propagated = 0;
12385     lenspec[1].len = 0;
12386     lenspec[1].kind = 0;
12387     lenspec[1].propagated = 0;
12388 
12389     set_len_attributes(stkptr, ivl);
12390   } else {
12391     lenspec[0].len = len0;
12392     lenspec[0].kind = kind0;
12393     lenspec[0].propagated = propagate0;
12394     lenspec[1].len = len1;
12395     lenspec[1].kind = kind1;
12396     lenspec[1].propagated = propagate1;
12397   }
12398 }
12399 
12400 static int
get_actype(SST * stkptr,int ivl)12401 get_actype(SST *stkptr, int ivl)
12402 {
12403   sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[ivl].kind,
12404                         lenspec[ivl].len, lenspec[ivl].propagated, 0);
12405   return sem.gdtype;
12406 }
12407 
12408 static void
ctte(int entry,int sptr)12409 ctte(int entry, int sptr)
12410 {
12411   int dtype;
12412   ADJARRP(entry, ADJARRG(sptr));
12413   ADJLENP(entry, ADJLENG(sptr));
12414   ALLOCP(entry, ALLOCG(sptr));
12415   ASSUMSHPP(entry, ASSUMSHPG(sptr));
12416   ASUMSZP(entry, ASUMSZG(sptr));
12417   DCLDP(entry, DCLDG(sptr));
12418   DTYPEP(entry, DTYPEG(sptr));
12419   POINTERP(entry, POINTERG(sptr));
12420   F90POINTERP(entry, F90POINTERG(sptr));
12421   SEQP(entry, SEQG(sptr));
12422   /* check that the datatype is a legal function datatype */
12423   dtype = DTYPEG(sptr);
12424   if (POINTERG(sptr)) {
12425     /* cannot be a character(len=*) */
12426     if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) {
12427       error(155, 3, gbl.lineno,
12428             "Function result cannot be assumed-length character pointer -",
12429             SYMNAME(sptr));
12430       POINTERP(sptr, FALSE);
12431       POINTERP(entry, FALSE);
12432     }
12433   }
12434   if (DTY(dtype) == TY_ARRAY) {
12435     /* cannot be a character(len=*) */
12436     if (DTY(dtype + 1) == DT_ASSCHAR || DTY(dtype + 1) == DT_ASSNCHAR) {
12437       error(155, 3, gbl.lineno,
12438             "Function result cannot be assumed-length character array -",
12439             SYMNAME(sptr));
12440       DTYPEP(sptr, DTY(dtype + 1));
12441       DTYPEP(entry, DTY(dtype + 1));
12442       dtype = DTY(dtype + 1);
12443     }
12444   }
12445 } /* ctte */
12446 
12447 static void
copy_type_to_entry(int sptr)12448 copy_type_to_entry(int sptr)
12449 {
12450   if (RESULTG(sptr)) {
12451     if (sem.interface) {
12452       /* find the entry symbol in the interface block */
12453       int sl, e;
12454       for (sl = sem.scope_level; sl > 0; --sl) {
12455         e = sem.scope_stack[sl].sptr;
12456         if (STYPEG(e) == ST_ENTRY || STYPEG(e) == ST_PROC) {
12457           if (FVALG(e) == sptr)
12458             ctte(e, sptr);
12459         }
12460         if (sem.scope_stack[sl].kind == SCOPE_INTERFACE)
12461           break;
12462       }
12463       for (e = sem.scope_stack[sl].symavl; e < stb.stg_avail; ++e) {
12464         if (STYPEG(e) == ST_ENTRY || STYPEG(e) == ST_PROC) {
12465           if (FVALG(e) == sptr)
12466             ctte(e, sptr);
12467         }
12468       }
12469     } else {
12470       int e;
12471       /*  scan all entries. NOTE: gbl.entries not yet set  */
12472       for (e = gbl.currsub; e > NOSYM; e = SYMLKG(e)) {
12473         if (FVALG(e) == sptr)
12474           ctte(e, sptr);
12475       }
12476     }
12477   }
12478 } /* copy_type_to_entry */
12479 
12480 static void
save_host(INTERF * state)12481 save_host(INTERF *state)
12482 {
12483   state->currsub = gbl.currsub;
12484   state->rutype = gbl.rutype;
12485   state->module_procedure = sem.module_procedure;
12486   state->pgphase = sem.pgphase;
12487   state->none_implicit = sem.none_implicit;
12488   state->seen_implicit = seen_implicit;
12489   state->seen_parameter = seen_parameter;
12490   state->gnr_rutype = 0;
12491   state->nml = sem.nml;
12492 
12493   gbl.currsub = 0;
12494   gbl.rutype = 0;
12495   sem.module_procedure = false;
12496   sem.pgphase = PHASE_INIT;
12497   symutl.none_implicit = sem.none_implicit = flg.dclchk;
12498   seen_implicit = FALSE;
12499   seen_parameter = FALSE;
12500   save_implicit(FALSE); /* save host's implicit state */
12501 }
12502 
12503 static void
restore_host(INTERF * state,LOGICAL keep_implicit)12504 restore_host(INTERF *state, LOGICAL keep_implicit)
12505 {
12506   gbl.currsub = state->currsub;
12507   gbl.rutype = state->rutype;
12508   sem.module_procedure = state->module_procedure;
12509   sem.pgphase = state->pgphase;
12510   symutl.none_implicit = sem.none_implicit = state->none_implicit;
12511   seen_implicit = state->seen_implicit;
12512   seen_parameter = state->seen_parameter;
12513   sem.nml = state->nml;
12514   restore_implicit(); /* restore host's implicit state */
12515   if (keep_implicit) {
12516     save_implicit(TRUE);
12517     /* in a contained subprogram, ignore host's implicit/parameter stmts */
12518     seen_implicit = FALSE;
12519     seen_parameter = FALSE;
12520   }
12521 }
12522 
12523 /* return TRUE if the name on the end is different from the name
12524  * of the routine */
12525 static LOGICAL
wrong_name(SPTR endname)12526 wrong_name(SPTR endname)
12527 {
12528   if (endname == 0)
12529     return FALSE;
12530   if (UNAMEG(gbl.currsub)) {
12531     /* compare to the original name */
12532     char *uname = stb.n_base + UNAMEG(gbl.currsub);
12533     return strcmp(uname, SYMNAME(endname)) != 0;
12534   }
12535   return strcmp(SYMNAME(gbl.currsub), SYMNAME(endname)) != 0;
12536 } /* wrong_name */
12537 
12538 /** Reset scopes and related set ups after processing and subroutine
12539  */
12540 static void
do_end_subprogram(SST * top,RU_TYPE rutype)12541 do_end_subprogram(SST *top, RU_TYPE rutype)
12542 {
12543   fix_iface(gbl.currsub);
12544   if (sem.interface && IN_MODULE) {
12545     do_iface_module();
12546   }
12547   if (sem.which_pass && !sem.interface) {
12548     fix_class_args(gbl.currsub);
12549   }
12550   if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) {
12551     queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
12552     queue_tbp(0, 0, 0, 0, TBP_CLEAR);
12553   }
12554   defer_pt_decl(0, 0);
12555   dummy_program();
12556   check_end_subprogram(rutype, SST_SYMG(RHS(2)));
12557 
12558   SST_IDP(LHS, 1); /* mark as end of subprogram unit */
12559   if (IN_MODULE && sem.interface == 0)
12560     mod_end_subprogram();
12561   pop_scope_level(SCOPE_NORMAL);
12562   check_defined_io();
12563   if (!IN_MODULE && !sem.interface)
12564     clear_ident_list();
12565   fix_proc_ptr_dummy_args();
12566   sem.seen_import = FALSE;
12567 }
12568 
12569 static void
check_end_subprogram(RU_TYPE rutype,int sym)12570 check_end_subprogram(RU_TYPE rutype, int sym)
12571 {
12572   if (gbl.currsub == 0) {
12573     if (sem.pgphase == PHASE_INIT && gbl.internal) {
12574       /* end of subprogram containing internal subprograms */
12575       restore_host(&host_state, TRUE);
12576       gbl.internal = 0;
12577       check_end_subprogram(rutype, sym);
12578       end_of_host = gbl.currsub;
12579       gbl.currsub = 0;
12580       if (sem.which_pass)
12581         end_contained();
12582       if (scn.currlab && sem.which_pass == 0)
12583         /* The end statement of the host subprogram is labeled.
12584          * Save its number for when the host's CONTAINS statement is
12585          * processed during the second pass.
12586          */
12587         sem.end_host_labno = scn.labno;
12588       return;
12589     }
12590     if (gbl.internal && sem.pgphase == PHASE_END && sem.which_pass == 0) {
12591       /* end of module subprogram containing internal subprograms */
12592       restore_host(&host_state, TRUE);
12593       gbl.internal = 0;
12594       sem.pgphase = PHASE_INIT;
12595       return;
12596     }
12597     error(302, 3, gbl.lineno, name_of_rutype(rutype), CNULL);
12598     gbl.internal = 0;
12599   } else if (gbl.rutype != rutype) {
12600     error(302, 3, gbl.lineno, name_of_rutype(rutype), CNULL);
12601   } else if (sym && wrong_name(sym))
12602     error(309, 3, gbl.lineno, SYMNAME(sym), CNULL);
12603 
12604   enforce_denorm();
12605 }
12606 
12607 static const char *
name_of_rutype(RU_TYPE rutype)12608 name_of_rutype(RU_TYPE rutype)
12609 {
12610   switch (rutype) {
12611   case RU_SUBR:
12612     return "SUBROUTINE";
12613   case RU_FUNC:
12614     return "FUNCTION";
12615   case RU_PROC:
12616     return "PROCEDURE";
12617   case RU_PROG:
12618     return "PROGRAM";
12619   case RU_BDATA:
12620     return "BLOCKDATA";
12621   }
12622   return "";
12623 }
12624 
12625 /* If an intrinsic is declared in a host subprogram and not otherwise used,
12626  * convert it to an identifier for the internal subprograms to share.
12627  */
12628 static void
convert_intrinsics_to_idents()12629 convert_intrinsics_to_idents()
12630 {
12631   SPTR sptr;
12632   assert(gbl.currsub && gbl.internal == 0,
12633          "only applicable for non-internal subprogram", 0, ERR_Severe);
12634   for (sptr = NOSYM + 1; sptr < stb.firstusym; ++sptr) {
12635     if (DCLDG(sptr) && !EXPSTG(sptr) && IS_INTRINSIC(STYPEG(sptr))) {
12636       SPTR new_sptr = newsym(sptr);
12637       STYPEP(new_sptr, ST_IDENT);
12638     }
12639   }
12640 }
12641 
12642 /*
12643  * In certain contexts, a new symbol must be created immediately
12644  * if the identifier is an intrinsic rather than relying on newsym().
12645  * For example, calling newsym() on a formal argument in an interface
12646  * block creates a new symbol as expected, but the effects of the
12647  * appearance of the intrinsic name in a type statement in an outer
12648  * scope are applied to the new symbol:
12649  *      integer cos	<- sets the DCLD flag of the generic
12650  *      interface
12651  *          subroutine sub(cos)
12652  *          integer cos <- newsym, but generic's DCLD flag is applied
12653  *          endsubroutine
12654  *      endinterface
12655  *      call sub(cos)   <- the first type statement no longer applies
12656  */
12657 static int
chk_intrinsic(int first,LOGICAL now,LOGICAL settype)12658 chk_intrinsic(int first, LOGICAL now, LOGICAL settype)
12659 {
12660   int oldsptr;
12661   int sptr;
12662 
12663   sptr = getocsym(first, OC_OTHER, FALSE);
12664   if (IS_INTRINSIC(STYPEG(sptr))) {
12665     if ((sem.interface && DCLDG(sptr)) || now) {
12666       error(35, 1, gbl.lineno, SYMNAME(sptr), CNULL);
12667       oldsptr = sptr;
12668       sptr = insert_sym(sptr);
12669       if (now && settype && DCLDG(oldsptr)) {
12670         DTYPEP(sptr, DTYPEG(oldsptr));
12671         DCLDP(sptr, TRUE);
12672       }
12673     }
12674   }
12675   return sptr;
12676 }
12677 
12678 /*
12679  * Create a ST_ENTRY for a function ENTRY.  Must be aware of the situation
12680  * where a variable named the same as the entry already exists.
12681  */
12682 static int
create_func_entry(int sptr)12683 create_func_entry(int sptr)
12684 {
12685   int func_result = chk_func_entry_result(sptr);
12686   if (func_result > NOSYM) {
12687     sptr = 0;
12688     if (sem.which_pass && IN_MODULE) {
12689       /* if in a module, we have already seen the ENTRY during
12690        * which_pass == 0; get THAT symbol */
12691       for (sptr = first_hash(func_result); sptr > NOSYM; sptr = HASHLKG(sptr)) {
12692         if (NMPTRG(sptr) == NMPTRG(func_result) && STYPEG(sptr) == ST_PROC &&
12693             FVALG(sptr) == func_result) {
12694           break;
12695         }
12696         if (NMPTRG(sptr) == NMPTRG(func_result) && STYPEG(sptr) == ST_ALIAS &&
12697             STYPEG(SYMLKG(sptr)) == ST_PROC &&
12698             SCOPEG(SYMLKG(sptr)) == SCOPEG(func_result)) {
12699           break;
12700         }
12701       }
12702     }
12703     /* sptr is the old symbol for the entry point, now an ST_PROC */
12704     if (sptr) {
12705       int fval;
12706       if (STYPEG(sptr) == ST_ALIAS) {
12707         fval = FVALG(SYMLKG(sptr));
12708       } else {
12709         fval = FVALG(sptr);
12710       }
12711       if (fval) {
12712         STYPEP(fval, ST_UNKNOWN);
12713         IGNOREP(fval, TRUE);
12714         HIDDENP(fval, TRUE);
12715         FVALP(sptr, 0);
12716       }
12717     } else {
12718       /* A variable is already defined in the same scope of
12719        * the entry and assume that the variable's declaration
12720        * is for the entry.  Create a new symbol as the
12721        * ST_ENTRY; make the variable found by chk_func_entry_result
12722        * the function result of the ST_ENTRY.
12723        */
12724       sptr = insert_sym(func_result);
12725     }
12726 
12727     SCP(func_result, SC_DUMMY);
12728     RESULTP(func_result, TRUE);
12729     pop_sym(func_result);
12730     sptr = declsym(sptr, ST_ENTRY, TRUE);
12731     DTYPEP(sptr, DTYPEG(func_result));
12732     ADJLENP(sptr, ADJLENG(func_result));
12733     DCLDP(sptr, DCLDG(func_result));
12734     FVALP(sptr, func_result);
12735     return sptr;
12736   }
12737   sptr = declsym(sptr, ST_ENTRY, TRUE);
12738   if (SCG(sptr) != SC_NONE)
12739     error(43, 3, gbl.lineno, SYMNAME(sptr), CNULL);
12740   return sptr;
12741 }
12742 
12743 /*
12744  * Create the result variable for a function ENTRY.  Must be aware of the
12745  * situation where a variable named the same as the 'result' already exists.
12746  */
12747 static int
create_func_entry_result(int sptr)12748 create_func_entry_result(int sptr)
12749 {
12750   int func_result = chk_func_entry_result(sptr);
12751   if (func_result > NOSYM) {
12752     /* A variable is already defined in the same scope of
12753      * the entry and assume that the variable's declaration
12754      * is for the entry.  Just use the variable as the
12755      * result of the entry.
12756      */
12757     SCP(func_result, SC_DUMMY);
12758     RESULTP(func_result, TRUE);
12759     return func_result;
12760   }
12761   sptr = declsym(sptr, ST_IDENT, TRUE);
12762   SCP(sptr, SC_DUMMY);
12763   return sptr;
12764 }
12765 
12766 /*
12767  * Retrieve/create a variable in the current scope.  Must be aware of
12768  * the situation where a variable is a function in which case, its
12769  * result variable must be used.
12770  */
12771 static int
create_var(int sym)12772 create_var(int sym)
12773 {
12774   int sptr;
12775   sptr = refsym_inscope(sym, OC_OTHER);
12776   switch (STYPEG(sptr)) {
12777   case ST_ENTRY:
12778     if (gbl.rutype != RU_FUNC) {
12779       error(43, 3, gbl.lineno, "subprogram or entry name", SYMNAME(sptr));
12780       sptr = insert_sym(sptr);
12781     } else {
12782       /* should we specify the RESULT name? */
12783       if (RESULTG(sptr)) {
12784         error(43, 3, gbl.lineno, SYMNAME(sptr),
12785               "- you must specify the RESULT name");
12786       }
12787       sptr = FVALG(sptr);
12788     }
12789     break;
12790   case ST_MODULE:
12791     if (!DCLDG(sptr)) {
12792       /*
12793        * if the module is indirectly USEd (DCLD is not set)
12794        * it's ok to create a new symbol when used.
12795        * Otherwise, the module name is stll visible.
12796        */
12797       sptr = insert_sym(sptr);
12798     }
12799     break;
12800   default:;
12801   }
12802   return sptr;
12803 }
12804 
12805 /*
12806  * For entries, the variable specified in the result clause or
12807  * the variable implied by the entry name may have already been
12808  * declared in the same scope; also, the variable may have already
12809  * been referenced.  Determine if a variable has already been declared
12810  * whose name is the same as the entry or the result variable.
12811  */
12812 static int
chk_func_entry_result(int sptr)12813 chk_func_entry_result(int sptr)
12814 {
12815   int sptr2;
12816 
12817   sptr = refsym(sptr, OC_OTHER);
12818   switch (STYPEG(sptr)) {
12819   case ST_IDENT:
12820   case ST_VAR:
12821   case ST_ARRAY:
12822     switch (SCG(sptr)) {
12823     case SC_NONE:
12824     case SC_LOCAL:
12825       sptr2 = SCOPEG(sptr);
12826       if (sptr2 == 0)
12827         break;
12828       if (STYPEG(sptr2) == ST_ALIAS)
12829         sptr2 = SYMLKG(sptr2);
12830       if (sptr2 == gbl.currsub) {
12831         /* A variable is already defined in the same scope of
12832          * the entry and assume that the variable's declaration
12833          * is for the entry or the result.
12834          */
12835         return sptr;
12836       }
12837       break;
12838     default:;
12839     }
12840     break;
12841   default:;
12842   }
12843   /* a variable with the same name doesn't exist in the same scope: */
12844   return 0;
12845 }
12846 
12847 static void
get_param_alias_const(SST * stkp,int param_sptr,int dtype)12848 get_param_alias_const(SST *stkp, int param_sptr, int dtype)
12849 {
12850   int ast;
12851   int alias;
12852   INT conval;
12853   SST s;
12854   ACL *aclp;
12855 
12856   if (SST_IDG(stkp) == S_EXPR) {
12857     aclp = construct_acl_from_ast(SST_ASTG(stkp), dtype, 0);
12858     if (sem.dinit_error || !aclp) {
12859       return;
12860     }
12861     aclp = eval_init_expr(aclp);
12862     conval = cngcon(aclp->conval, aclp->dtype, dtype);
12863   } else if (SST_IDG(stkp) == S_LVALUE && stkp->value.cnval.acl) {
12864     construct_acl_for_sst(stkp, dtype);
12865     aclp = SST_ACLG(stkp);
12866     if (sem.dinit_error || !aclp) {
12867       return;
12868     }
12869     aclp = eval_init_expr(aclp);
12870     conval = cngcon(aclp->conval, aclp->dtype, dtype);
12871   } else {
12872     conval = chkcon(stkp, dtype, FALSE);
12873   }
12874   CONVAL1P(param_sptr, conval);
12875   if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR || dtype == DT_DEFERCHAR ||
12876       dtype == DT_DEFERNCHAR)
12877     DTYPEP(param_sptr, DTYPEG(CONVAL1G(param_sptr)));
12878   alias = mk_cval1(conval, (int)DTYPEG(param_sptr));
12879   CONVAL2P(param_sptr, alias); /* ast of <expression> */
12880   if (sem.interface == 0)
12881     add_param(param_sptr);
12882   /* create an ast for the parameter; set the alias field of the ast
12883    * so that we don't have to set the alias field whenever the
12884    */
12885   ast = mk_id(param_sptr);
12886   A_ALIASP(ast, alias);
12887 }
12888 
12889 /* get the char length from the initialization expression */
12890 static void
set_string_type_from_init(int sptr,ACL * init_acl)12891 set_string_type_from_init(int sptr, ACL *init_acl)
12892 {
12893   int sdtype = DTYPEG(sptr);
12894   int ndtype = init_acl->dtype;
12895 
12896   if (DTY(ndtype) == TY_ARRAY)
12897     ndtype = DTY(ndtype + 1);
12898   /* get the new char length */
12899   if (DTY(sdtype) == TY_ARRAY) {
12900     /* make array type with new char subtype, same bounds */
12901     ndtype = get_type(3, TY_ARRAY, ndtype);
12902     DTY(ndtype + 2) = DTY(sdtype + 2);
12903   }
12904   DTYPEP(sptr, ndtype);
12905 }
12906 
12907 static void
fixup_param_vars(SST * var,SST * init)12908 fixup_param_vars(SST *var, SST *init)
12909 {
12910   int sptr;
12911   int sptr1;
12912   int dtype;
12913   ADSC *ad;
12914   int sdtype;
12915   ACL *aclp;
12916 
12917   sptr = SST_SYMG(var);
12918   PARAMP(sptr, 1);
12919 
12920   if (SST_IDG(init) == S_EXPR && A_TYPEG(SST_ASTG(init)) == A_INTR &&
12921       DTY(SST_DTYPEG(init)) == TY_ARRAY) {
12922     aclp = construct_acl_from_ast(SST_ASTG(init), SST_DTYPEG(init), 0);
12923     dinit_struct_param(sptr, aclp, SST_DTYPEG(init));
12924 
12925     sdtype = DTYPEG(sptr);
12926     if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
12927         DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) {
12928       set_string_type_from_init(sptr, aclp);
12929     }
12930   } else if (SST_IDG(init) == S_SCONST) {
12931     construct_acl_for_sst(init, SST_DTYPEG(init));
12932     dinit_struct_param(sptr, SST_ACLG(init), SST_DTYPEG(init));
12933 
12934     sdtype = DTYPEG(sptr);
12935     if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
12936         DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) {
12937       set_string_type_from_init(sptr, SST_ACLG(init));
12938     }
12939   } else if (SST_IDG(init) == S_ACONST ||
12940              (SST_IDG(init) == S_IDENT &&
12941               (STYPEG(SST_SYMG(init)) == ST_PARAM || PARAMG(SST_SYMG(init))))) {
12942     sdtype = DTYPEG(sptr);
12943     if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
12944         DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERCHAR) {
12945       set_string_type_from_init(sptr, SST_ACLG(init));
12946     }
12947 
12948     dinit_struct_param(sptr, SST_ACLG(init), DTYPEG(sptr));
12949   } else if (DTY(DTYPEG(sptr)) == TY_ARRAY && SST_IDG(init) == S_CONST &&
12950              (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
12951               DDTG(DTYPEG(sptr)) == DT_ASSNCHAR)) {
12952     aclp = construct_acl_from_ast(SST_ASTG(init), SST_DTYPEG(init), 0);
12953     set_string_type_from_init(sptr, aclp);
12954   } else if (DTY(DTYPEG(sptr)) == TY_ARRAY && SST_IDG(init) == S_CONST) {
12955     aclp = construct_acl_from_ast(SST_ASTG(init), SST_DTYPEG(init), 0);
12956     dinit_struct_param(sptr, aclp, SST_DTYPEG(init));
12957   }
12958 
12959   if ((STYPEG(sptr) == ST_ARRAY) && SCG(sptr) == SC_NONE &&
12960       SCOPEG(sptr) == stb.curr_scope) {
12961     STYPEP(sptr, ST_PARAM);
12962     if (flg.xref)
12963       xrefput(sptr, 'd');
12964   } else if (STYPEG(sptr) == ST_VAR && DTY(DTYPEG(sptr)) == TY_ARRAY &&
12965              SCOPEG(sptr) == stb.curr_scope) {
12966 /* HACK: if the named constant being defined has an initializer
12967  * that contains an intrinsic call that uses the named constant
12968  * as an argument, then the argument handling may have
12969  * changed the item's STYPE to ST_VAR when array. Change it back to
12970  * an ST_PARAM.
12971  */
12972     STYPEP(sptr, ST_PARAM);
12973     if (flg.xref)
12974       xrefput(sptr, 'd');
12975 
12976   } else if (STYPEG(sptr) == ST_VAR && SCOPEG(sptr) == stb.curr_scope &&
12977              KINDG(sptr)) {
12978     /* Overloaded type parameter */
12979     STYPEP(sptr, ST_PARAM);
12980     if (flg.xref)
12981       xrefput(sptr, 'd');
12982 
12983   } else if (STYPEG(sptr) == ST_IDENT && SCOPEG(sptr) == stb.curr_scope) {
12984     STYPEP(sptr, ST_PARAM);
12985     if (flg.xref)
12986       xrefput(sptr, 'd');
12987 
12988   } else {
12989     sptr = declsym(sptr, ST_PARAM, TRUE);
12990     if (SCG(sptr) != SC_NONE) {
12991       error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
12992       return;
12993     }
12994   }
12995 
12996   dtype = DTYPEG(sptr);
12997   if (DTY(dtype) == TY_DERIVED) {
12998     sptr1 = get_param_alias_var(sptr, dtype);
12999   } else if (DTY(dtype) == TY_ARRAY) {
13000     ad = AD_DPTR(dtype);
13001     if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) {
13002       error(84, 3, gbl.lineno, SYMNAME(sptr),
13003             "- a named constant array must have constant extents");
13004       return;
13005     }
13006 
13007     sptr1 = get_param_alias_var(sptr, dtype);
13008     STYPEP(sptr1, ST_ARRAY);
13009     if (sem.interface == 0) {
13010       init_named_array_constant(sptr, gbl.currsub);
13011     }
13012   } else {
13013     get_param_alias_const(init, sptr, dtype);
13014 
13015     sdtype = DTYPEG(sptr);
13016     if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
13017         DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) {
13018       set_string_type_from_init(sptr, SST_ACLG(init));
13019     }
13020   }
13021 }
13022 
13023 static void
save_typedef_init(int sptr,int dtype)13024 save_typedef_init(int sptr, int dtype)
13025 {
13026   ACL *ict;
13027 
13028   if (!stsk->ict_beg) {
13029     DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */
13030     /* Pop out to parent structure (if any) */
13031     sem.stsk_depth--;
13032     stsk = &STSK_ENT(0);
13033     return;
13034   }
13035 
13036   if (sem.stsk_depth == 1 && stsk->ict_beg != NULL) {
13037     /* This is the outer most structure, fix up top subc ict entry */
13038     ict = GET_ACL(15);
13039     ict->id = AC_TYPEINIT;
13040     ict->next = NULL;
13041     ict->subc = stsk->ict_beg;
13042     ict->repeatc = astb.i1;
13043     ict->sptr = sptr;
13044     ict->dtype = dtype;
13045     stsk->ict_beg = ict;
13046   }
13047   df_dinit(NULL, ict);
13048   DTY(dtype + 5) = put_getitem_p(stsk->ict_beg);
13049 
13050   DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */
13051 
13052   /* Pop out to parent structure (if any) */
13053   sem.stsk_depth--;
13054   stsk = &STSK_ENT(0);
13055 
13056 }
13057 
13058 void
build_typedef_init_tree(int sptr,int dtype)13059 build_typedef_init_tree(int sptr, int dtype)
13060 {
13061   ACL *ict;
13062   ACL *ict1;
13063   int td_dtype;
13064 
13065   td_dtype = DDTG(dtype);
13066 
13067   ict1 = (ACL *)get_getitem_p(DTY(td_dtype + 5));
13068   if (ict1) {
13069     /* Need to build an initializer constant tree */
13070     ict = GET_ACL(15);
13071     *ict = *ict1;
13072     ict->sptr = sptr;
13073     if (DTY(DTYPEG(sptr)) == TY_ARRAY)
13074       ict->repeatc = AD_NUMELM(AD_PTR(sptr));
13075     else
13076       ict->repeatc = astb.i1;
13077     if (ict->sptr)
13078       save_struct_init(ict);
13079     if (INSIDE_STRUCT) {
13080       if (stsk->ict_end)
13081         stsk->ict_end->next = ict;
13082       else
13083         stsk->ict_beg = ict;
13084       stsk->ict_end = ict;
13085     } else {
13086       /* For initialized sptr, don't create init list */
13087       if (DINITG(sptr) && DTY(td_dtype) == TY_DERIVED && !SAVEG(sptr))
13088         return;
13089 
13090       dinit_no_dinitp((VAR *)NULL, ict);
13091     }
13092   }
13093 }
13094 
13095 static void
init_allocatable_typedef_components(SPTR td_sptr)13096 init_allocatable_typedef_components(SPTR td_sptr)
13097 {
13098   DTYPE td_dtype = DTYPEG(td_sptr);
13099   SPTR sptr = 0;
13100   SPTR fld_sptr;
13101   ACL *td_aclp;
13102   ACL **aclpp;
13103   int init_ict = get_struct_initialization_tree(td_dtype);
13104 
13105   if (init_ict) {
13106     td_aclp = get_getitem_p(init_ict);
13107   } else {
13108     td_aclp = GET_ACL(15);
13109     td_aclp->id = AC_TYPEINIT;
13110     td_aclp->sptr = td_sptr;
13111     td_aclp->dtype = td_dtype;
13112   }
13113   aclpp = &td_aclp->subc;
13114 
13115   for (fld_sptr = DTY(td_dtype + 1); fld_sptr > NOSYM;
13116        fld_sptr = SYMLKG(fld_sptr)) {
13117     ACL *aclp = NULL;
13118     DTYPE fld_dtype = DTYPEG(fld_sptr);
13119     if (is_array_dtype(fld_dtype))
13120       fld_dtype = array_element_dtype(fld_dtype);
13121 
13122     /* position the init list ptr */
13123     if (*aclpp) {
13124       for (sptr = td_sptr;
13125            sptr > NOSYM && sptr != fld_sptr && sptr != (*aclpp)->sptr;
13126            sptr = SYMLKG(sptr))
13127         continue;
13128       if (sptr == (*aclpp)->sptr) {
13129         /* this field already has an initializer */
13130         aclpp = &(*aclpp)->next;
13131         continue;
13132       }
13133     }
13134 
13135     if (DTY(fld_dtype) == TY_DERIVED && ALLOCFLDG(sptr)) {
13136       init_allocatable_typedef_components(fld_sptr);
13137       aclp = get_getitem_p(get_struct_initialization_tree(fld_dtype));
13138     } else if (ALLOCATTRG(fld_sptr)) {
13139       aclp = mk_init_intrinsic(AC_I_null);
13140     }
13141     if (aclp) {
13142       aclp->sptr = MIDNUMG(fld_sptr);
13143       aclp->next = *aclpp;
13144       *aclpp = aclp;
13145       aclpp = &aclp->next;
13146     }
13147   }
13148 
13149   df_dinit(NULL, td_aclp);
13150   if (!init_ict) { /* this is the "initialization tree" field */
13151     DTY(td_dtype + 5) = put_getitem_p(td_aclp);
13152   }
13153 }
13154 
13155 static void
symatterr(int sev,int sptr,char * att)13156 symatterr(int sev, int sptr, char *att)
13157 {
13158   char buf[100];
13159   snprintf(buf, sizeof buf, "Attribute '%s' cannot be applied to symbol", att);
13160   buf[sizeof buf - 1] = '\0'; /* Windows snprintf bug workaround */
13161   error(155, sev, gbl.lineno, buf, SYMNAME(sptr));
13162 }
13163 
13164 static void
fixup_function_return_type(int retdtype,int dtsptr)13165 fixup_function_return_type(int retdtype, int dtsptr)
13166 {
13167   dtsptr = lookupsymbol(SYMNAME(dtsptr));
13168   if (dtsptr && dtsptr != DTY(retdtype + 3)) {
13169     DTYPEP(gbl.currsub, DTYPEG(dtsptr));
13170     DTYPEP(FVALG(gbl.currsub), DTYPEG(dtsptr));
13171   } else if (sem.pgphase > PHASE_SPEC) {
13172     error(4, 3, FUNCLINEG(gbl.currsub),
13173           "Function return type has not been declared", CNULL);
13174     DTYPEP(gbl.currsub, DTYPEG(dtsptr));
13175     DTYPEP(FVALG(gbl.currsub), DTYPEG(dtsptr));
13176   }
13177 }
13178 
13179 static int
fixup_KIND_expr(int ast)13180 fixup_KIND_expr(int ast)
13181 {
13182   int newast = ast;
13183   int tmp_ast1 = 0;
13184   int tmp_ast2 = 0;
13185   int sptr;
13186   int newsptr;
13187   int ndim;
13188   int subs[MAXRANK];
13189   int argt;
13190   int i;
13191   int changed;
13192   float f;
13193 
13194   switch (A_TYPEG(ast)) {
13195   case A_CNST:
13196     if (DT_ISREAL(A_DTYPEG(ast))) {
13197       newast = mk_convert(ast, DT_INT);
13198     }
13199     break;
13200   case A_SUBSCR: /* NECESSARY? */
13201     sptr = A_SPTRG(A_LOPG(ast));
13202     ndim = ADD_NUMDIM(DTYPEG(sptr));
13203     argt = A_ARGSG(ast);
13204     changed = tmp_ast1 = fixup_KIND_expr(A_LOPG(ast));
13205     tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast);
13206     for (i = 0; i < ndim; i++) {
13207       changed |= tmp_ast2 = fixup_KIND_expr(ARGT_ARG(argt, i));
13208       subs[i] = tmp_ast2 ? tmp_ast2 : ARGT_ARG(argt, i);
13209     }
13210     if (changed) {
13211       newast = mk_subscr(tmp_ast1, subs, ndim, A_DTYPEG(ast));
13212     }
13213     break;
13214   case A_MEM: /* NECESSARY? */
13215     tmp_ast1 = fixup_KIND_expr(A_PARENTG(ast));
13216     tmp_ast2 = fixup_KIND_expr(A_MEMG(ast));
13217     if (tmp_ast1 || tmp_ast2) {
13218       tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast);
13219       tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(ast);
13220       newast = mk_member(tmp_ast1, tmp_ast2, A_DTYPEG(ast));
13221     }
13222     break;
13223   case A_UNOP:
13224     tmp_ast1 = fixup_KIND_expr(A_LOPG(ast));
13225     if (tmp_ast1) {
13226       newast = mk_unop(A_OPTYPEG(ast), tmp_ast1, A_DTYPEG(ast));
13227     }
13228     break;
13229   case A_BINOP:
13230     tmp_ast1 = fixup_KIND_expr(A_LOPG(ast));
13231     tmp_ast2 = fixup_KIND_expr(A_ROPG(ast));
13232     if (tmp_ast1 || tmp_ast2) {
13233       tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast);
13234       tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(ast);
13235       newast = mk_binop(A_OPTYPEG(ast), tmp_ast1, tmp_ast2, DT_INT);
13236     }
13237     break;
13238   case A_FUNC:
13239     /* could be an subscripted array expr */
13240     sptr = findByNameStypeScope(SYMNAME(A_SPTRG(A_LOPG(ast))), ST_PARAM, 0);
13241     if (sptr && DTY(DTYPEG(sptr)) == TY_ARRAY) {
13242       tmp_ast1 = mk_id(CONVAL1G(sptr));
13243       ndim = ADD_NUMDIM(DTYPEG(sptr));
13244       if (ndim != A_ARGCNTG(ast))
13245         break;
13246       argt = A_ARGSG(ast);
13247       for (i = 0; i < ndim; i++) {
13248         subs[i] = ARGT_ARG(argt, i);
13249       }
13250       newast = mk_subscr(tmp_ast1, subs, ndim, DTYPEG(sptr));
13251     }
13252     break;
13253   case A_ID:
13254     sptr = A_SPTRG(ast);
13255     if (!SCOPEG(sptr) || sem.pgphase == PHASE_USE) {
13256       newsptr = findByNameStypeScope(SYMNAME(A_SPTRG(ast)), ST_PARAM, 0);
13257       if (newsptr != sptr) {
13258         if (STYPEG(newsptr) == ST_CONST) {
13259           /* MORE can this happen, A_ID&ST_CONST */
13260           newast = mk_cnst(newsptr);
13261         } else if (STYPEG(newsptr) == ST_PARAM) {
13262           newast = CONVAL2G(newsptr);
13263         } else {
13264           newast = 0;
13265         }
13266       }
13267     }
13268     break;
13269   }
13270   return newast;
13271 }
13272 
13273 static int
eval_KIND_expr(int ast,int * val,int * dtyp)13274 eval_KIND_expr(int ast, int *val, int *dtyp)
13275 {
13276   int val1;
13277   int val2;
13278   int tmp_ast1;
13279   int tmp_ast2;
13280   int sptr;
13281   int success = 0;
13282 
13283   if (!ast)
13284     return 0;
13285 
13286   if (A_ALIASG(ast)) {
13287     *dtyp = A_DTYPEG(ast);
13288     ast = A_ALIASG(ast);
13289   }
13290 
13291   switch (A_TYPEG(ast)) {
13292   case A_CNST:
13293     *dtyp = A_DTYPEG(ast);
13294     *val = CONVAL2G(A_SPTRG(ast));
13295     success = 1;
13296     break;
13297   case A_UNOP:
13298     if (eval_KIND_expr(A_LOPG(ast), &val1, dtyp)) {
13299       if (A_OPTYPEG(ast) == OP_SUB)
13300         *val = negate_const(val1, A_DTYPEG(ast));
13301       if (A_OPTYPEG(ast) == OP_LNOT)
13302         *val = ~(val1);
13303       *dtyp = A_DTYPEG(ast);
13304       success = 1;
13305     }
13306     break;
13307   case A_BINOP:
13308     if (eval_KIND_expr(A_LOPG(ast), &val1, dtyp) &&
13309         eval_KIND_expr(A_ROPG(ast), &val2, dtyp)) {
13310       *val = const_fold(A_OPTYPEG(ast), val1, val2, A_DTYPEG(ast));
13311       *dtyp = A_DTYPEG(ast);
13312       success = 1;
13313     }
13314     break;
13315   case A_SUBSCR:
13316   case A_MEM:
13317     tmp_ast1 = complex_alias(ast);
13318     if (eval_KIND_expr(tmp_ast1, &val1, dtyp)) {
13319       *val = val1;
13320       success = 1;
13321     }
13322     break;
13323   }
13324 
13325   return success;
13326 }
13327 
13328 static void
get_retval_KIND_value()13329 get_retval_KIND_value()
13330 {
13331   int sptr;
13332   int sav_gbl_lineno = gbl.lineno;
13333   int val = -1;
13334   int dtyp;
13335   int l_ast1;
13336 
13337   gbl.lineno = sem.deferred_kind_len_lineno;
13338 
13339   /* Handle deferred KIND spec */
13340   if (A_TYPEG(sem.deferred_func_kind) == A_ID) {
13341     sptr = findByNameStypeScope(SYMNAME(A_SPTRG(sem.deferred_func_kind)),
13342                                 ST_PARAM, 0);
13343     if (sptr) {
13344       dtyp = DTYPEG(sptr);
13345       val = CONVAL1G(sptr);
13346       if (STYPEG(A_SPTRG(sem.deferred_func_kind)) == ST_UNKNOWN) {
13347         IGNOREP(A_SPTRG(sem.deferred_func_kind), TRUE);
13348         HIDDENP(A_SPTRG(sem.deferred_func_kind), TRUE);
13349       }
13350     }
13351   } else if (A_ISEXPR(A_TYPEG(sem.deferred_func_kind))) {
13352     l_ast1 = fixup_KIND_expr(sem.deferred_func_kind);
13353     if (!eval_KIND_expr(l_ast1, &val, &dtyp)) {
13354       val = -1;
13355     }
13356   }
13357 
13358   if (val < 0) {
13359     errsev(87);
13360     goto exit;
13361   }
13362 
13363   if (dtyp != DT_INT4) {
13364     errwarn(91);
13365     goto exit;
13366   }
13367 
13368   if ((dtyp =
13369            select_kind(DTYPEG(gbl.currsub), DTY(DTYPEG(gbl.currsub)), val))) {
13370     DTYPEP(gbl.currsub, dtyp);
13371     DTYPEP(FVALG(gbl.currsub), dtyp);
13372     if ((sptr = findByNameStypeScope(SYMNAME(gbl.currsub), ST_ALIAS, 0))) {
13373       DTYPEP(sptr, dtyp);
13374     }
13375   }
13376 
13377 exit:
13378   gbl.lineno = sav_gbl_lineno;
13379   sem.deferred_func_kind = 0;
13380   if (!sem.deferred_func_len)
13381     sem.deferred_kind_len_lineno = 0;
13382 }
13383 
13384 static void
get_retval_LEN_value()13385 get_retval_LEN_value()
13386 {
13387   int sptr;
13388   int sav_gbl_lineno = gbl.lineno;
13389   int val = -1;
13390   int dtyp = 0;
13391   int l_ast1;
13392 
13393   gbl.lineno = sem.deferred_kind_len_lineno;
13394 
13395   /* Handle deferred LEN spec */
13396   l_ast1 = fixup_KIND_expr(sem.deferred_func_len);
13397   if (A_TYPEG(l_ast1) == A_CNST) {
13398     dtyp = mod_type(sem.ogdtype, DTY(sem.ogdtype), 1, CONVAL2G(A_SPTRG(l_ast1)),
13399                     0, gbl.currsub);
13400     if (dtyp) {
13401       DTYPEP(gbl.currsub, dtyp);
13402       DTYPEP(FVALG(gbl.currsub), dtyp);
13403     }
13404   } else {
13405     dtyp = mod_type(sem.ogdtype, DTY(sem.ogdtype), 4, l_ast1, 0, gbl.currsub);
13406     if (dtyp) {
13407       DTYPEP(gbl.currsub, dtyp);
13408       ADJLENP(gbl.currsub, 1);
13409       DTYPEP(FVALG(gbl.currsub), dtyp);
13410       ADJLENP(FVALG(gbl.currsub), 1);
13411     }
13412   }
13413 
13414 exit:
13415   gbl.lineno = sav_gbl_lineno;
13416   sem.deferred_func_len = 0;
13417   sem.deferred_kind_len_lineno = 0;
13418 }
13419 
13420 static void
get_retval_derived_type()13421 get_retval_derived_type()
13422 {
13423   int sptr;
13424   LOGICAL found = FALSE;
13425 
13426   if (gbl.rutype == RU_FUNC) {
13427     for (sptr = first_hash(sem.deferred_dertype); sptr > NOSYM;
13428          sptr = HASHLKG(sptr)) {
13429       if (sptr == sem.deferred_dertype)
13430         continue;
13431       if (STYPEG(sptr) == ST_TYPEDEF && STYPEG(SCOPEG(sptr)) == ST_MODULE) {
13432         pop_sym(sem.deferred_dertype);
13433         found = TRUE;
13434         break;
13435       }
13436     }
13437   }
13438 
13439   if (found) {
13440     DTYPEP(gbl.currsub, DTYPEG(sptr));
13441     DTYPEP(FVALG(gbl.currsub), DTYPEG(sptr));
13442   } else {
13443     error(155, 3, sem.deferred_kind_len_lineno,
13444           "Derived type has not been declared -",
13445           SYMNAME(sem.deferred_dertype));
13446   }
13447 
13448 exit:
13449   sem.deferred_dertype = 0;
13450   sem.deferred_kind_len_lineno = 0;
13451 }
13452 
13453 static void
process_bind(int sptr)13454 process_bind(int sptr)
13455 {
13456   int b_type;
13457   int b_bitv;
13458   int need_altname = 0;
13459   char *np;
13460   char *w32_name;
13461   int wsptr;
13462 
13463   /* A module routine without an explicit C name uses the routine name. */
13464   if (!XBIT(58,0x200000)) {
13465     if ((bind_attr.exist & DA_B(DA_C)) &&
13466         !bind_attr.altname && INMODULEG(sptr) &&
13467         (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY)) {
13468       char *np = SYMNAME(sptr);
13469       bind_attr.exist |= DA_B(DA_ALIAS);
13470       bind_attr.altname = getstring(np, strlen(np));
13471     }
13472   }
13473 
13474   b_type = 0;
13475   for (b_bitv = bind_attr.exist; b_bitv; b_bitv >>= 1, b_type++) {
13476 
13477     if ((b_bitv & 1) == 0)
13478       continue;
13479 
13480     switch (b_type) {
13481     case DA_ALIAS:
13482       /* An altname can't be empty.  Exit early to use a "normal" mangled
13483        * variant of the primary symbol name. */
13484       np = stb.n_base + CONVAL1G(bind_attr.altname);
13485       if (!*np)
13486         return;
13487       ALTNAMEP(sptr, bind_attr.altname);
13488       break;
13489     case DA_C:
13490 
13491 #if defined(TARGET_OSX)
13492       /* add underscore to OSX common block names */
13493       if (STYPEG(sptr) == ST_CMBLK)
13494         need_altname = 1;
13495 #endif
13496       /* NEW CFUNCP and REFERENCEP */
13497       CFUNCP(sptr, 1);
13498       if ((STYPEG(sptr) == ST_PROC) || (STYPEG(sptr) == ST_ENTRY)) {
13499         PASSBYREFP(sptr, 1);
13500         MSCALLP(sptr, 0);
13501       }
13502 
13503       break;
13504     } /* end switch */
13505 
13506   } /* end for */
13507 
13508   if ((need_altname) && ALTNAMEG(sptr) == 0) {
13509     /* set default altname, so that no underbar gets added */
13510     ALTNAMEP(sptr, getstring(SYMNAME(sptr), strlen(SYMNAME(sptr))));
13511   }
13512 } /* process_bind */
13513 
13514 static void
clear_ident_list()13515 clear_ident_list()
13516 {
13517   IDENT_LIST *curr, *curr_next;
13518   IDENT_PROC_LIST *curr_proc, *curr_proc_next;
13519   long hashval;
13520 
13521   if (!sem.which_pass || !dirty_ident_base || gbl.internal > 1) {
13522     return;
13523   }
13524 
13525   for (hashval = 0; hashval < HASHSIZE; ++hashval) {
13526     for (curr = ident_base[hashval]; curr;) {
13527       for (curr_proc = curr->proc_list; curr_proc;) {
13528         curr_proc_next = curr_proc->next;
13529         FREE(curr_proc);
13530         curr_proc = curr_proc_next;
13531       }
13532       curr->proc_list = 0;
13533       curr_next = curr->next;
13534       FREE(curr);
13535       curr = curr_next;
13536     }
13537     ident_base[hashval] = 0;
13538   }
13539 
13540   dirty_ident_base = FALSE;
13541 }
13542 
13543 /** \brief Emit a warning if a duplicate subproblem prefix is used.
13544  */
13545 static void
check_duplicate(bool checker,const char * op)13546 check_duplicate(bool checker, const char *op)
13547 {
13548   if (checker)
13549    error(1054, ERR_Warning, gbl.lineno, op, NULL);
13550 }
13551 
13552 /** \brief Reset subprogram prefixes to zeroes
13553  */
13554 static void
clear_subp_prefix_settings(struct subp_prefix_t * subp)13555 clear_subp_prefix_settings(struct subp_prefix_t *subp)
13556 {
13557   BZERO(subp, struct subp_prefix_t, 1);
13558 }
13559 
13560 /** \brief MODULE prefix checking for subprograms
13561            C1547: cannot be inside a an abstract interface
13562  */
13563 static void
check_module_prefix()13564 check_module_prefix()
13565 {
13566   if (sem.interface && subp_prefix.module &&
13567       sem.interf_base[sem.interface - 1].abstract)
13568     error(1055, ERR_Severe, gbl.lineno, NULL, NULL);
13569 }
13570 
13571 static void
decr_ident_use(int ident,int proc)13572 decr_ident_use(int ident, int proc)
13573 {
13574   long hashval;
13575   IDENT_LIST *curr;
13576   IDENT_PROC_LIST *curr_proc;
13577 
13578   if (sem.which_pass || !dirty_ident_base || gbl.internal <= 1) {
13579     return;
13580   }
13581   HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident)))
13582   for (curr = ident_base[hashval]; curr; curr = curr->next) {
13583     if (strcmp(curr->ident, SYMNAME(ident)) == 0) {
13584       for (curr_proc = curr->proc_list; curr_proc;
13585            curr_proc = curr_proc->next) {
13586         if (strcmp(SYMNAME(proc), curr_proc->proc_name) == 0) {
13587           curr_proc->usecnt -= 1;
13588         }
13589       }
13590     }
13591   }
13592 }
13593 
13594 static void
defer_ident_list(int ident,int proc)13595 defer_ident_list(int ident, int proc)
13596 {
13597 
13598   long hashval;
13599   IDENT_LIST *curr;
13600   IDENT_PROC_LIST *curr_proc;
13601 
13602   if (STYPEG(ident) && SCOPEG(ident) == gbl.currsub && SCOPEG(ident) != proc) {
13603     /* Note: if STYPEG(ident) == 0, then this is an implicitly defined symbol */
13604     proc = SCOPEG(ident);
13605   }
13606   HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident)));
13607   for (curr = ident_base[hashval]; curr; curr = curr->next) {
13608     if (strcmp(curr->ident, SYMNAME(ident)) != 0)
13609       continue;
13610     for (curr_proc = curr->proc_list; curr_proc; curr_proc = curr_proc->next) {
13611       if (strcmp(SYMNAME(proc), curr_proc->proc_name) == 0) {
13612         curr_proc->usecnt += 1;
13613         return; /* identifier and procedure already added */
13614       }
13615     }
13616     /* add procedure name */
13617     dirty_ident_base = TRUE;
13618     NEW(curr_proc, IDENT_PROC_LIST, 1);
13619     NEW(curr_proc->proc_name, char, strlen(SYMNAME(proc)) + 1);
13620     strcpy(curr_proc->proc_name, SYMNAME(proc));
13621     curr_proc->next = curr->proc_list;
13622     curr->proc_list = curr_proc;
13623     curr_proc->usecnt = 1;
13624     return;
13625   }
13626   /* add identifier and create new procedure list */
13627   NEW(curr, IDENT_LIST, 1);
13628   NEW(curr->ident, char, strlen(SYMNAME(ident)) + 1);
13629   strcpy(curr->ident, SYMNAME(ident));
13630   NEW(curr_proc, IDENT_PROC_LIST, 1);
13631   NEW(curr_proc->proc_name, char, strlen(SYMNAME(proc)) + 1);
13632   strcpy(curr_proc->proc_name, SYMNAME(proc));
13633   curr->proc_list = curr_proc;
13634   curr_proc->next = 0;
13635   curr_proc->usecnt = 1;
13636   curr->next = ident_base[hashval];
13637   ident_base[hashval] = curr;
13638   dirty_ident_base = TRUE;
13639 }
13640 
13641 int
internal_proc_has_ident(int ident,int proc)13642 internal_proc_has_ident(int ident, int proc)
13643 {
13644   long hashval;
13645   IDENT_LIST *curr;
13646   IDENT_PROC_LIST *curr_proc;
13647 
13648   if (!dirty_ident_base)
13649     return 0;
13650 
13651   HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident)));
13652   for (curr = ident_base[hashval]; curr; curr = curr->next) {
13653     if (strcmp(curr->ident, SYMNAME(ident)) == 0) {
13654       for (curr_proc = curr->proc_list; curr_proc;
13655            curr_proc = curr_proc->next) {
13656         if (strcmp(curr_proc->proc_name, SYMNAME(proc)) == 0 &&
13657             curr_proc->usecnt > 0) {
13658           return 1;
13659         }
13660       }
13661     }
13662   }
13663   return 0;
13664 }
13665 
13666 #ifdef GSCOPEP
13667 static void
prop_reqgs(int ast)13668 prop_reqgs(int ast)
13669 {
13670   switch (A_TYPEG(ast)) {
13671   case A_ID:
13672     GSCOPEP(A_SPTRG(ast), 1);
13673     break;
13674   case A_SUBSCR:
13675   case A_SUBSTR:
13676   case A_UNOP:
13677     prop_reqgs(A_LOPG(ast));
13678     break;
13679   case A_MEM:
13680     prop_reqgs(A_PARENTG(ast));
13681     break;
13682   case A_BINOP:
13683     prop_reqgs(A_LOPG(ast));
13684     prop_reqgs(A_ROPG(ast));
13685     break;
13686   }
13687 }
13688 
13689 static void
fixup_ident_bounds(int sptr)13690 fixup_ident_bounds(int sptr)
13691 {
13692   int dtype, numdim, i;
13693   ADSC *ad;
13694 
13695   if (GSCOPEG(sptr)) {
13696     dtype = DTYPEG(sptr);
13697     if (DTY(dtype) != TY_ARRAY)
13698       return;
13699     ad = AD_DPTR(dtype);
13700     numdim = AD_NUMDIM(ad);
13701     prop_reqgs(AD_NUMELM(ad));
13702     prop_reqgs(AD_ZBASE(ad));
13703     for (i = 0; i < numdim; ++i) {
13704       prop_reqgs(AD_LWAST(ad, i));
13705       prop_reqgs(AD_UPAST(ad, i));
13706       prop_reqgs(AD_EXTNTAST(ad, i));
13707       prop_reqgs(AD_MLPYR(ad, i));
13708     }
13709   }
13710 }
13711 
13712 void
fixup_reqgs_ident(int sptr)13713 fixup_reqgs_ident(int sptr)
13714 {
13715   if (GSCOPEG(sptr)) {
13716     if (SDSCG(sptr)) {
13717       GSCOPEP(SDSCG(sptr), 1);
13718     }
13719     if (PTRVG(sptr)) {
13720       GSCOPEP(PTRVG(sptr), 1);
13721     }
13722     if (MIDNUMG(sptr)) {
13723       GSCOPEP(MIDNUMG(sptr), 1);
13724     }
13725     if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
13726       fixup_ident_bounds(sptr);
13727     }
13728   }
13729 }
13730 
13731 #endif
13732 
13733 static void
defer_iface(int iface,int dtype,int proc,int mem)13734 defer_iface(int iface, int dtype, int proc, int mem)
13735 {
13736   int pass, len, tag;
13737   iface_avail++;
13738   NEED(iface_avail, iface_base, IFACE, iface_size, iface_avail + 50);
13739   iface_base[iface_avail - 1].iface = iface;
13740   iface_base[iface_avail - 1].dtype = dtype;
13741   iface_base[iface_avail - 1].proc = proc;
13742   iface_base[iface_avail - 1].scope = SCOPEG(mem);
13743   iface_base[iface_avail - 1].internal = gbl.internal;
13744   /* Need to save which sem pass created this iface */
13745   iface_base[iface_avail - 1].sem_pass = sem.which_pass;
13746 
13747   len = strlen(SYMNAME(iface)) + 1;
13748   NEW(iface_base[iface_avail - 1].iface_name, char, len);
13749   strcpy(iface_base[iface_avail - 1].iface_name, SYMNAME(iface));
13750 
13751   iface_base[iface_avail - 1].tag_name = 0;
13752   iface_base[iface_avail - 1].pass_class = 0;
13753 
13754   if (mem && STYPEG(mem) == ST_MEMBER) {
13755     iface_base[iface_avail - 1].mem = mem;
13756     pass = PASSG(mem);
13757     if (pass && DTYPEG(pass) != stsk->dtype) {
13758       /* assume dtype of pass argument is same as enclosed dtype.
13759        * We do this since PASS will get written to a module before
13760        * we can fix it after we've seen the procedure/interface.
13761        * If the pass argument differs from enclosed dtype, we will
13762        * catch it in do_iface().
13763        */
13764       DTYPEP(pass, stsk->dtype);
13765     }
13766 
13767   } else {
13768     iface_base[iface_avail - 1].mem = 0;
13769   }
13770 
13771   iface_base[iface_avail - 1].proc_var = mem;
13772   iface_base[iface_avail - 1].lineno = gbl.lineno;
13773 }
13774 
13775 /** \brief This routine sets the PASS field in a procedure pointer for
13776   * semantic pass 0 prior to call to end_module().
13777   *
13778   * This is needed, otherwise we may incorrectly write the procedure pointer
13779   * module info without PASS set.
13780   */
13781 static void
fix_iface0()13782 fix_iface0()
13783 {
13784   int i, iface, proc, mem;
13785   char *name;
13786 
13787   if (sem.which_pass)
13788     return;
13789 
13790   for (i = 0; i < iface_avail; i++) {
13791     mem = iface_base[i].mem;
13792     name = iface_base[i].iface_name;
13793 
13794     if (!name || !mem)
13795       continue;
13796     iface = findByNameStypeScope(name, ST_PROC, 0);
13797     iface_base[i].stype = STYPEG(iface); /* need to save stype */
13798     if (iface && !PASSG(mem) && !NOPASSG(mem)) {
13799       int arg_sptr = aux.dpdsc_base[DPDSCG(iface)];
13800       PASSP(mem, arg_sptr);
13801     }
13802   }
13803 }
13804 
13805 static void
fix_iface(int sptr)13806 fix_iface(int sptr)
13807 {
13808   int len, tag, i, iface, proc, mem, dtype;
13809   int *dscptr;
13810   char *name;
13811 
13812   for (i = 0; i < iface_avail; i++) {
13813     iface = iface_base[i].iface;
13814     proc = iface_base[i].proc;
13815     mem = iface_base[i].mem;
13816     name = iface_base[i].iface_name;
13817     dtype = iface_base[i].dtype;
13818     if (!iface && mem && dtype && !NOPASSG(mem) &&
13819         strcmp(name, SYMNAME(sptr)) == 0) {
13820       iface = sptr;
13821       iface_base[i].iface = sptr;
13822     }
13823     if (iface && sptr && strcmp(name, SYMNAME(sptr)) == 0) {
13824       iface_base[i].iface = sptr;
13825       if (!PASSG(mem) && !NOPASSG(mem)) {
13826         dscptr = aux.dpdsc_base + DPDSCG(iface);
13827         PASSP(mem, *dscptr);
13828       } else if (PASSG(mem)) {
13829         int j = find_dummy_position(iface, PASSG(mem));
13830         if (j > 0)
13831           PASSP(mem, aux.dpdsc_base[DPDSCG(iface) + j - 1]);
13832       }
13833 #ifdef CLASSG
13834       if (CLASSG(PASSG(mem))) {
13835         iface_base[i].pass_class = 1;
13836 
13837         tag = DTYPEG(PASSG(mem));
13838         tag = DTY(tag + 3);
13839 
13840         len = strlen(SYMNAME(tag)) + 1;
13841         NEW(iface_base[iface_avail - 1].tag_name, char, len);
13842         strcpy(iface_base[iface_avail - 1].tag_name, SYMNAME(tag));
13843       }
13844 #endif
13845     }
13846   }
13847 }
13848 
13849 /* Called during sem pass 0 at the end of the subroutine/function. We attempt
13850  * to share compatible procedure pointer dtypes found in argument descriptors.
13851  * This fixes a problem exhibited in the Whizard code where we perform an
13852  * argument check on a call to a forward referenced internal procedure. In
13853  * this case, the argument's DT_PROC dtype has not yet been seen.
13854  */
13855 static void
fix_proc_ptr_dummy_args()13856 fix_proc_ptr_dummy_args()
13857 {
13858 
13859   int paramct, dpdsc, i;
13860 
13861   if (sem.which_pass)
13862     return;
13863   proc_arginfo(gbl.currsub, &paramct, &dpdsc, NULL);
13864   for (i = 0; i < paramct; ++i) {
13865     int sptr = aux.dpdsc_base[dpdsc + i];
13866     if (is_procedure_ptr(sptr) && SCG(sptr) == SC_DUMMY) {
13867       char *symname = SYMNAME(sptr);
13868       int len = strlen(symname);
13869       int hash, hptr;
13870       HASH_ID(hash, symname, len);
13871       for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
13872         if (is_procedure_ptr(hptr) && strcmp(symname, SYMNAME(hptr)) == 0) {
13873           if (hptr != sptr && test_scope(hptr) >= 0) {
13874             DTYPE d1 = DTYPEG(sptr);
13875             DTYPE d2 = DTYPEG(hptr);
13876             if (cmp_interfaces(DTY(d1 + 2), DTY(d2 + 2), TRUE)) {
13877               DTYPEP(sptr, d2);
13878               break;
13879             }
13880           }
13881         }
13882       }
13883     }
13884   }
13885 }
13886 
13887 static void
do_iface(int iface_state)13888 do_iface(int iface_state)
13889 {
13890   int i;
13891   for (i = 0; i < iface_avail; i++) {
13892     _do_iface(iface_state, i);
13893   }
13894   if (iface_state) {
13895     iface_avail = 0;
13896   }
13897 }
13898 
13899 static void
do_iface_module(void)13900 do_iface_module(void)
13901 {
13902   /*
13903    * processing interfaces while in a module-contained subprogram;
13904    * need to process those interfaces which are not module procedures.
13905    */
13906   int i;
13907   int iface;
13908   assert(IN_MODULE, "must be in module", 0, ERR_Fatal);
13909   if (sem.interface && !get_seen_contains()) {
13910     /* in an interface block in a module specification, if the iface is from
13911      * this module, defer until the end of the module
13912      */
13913     for (i = 0; i < iface_avail; i++) {
13914       iface = iface_base[i].iface;
13915       if ((!iface || STYPEG(iface) == ST_UNKNOWN) && !sem.which_pass)
13916         continue;
13917       _do_iface(/*1*/ sem.which_pass, i);
13918       iface_base[i].iface = 0;
13919     }
13920   } else {
13921     if (!gbl.currsub) {
13922       /* IN_MODULE_SPEC */
13923       for (i = 0; i < iface_avail; i++) {
13924         iface = iface_base[i].iface;
13925         if (!iface)
13926           continue;
13927         switch (STYPEG(iface)) {
13928         case ST_UNKNOWN:
13929         case ST_MODPROC:
13930           continue;
13931         case ST_ALIAS:
13932           if (SCOPEG(iface) == gbl.currmod)
13933             continue;
13934           break;
13935         default:;
13936         }
13937         _do_iface(/*1*/ sem.which_pass, i);
13938         iface_base[i].iface = 0;
13939       }
13940     }
13941     for (i = 0; i < iface_avail; i++) {
13942       iface = iface_base[i].iface;
13943       if (iface) {
13944         int scp;
13945         scp = SCOPEG(iface);
13946         if (scp && (scp == gbl.currsub || scp == SCOPEG(gbl.currsub)) &&
13947             !INMODULEG(iface)) {
13948           _do_iface(1, i);
13949           iface_base[i].iface = 0;
13950         } else if (sem.which_pass) {
13951           switch (STYPEG(iface)) {
13952           case ST_MODPROC:
13953           case ST_ALIAS:
13954             break;
13955           default:
13956             if (scp == gbl.currmod) {
13957               _do_iface(sem.which_pass, i);
13958               iface_base[i].iface = 0;
13959             } else if (scp != gbl.currmod && NEEDMODG(scp)) {
13960               _do_iface(sem.which_pass, i);
13961               iface_base[i].iface = 0;
13962             }
13963           }
13964         } else if (gbl.currsub && scp &&
13965                    (!INMODULEG(iface) || ABSTRACTG(iface))) {
13966           switch (STYPEG(iface)) {
13967           case ST_MODPROC:
13968           case ST_ALIAS:
13969             break;
13970           default:
13971             if (scp == ENCLFUNCG(gbl.currsub)) {
13972               _do_iface(1, i);
13973               iface_base[i].iface = 0;
13974             } else if (scp != SCOPEG(gbl.currsub)) {
13975               _do_iface(1, i);
13976               iface_base[i].iface = 0;
13977             }
13978           }
13979         }
13980       }
13981     }
13982   }
13983 }
13984 
13985 /**
13986  * Called by _do_iface() as part of error clean-up. We need to clear the
13987  * next attempt to use an erroneous interface specified in the iface argument
13988  * starting at the "i + 1" element in iface_base.
13989  */
13990 static void
clear_iface(int i,SPTR iface)13991 clear_iface(int i, SPTR iface)
13992 {
13993     int j;
13994 
13995     for (j = i + 1; j < iface_avail; j++) {
13996       if (iface_base[j].iface &&
13997           sem_strcmp(SYMNAME(iface), SYMNAME(iface_base[j].iface)) == 0) {
13998         /* inhibit the next attempt to use the same interface */
13999         iface_base[j].iface = 0;
14000       }
14001     }
14002 }
14003 
14004 static void
_do_iface(int iface_state,int i)14005 _do_iface(int iface_state, int i)
14006 {
14007   SPTR sptr, orig, fval;
14008   int dpdsc, paramct;
14009   LOGICAL pass_notfound;
14010   SPTR passed_object; /* passed-object dummy argument */
14011   int j;
14012   SPTR iface = iface_base[i].iface;
14013   SPTR ptr_scope = iface_base[i].scope;
14014   const char *name = iface_base[i].iface_name;
14015   DTYPE dtype = iface_base[i].dtype;
14016   SPTR proc = iface_base[i].proc;
14017   SPTR mem = iface_base[i].mem;
14018   int lineno = iface_base[i].lineno;
14019   LOGICAL class = iface_base[i].pass_class;
14020   const char *dt_name = iface_base[i].tag_name;
14021   SPTR proc_var = iface_base[i].proc_var;
14022   int internal = iface_base[i].internal;
14023 
14024   if (!iface) {
14025     return;
14026   }
14027 
14028   if (dtype > 0) {
14029     if (DTY(dtype) == TY_ARRAY) {
14030       dtype = DTY(dtype + 1);
14031     }
14032     if (DTY(dtype) == TY_PTR) {
14033       dtype = DTY(dtype+1);
14034     }
14035     if (DTY(dtype) != TY_PROC) {
14036       return;
14037     }
14038   }
14039 
14040   if (ptr_scope && STYPEG(ptr_scope) != ST_MODULE &&
14041       ptr_scope != stb.curr_scope &&
14042       (gbl.internal <= 1 || (gbl.internal > 1 && gbl.outersub != ptr_scope))) {
14043     /* This procedure pointer is not in scope. So, we skip it to avoid
14044      * overwriting another dtype.
14045      */
14046     return;
14047   }
14048 
14049   if (internal > 1 && gbl.internal != internal) {
14050     /* This procedure variable/pointer was declared in an internal procedure
14051      * that differs from the current procedure. So, skip it to avoid
14052      * overwriting it with another dtype.
14053      */
14054     return;
14055   }
14056 
14057   if (proc) {
14058     DTYPEP(proc, DTYPEG(iface));
14059   }
14060   if (!STYPEG(iface)) {
14061     if (sem.which_pass) {
14062       SPTR hptr;
14063       char *symname = SYMNAME(iface);
14064       int len = strlen(symname);
14065       int hash;
14066       HASH_ID(hash, symname, len);
14067       for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
14068         if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) {
14069           int scope = test_scope(hptr);
14070 
14071           if (scope && scope <= test_scope(iface)) {
14072             iface = hptr;
14073             break;
14074           }
14075         }
14076       }
14077       if (!STYPEG(iface)) {
14078         /* Check to see if we saw this iface in the first pass.
14079          * If so, do not generate an error.
14080          */
14081         int j;
14082         for (j = 0; j < iface_avail; j++) {
14083           if (iface_base[j].sem_pass == 0 &&
14084               strcmp(iface_base[j].iface_name, name) == 0 &&
14085               iface_base[j].stype == ST_PROC) {
14086             return;
14087           }
14088         }
14089         orig = iface;
14090         goto iface_err;
14091       }
14092     }
14093     if (proc <= NOSYM)
14094       return;
14095   }
14096   if (strcmp(SYMNAME(iface), name) != 0)
14097     iface = getsymbol(name);
14098   if (sem.interface <= 1) {
14099     sptr = refsym(iface, OC_OTHER);
14100   } else {
14101     sptr = refsym_inscope(iface, OC_OTHER);
14102   }
14103   if (DTY(dtype) == TY_PROC && STYPEG(DTY(dtype + 2)) == ST_MEMBER) {
14104     iface = sptr;
14105     DTY(dtype + 2) = iface;
14106   }
14107   if ((!sem.which_pass || STYPEG(sptr)) &&
14108       (STYPEG(iface) != ST_ENTRY || sptr != FVALG(iface))) {
14109     iface = sptr;
14110   }
14111   orig = iface;
14112   switch (STYPEG(iface)) {
14113   case ST_IDENT:
14114     if (RESULTG(iface)) /* Interface not seen yet */
14115       return;
14116     goto iface_err;
14117   case ST_GENERIC:
14118     iface = GSAMEG(iface);
14119   case ST_INTRIN:
14120   case ST_PD:
14121     iface = iface_intrinsic(iface);
14122     if (!iface) {
14123       goto iface_err;
14124     }
14125   /* fall thru */
14126   case ST_ENTRY:
14127   case ST_PROC:
14128     paramct = PARAMCTG(iface);
14129     dpdsc = DPDSCG(iface);
14130     break;
14131   case ST_MEMBER:
14132     if (DTY(DTYPEG(iface)) == TY_PTR) {
14133       /* Procedure pointer that's a component of a derived type. */
14134       break;
14135     }
14136     goto iface_err;
14137   default:
14138   iface_err:
14139     if (!STYPEG(iface) &&
14140         (!sem.which_pass || iface_state == 0 ||
14141         (IN_MODULE && !sem.seen_end_module))) {
14142 /* Do not generate error on semantic pass 0. May not have seen the
14143  * entire module yet. Return only if we have seen an IMPORT stmt.
14144  */
14145       return;
14146     }
14147     error(155, 3, lineno, "Illegal procedure interface -", SYMNAME(orig));
14148     clear_iface(i, orig);
14149     return;
14150   }
14151   if (ELEMENTALG(orig) && !IS_INTRINSIC(STYPEG(orig)) &&
14152       POINTERG(proc_var)) {
14153     error(1010, ERR_Severe, lineno, SYMNAME(proc_var), CNULL);
14154     clear_iface(i, orig);
14155   }
14156   passed_object = 0;
14157   pass_notfound = mem && PASSG(mem);
14158   fval = FVALG(iface);
14159   if (paramct || fval) {
14160     SPTR *dscptr;
14161     int j;
14162     if (fval)
14163       dpdsc = ++aux.dpdsc_avl;
14164     else
14165       dpdsc = aux.dpdsc_avl;
14166     NEED(aux.dpdsc_avl + paramct, aux.dpdsc_base, int, aux.dpdsc_size,
14167          aux.dpdsc_size + paramct + 100);
14168     dscptr = aux.dpdsc_base + DPDSCG(iface);
14169     if (paramct && mem && !NOPASSG(mem) && !PASSG(mem)) {
14170       passed_object = *dscptr; /* passed-object default */
14171     }
14172     for (j = 0; j < paramct; j++) {
14173       SPTR arg = *dscptr++;
14174       aux.dpdsc_base[dpdsc + j] = arg;
14175       if (pass_notfound && sem_strcmp(SYMNAME(arg), SYMNAME(PASSG(mem))) == 0) {
14176         pass_notfound = FALSE;
14177         passed_object = arg;
14178       }
14179     }
14180     if (fval) {
14181       aux.dpdsc_base[dpdsc - 1] = fval;
14182       FUNCP(mem, TRUE);
14183     }
14184     aux.dpdsc_avl += paramct;
14185   } else {
14186     dpdsc = 0;
14187   }
14188   if (proc) {
14189     DTYPEP(proc, DTYPEG(iface));
14190     PARAMCTP(proc, paramct);
14191     DPDSCP(proc, dpdsc);
14192     FVALP(proc, fval);
14193     PUREP(proc, PUREG(iface));
14194     ELEMENTALP(proc, ELEMENTALG(iface));
14195     CFUNCP(proc, CFUNCG(iface));
14196   } else {
14197     /*  dtype locates the TY_PROC data type record  */
14198     if (mem && paramct == 0 && !NOPASSG(mem)) {
14199       error(155, 3, lineno, "NOPASS attribute must be present for",
14200             SYMNAME(mem));
14201       NOPASSP(mem, TRUE);
14202       passed_object = 0;
14203     }
14204     DTY(dtype + 1) = DTYPEG(iface);
14205     DTY(dtype + 2) = iface;
14206     DTY(dtype + 3) = paramct;
14207     DTY(dtype + 4) = dpdsc;
14208     DTY(dtype + 5) = fval;
14209     if (pass_notfound) {
14210       error(155, 3, lineno, "Passed-object dummy argument not found -",
14211             SYMNAME(PASSG(mem)));
14212     }
14213     if (passed_object && iface_state) {
14214       DTYPE dt;
14215       if (dt_name) {
14216         dt = DTYPEG(getsymbol(dt_name));
14217       } else
14218         dt = DTYPEG(passed_object);
14219       if (DTY(dt) != TY_DERIVED || DTY(dt + 3) == 0) {
14220         error(155, 3, lineno,
14221               "Passed-object dummy argument must be a derived type scalar -",
14222               SYMNAME(passed_object));
14223       } else {
14224         SPTR tdf = DTY(dt + 3);
14225         if (dt != ENCLDTYPEG(mem)) {
14226           error(155, 3, lineno,
14227                 "Incompatible passed-object dummy argument for ",
14228                 SYMNAME(iface));
14229         } else if (!SEQG(tdf) && !class) {
14230           error(155, 3, lineno,
14231                 "Passed-object dummy argument is not polymorphic -",
14232                 SYMNAME(passed_object));
14233         }
14234         if (POINTERG(passed_object) || ALLOCATTRG(passed_object))
14235           error(155, 3, lineno, "Passed-object dummy argument must not be "
14236                                 "POINTER or ALLOCATABLE -",
14237                 SYMNAME(passed_object));
14238       }
14239       PASSP(mem, passed_object); /* default or specified */
14240     }
14241   }
14242 }
14243 
14244 /** \brief Sets up type parameters used in parameterized derived types (PDTs)
14245   */
14246 int
queue_type_param(int sptr,int dtype,int offset,int flag)14247 queue_type_param(int sptr, int dtype, int offset, int flag)
14248 {
14249 
14250   /* linked list of type parameters for a particular derived type */
14251   typedef struct tp {
14252     char *name;      /* name of parameter */
14253     int dtype;       /* derived type holding this type parameter */
14254     int offset;      /* parameter's position in list parm list */
14255     struct tp *next; /* next record */
14256   } TP;
14257 
14258   static TP *tp_queue = 0;
14259   TP *prev, *curr, *new_tp;
14260   char *c;
14261   int tag, parent, mem, i, j, mem2, pmem, pmem2;
14262   int prevmem, firstuse, parentuse;
14263 
14264   if (flag == 0) {
14265     /* init/clear entries */
14266     for (prev = curr = tp_queue; curr;) {
14267       FREE(curr->name);
14268       prev = curr;
14269       curr = curr->next;
14270       FREE(prev);
14271     }
14272     tp_queue = 0;
14273     return 1;
14274   } else if (flag == 1) {
14275     /* add entry */
14276     c = SYMNAME(sptr);
14277 
14278     /* step 1 - check for duplicate type parameter in this type */
14279     for (curr = tp_queue; curr; curr = curr->next) {
14280       if (curr->dtype == dtype && strcmp(curr->name, c) == 0) {
14281         error(155, 3, gbl.lineno, "Duplicate type parameter -", c);
14282         return 0;
14283       }
14284     }
14285     /* step 2 - add type parameter to queue */
14286     NEW(new_tp, TP, 1);
14287     BZERO(new_tp, TP, 1);
14288 
14289     NEW(new_tp->name, char, strlen(c) + 1);
14290     strcpy(new_tp->name, c);
14291     new_tp->dtype = dtype;
14292     new_tp->offset = offset;
14293     new_tp->next = tp_queue;
14294     tp_queue = new_tp;
14295     return 1;
14296   } else if (flag == 3) {
14297     tag = DTY(dtype + 3);
14298     parent = DTYPEG(PARENTG(tag));
14299 
14300     if (parent) {
14301       i = queue_type_param(sptr, parent, offset, 3);
14302       if (i)
14303         return i;
14304     }
14305     for (curr = tp_queue; curr; curr = curr->next) {
14306       if (curr->dtype == dtype) {
14307         c = curr->name;
14308         if (strcmp(c, SYMNAME(sptr)) == 0)
14309           return curr->offset;
14310       }
14311     }
14312     return 0;
14313   } else if (flag == 2) {
14314     /* fill in dtype into type param fields, check parent type params,
14315      * check to make sure defined params have corresponding components
14316      * in the the dtype, and reorder (if necessary) params.
14317      */
14318     int mem1, prev, prev1;
14319     for (curr = tp_queue; curr; curr = curr->next) {
14320       if (curr->dtype == 0)
14321         curr->dtype = dtype;
14322     }
14323 
14324     tag = DTY(dtype + 3);
14325     parent = DTYPEG(PARENTG(tag));
14326 
14327     if (parent) {
14328       for (curr = tp_queue; curr; curr = curr->next) {
14329         if (curr->dtype == dtype) {
14330           c = curr->name;
14331           for (mem = DTY(parent + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14332             if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), c) == 0) {
14333               error(155, 3, gbl.lineno, "Duplicate type parameter "
14334                                         "(in parent type) -",
14335                     c);
14336             }
14337           }
14338         }
14339       }
14340     }
14341 
14342     for (curr = tp_queue; curr; curr = curr->next) {
14343       if (curr->dtype == dtype) {
14344         c = curr->name;
14345         for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14346           if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), c) == 0) {
14347             KINDP(mem, curr->offset);
14348             break;
14349           }
14350         }
14351         if (mem <= NOSYM) {
14352           error(155, 3, gbl.lineno, "Missing type parameter specification -",
14353                 c);
14354         }
14355       }
14356     }
14357 
14358     /* check for extraneous kind type parameters */
14359 
14360     for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14361       if (!USEKINDG(mem) && KINDG(mem) == -1) {
14362         error(155, 3, gbl.lineno, "Kind type parameter component does not have "
14363                                   "a corresponding type parameter specifier -",
14364               SYMNAME(mem));
14365       }
14366     }
14367 
14368 /* For now, place length type parameters at the beginning of the dtype
14369  * to improve processing of them later.
14370  * Also fix up recursively typed components.
14371  */
14372 
14373     firstuse = parentuse = 0;
14374     for (prevmem = mem = DTY(dtype + 1); mem > NOSYM;) {
14375       int bt;
14376       bt = DTYPEG(mem);
14377       if ((POINTERG(mem) || ALLOCATTRG(mem)) && DTY(bt) == TY_DERIVED) {
14378         bt = DTY(bt + 3);
14379         bt = BASETYPEG(bt);
14380         if (bt && bt == ENCLDTYPEG(mem)) {
14381           /* This is a recursively typed component. We need to set
14382            * this component's type to the enclosed type since this component
14383            * was added before the enclosed type was fully defined. Otherwise,
14384            * this component's type is incomplete and may not have all of its
14385            * components. Recursively typed components must have POINTER
14386            * attribute in F2003. In F2008, they can have POINTER or
14387            * ALLOCTABLE attribute.
14388            */
14389           DTYPEP(mem, bt);
14390         }
14391       }
14392       if (PARENTG(mem)) {
14393         parentuse = mem;
14394       } else if (!firstuse && !LENPARMG(mem) && USELENG(mem)) {
14395         firstuse = mem;
14396       } else if (firstuse && LENPARMG(mem)) {
14397         SYMLKP(prevmem, SYMLKG(mem));
14398         if (!parentuse) {
14399           SYMLKP(mem, DTY(dtype + 1));
14400           DTY(dtype + 1) = mem;
14401         } else {
14402           SYMLKP(mem, SYMLKG(parentuse));
14403           SYMLKP(parentuse, mem);
14404         }
14405         mem = SYMLKG(prevmem);
14406         continue;
14407       }
14408       prevmem = mem;
14409       mem = SYMLKG(mem);
14410     }
14411 
14412     /* ditto with kind type parameters */
14413 
14414     firstuse = parentuse = 0;
14415     for (prevmem = mem = DTY(dtype + 1); mem > NOSYM;) {
14416       if (PARENTG(mem)) {
14417         parentuse = mem;
14418       } else if (!firstuse && !LENPARMG(mem) && USEKINDG(mem) &&
14419                  A_TYPEG(KINDASTG(mem)) != A_CNST &&
14420                  A_TYPEG(KINDASTG(mem)) != A_ID) {
14421         firstuse = mem;
14422       } else if (firstuse && KINDG(mem) && !USEKINDG(mem) && !KINDASTG(mem)) {
14423         SYMLKP(prevmem, SYMLKG(mem));
14424         if (!parentuse) {
14425           SYMLKP(mem, DTY(dtype + 1));
14426           DTY(dtype + 1) = mem;
14427         } else {
14428           SYMLKP(mem, SYMLKG(parentuse));
14429           SYMLKP(parentuse, mem);
14430         }
14431         mem = SYMLKG(prevmem);
14432         continue;
14433       }
14434       prevmem = mem;
14435       mem = SYMLKG(mem);
14436     }
14437 
14438     return 1;
14439   }
14440 
14441   return 0;
14442 }
14443 
14444 static void
search_kind(int ast,int * offset)14445 search_kind(int ast, int *offset)
14446 {
14447 
14448   int sptr, rslt;
14449 
14450   if (!offset || *offset)
14451     return;
14452   if (A_TYPEG(ast) == A_ID) {
14453     sptr = A_SPTRG(ast);
14454     if (sptr) {
14455       rslt = queue_type_param(sptr, 0, 0, 3);
14456       if (!rslt && sem.stsk_depth && stsk == &STSK_ENT(0)) {
14457         rslt = get_kind_parm(sptr, stsk->dtype);
14458       }
14459       if (rslt) {
14460         *offset = rslt;
14461         return;
14462       }
14463     }
14464   }
14465 }
14466 
14467 static int
chk_kind_parm(SST * stkp)14468 chk_kind_parm(SST *stkp)
14469 {
14470   int offset;
14471   int sptr;
14472   int ast;
14473 
14474   sptr = 0;
14475   switch (SST_IDG(stkp)) {
14476   case S_IDENT:
14477     sptr = SST_SYMG(stkp);
14478     break;
14479   case S_LVALUE:
14480     sptr = SST_LSYMG(stkp);
14481     break;
14482   case S_EXPR:
14483     ast = SST_ASTG(stkp);
14484     offset = 0;
14485     ast_visit(1, 1);
14486     ast_traverse(ast, NULL, search_kind, &offset);
14487     ast_unvisit();
14488     return offset;
14489   }
14490   if (!sptr)
14491     return 0;
14492   /* Check to see if this is a kind type parameter */
14493   offset = queue_type_param(sptr, 0, 0, 3);
14494   if (!offset && INSIDE_STRUCT && stsk == &STSK_ENT(0) && stsk->type == 'd') {
14495     offset = get_kind_parm(sptr, stsk->dtype);
14496   }
14497   if (offset)
14498     IGNOREP(sptr, TRUE); /* needed for "implicit none" */
14499   return offset;
14500 }
14501 
14502 static int
get_kind_parm(int sptr,int dtype)14503 get_kind_parm(int sptr, int dtype)
14504 {
14505   int rslt, tag, parent, mem;
14506 
14507   if (DTY(dtype) != TY_DERIVED)
14508     return 0;
14509 
14510   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14511     if (PARENTG(mem)) {
14512       rslt = get_kind_parm(sptr, DTYPEG(mem));
14513       if (rslt)
14514         return rslt;
14515     }
14516     if (!USEKINDG(mem) && KINDG(mem) &&
14517         strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0)
14518       return KINDG(mem);
14519   }
14520 
14521   return 0;
14522 }
14523 
14524 static int
get_kind_parm_strict(int sptr,int dtype)14525 get_kind_parm_strict(int sptr, int dtype)
14526 {
14527   int rslt, tag, parent, mem;
14528 
14529   if (DTY(dtype) != TY_DERIVED)
14530     return 0;
14531 
14532   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14533     if (PARENTG(mem)) {
14534       rslt = get_kind_parm(sptr, DTYPEG(mem));
14535       if (rslt)
14536         return rslt;
14537     }
14538     if (!USEKINDG(mem) && !LENPARMG(mem) && KINDG(mem) &&
14539         strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) {
14540       return KINDG(mem);
14541     }
14542   }
14543 
14544   return 0;
14545 }
14546 
14547 /** \brief search a derived type for a kind type parameter with a specified
14548   *        name.
14549   *
14550   * \param np is the name we're search for
14551   * \param dtype is the derived type record that we are searching
14552   *
14553   * \return integer > 0 for the parameter number, else 0 if not found.
14554   */
14555 int
get_kind_parm_by_name(char * np,int dtype)14556 get_kind_parm_by_name(char *np, int dtype)
14557 {
14558   int rslt, mem;
14559 
14560   if (DTY(dtype) != TY_DERIVED)
14561     return 0;
14562 
14563   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14564     if (PARENTG(mem)) {
14565       rslt = get_kind_parm_by_name(np, DTYPEG(mem));
14566       if (rslt)
14567         return rslt;
14568     }
14569     if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), np) == 0)
14570       return KINDG(mem);
14571   }
14572 
14573   return 0;
14574 }
14575 
14576 /** \brief search derived type for a type parameter in the same position as
14577   *        specified by offset.
14578   *
14579   * \param offset is the desired parameter position
14580   * \param dtype is the derived type record to search in
14581   *
14582   * \return symbol table pointer of the parameter component in the derived
14583   *         type; else 0 if not found.
14584   */
14585 int
get_parm_by_number(int offset,int dtype)14586 get_parm_by_number(int offset, int dtype)
14587 {
14588   int rslt, mem;
14589 
14590   if (DTY(dtype) != TY_DERIVED)
14591     return 0;
14592 
14593   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14594     if (PARENTG(mem)) {
14595       rslt = get_parm_by_number(offset, DTYPEG(mem));
14596       if (rslt)
14597         return rslt;
14598     }
14599     if (!USEKINDG(mem) && KINDG(mem) == offset)
14600       return mem;
14601   }
14602   return 0;
14603 }
14604 
14605 /** \brief search a derived type for a kind or length type parameter with a
14606   *        specified name.
14607   *
14608   * \param np is the name we're search for
14609   * \param dtype is the derived type record that we are searching
14610   *
14611   * \return integer > 0 for the parameter number, else 0 if not found.
14612   */
14613 int
get_parm_by_name(char * np,int dtype)14614 get_parm_by_name(char *np, int dtype)
14615 {
14616   int rslt, mem;
14617 
14618   if (DTY(dtype) != TY_DERIVED)
14619     return 0;
14620 
14621   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14622     if (PARENTG(mem)) {
14623       rslt = get_parm_by_name(np, DTYPEG(mem));
14624       if (rslt)
14625         return rslt;
14626     }
14627     if (!USEKINDG(mem) && KINDG(mem) && strcmp(np, SYMNAME(mem)) == 0)
14628       return mem;
14629   }
14630   return 0;
14631 }
14632 
14633 /** Should be called when we parse ENDTYPE. This function goes
14634   * through a derived type's members and makes sure there are
14635   * no length type parameters in the initialization part of a
14636   * member.
14637   */
14638 static void
chk_initialization_with_kind_parm(int dtype)14639 chk_initialization_with_kind_parm(int dtype)
14640 {
14641   int mem;
14642 
14643   if (DTY(dtype) == TY_ARRAY)
14644     dtype = DTY(dtype + 1);
14645 
14646   if (DTY(dtype) != TY_DERIVED)
14647     return;
14648 
14649   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14650     if (PARENTG(mem)) {
14651       chk_initialization_with_kind_parm(DTYPEG(mem));
14652     }
14653     if (INITKINDG(mem) && PARMINITG(mem) &&
14654         !chk_kind_parm_expr(PARMINITG(mem), dtype, 0, 1)) {
14655       error(155, 3, gbl.lineno, "Initialization must be a constant"
14656                                 " expression for component",
14657             SYMNAME(mem));
14658     }
14659   }
14660 }
14661 
14662 int
chk_kind_parm_expr(int ast,int dtype,int flag,int strict_flag)14663 chk_kind_parm_expr(int ast, int dtype, int flag, int strict_flag)
14664 {
14665   int sptr, offset, rslt, i;
14666 
14667   if (!ast)
14668     return 0;
14669 
14670   switch (A_TYPEG(ast)) {
14671   case A_INTR:
14672     switch (A_OPTYPEG(ast)) {
14673     case I_INT1:
14674     case I_INT2:
14675     case I_INT4:
14676     case I_INT8:
14677     case I_INT:
14678       i = A_ARGSG(ast);
14679       return chk_kind_parm_expr(ARGT_ARG(i, 0), dtype, flag, strict_flag);
14680     }
14681     break;
14682   case A_CONV:
14683     return chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag);
14684   case A_CNST:
14685     return 1;
14686   case A_ID:
14687     sptr = A_SPTRG(ast);
14688     offset = (!strict_flag) ? get_kind_parm(sptr, dtype)
14689                             : get_kind_parm_strict(sptr, dtype);
14690     if (flag && !offset && (!strict_flag || !get_kind_parm(sptr, dtype))) {
14691       /* we might be in the middle of a derived type definition, so see if
14692        * there's a match in the type parameter queue.
14693        */
14694       offset = queue_type_param(sptr, 0, 0, 3);
14695     }
14696     if (!offset)
14697       return 0;
14698     IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */
14699     KINDP(sptr, offset);
14700     return offset;
14701   case A_UNOP:
14702     return chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag);
14703   case A_BINOP:
14704     rslt = chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag);
14705     if (!rslt)
14706       return 0;
14707     rslt = chk_kind_parm_expr(A_ROPG(ast), dtype, flag, strict_flag);
14708     if (!rslt)
14709       return 0;
14710     return rslt;
14711   }
14712 
14713   return 0;
14714 }
14715 
14716 static int
has_kind_parm_expr(int ast,int dtype,int flag)14717 has_kind_parm_expr(int ast, int dtype, int flag)
14718 {
14719 
14720   int sptr, offset, rslt, i;
14721 
14722   if (!ast)
14723     return 0;
14724 
14725   switch (A_TYPEG(ast)) {
14726   case A_INTR:
14727     switch (A_OPTYPEG(ast)) {
14728     case I_INT1:
14729     case I_INT2:
14730     case I_INT4:
14731     case I_INT8:
14732     case I_INT:
14733       i = A_ARGSG(ast);
14734       return has_kind_parm_expr(ARGT_ARG(i, 0), dtype, flag);
14735     }
14736     break;
14737   case A_CONV:
14738     return has_kind_parm_expr(A_LOPG(ast), dtype, flag);
14739   case A_CNST:
14740     return 0;
14741   case A_ID:
14742     sptr = A_SPTRG(ast);
14743     offset = get_kind_parm_strict(sptr, dtype);
14744     if (flag && !offset) {
14745       /* we might be in the middle of a derived type definition, so see if
14746        * there's a match in the type parameter queue.
14747        */
14748       offset = queue_type_param(sptr, 0, 0, 3);
14749     }
14750     if (!offset)
14751       return 0;
14752     IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */
14753     KINDP(sptr, offset);
14754     return offset;
14755   case A_UNOP:
14756     return has_kind_parm_expr(A_LOPG(ast), dtype, flag);
14757   case A_BINOP:
14758     rslt = has_kind_parm_expr(A_LOPG(ast), dtype, flag);
14759     if (rslt)
14760       return rslt;
14761     rslt = has_kind_parm_expr(A_ROPG(ast), dtype, flag);
14762     return rslt;
14763   }
14764 
14765   return 0;
14766 }
14767 
14768 static int
chk_asz_deferlen(int ast,int dtype)14769 chk_asz_deferlen(int ast, int dtype)
14770 {
14771 
14772   int sptr, mem, rslt;
14773 
14774   if (!ast)
14775     return 0;
14776 
14777   switch (A_TYPEG(ast)) {
14778   case A_ID:
14779     sptr = A_SPTRG(ast);
14780     rslt = 0;
14781     for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14782       if (PARENTG(mem)) {
14783         rslt = chk_asz_deferlen(ast, DTYPEG(mem));
14784         if (rslt < 0)
14785           return rslt;
14786         continue;
14787       }
14788       if (strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) {
14789         rslt = sptr = mem;
14790         break;
14791       }
14792     }
14793     if (rslt) {
14794       if (DEFERLENG(sptr))
14795         return -1;
14796       else if (ASZG(sptr))
14797         return -2;
14798     }
14799     break;
14800   case A_BINOP:
14801     rslt = chk_asz_deferlen(A_LOPG(ast), dtype);
14802     if (rslt != 0) {
14803       return rslt;
14804     }
14805     rslt = chk_asz_deferlen(A_ROPG(ast), dtype);
14806     if (rslt != 0) {
14807       return rslt;
14808     }
14809   }
14810   return 0;
14811 }
14812 
14813 static int
get_len_parm(int sptr,int dtype)14814 get_len_parm(int sptr, int dtype)
14815 {
14816   int rslt, tag, parent, mem;
14817 
14818   if (DTY(dtype) != TY_DERIVED)
14819     return 0;
14820 
14821   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14822     if (PARENTG(mem)) {
14823       rslt = get_len_parm(sptr, DTYPEG(mem));
14824       if (rslt)
14825         return rslt;
14826     }
14827     if (LENPARMG(mem) && !USEKINDG(mem) && KINDG(mem) &&
14828         strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0)
14829       return KINDG(mem);
14830   }
14831 
14832   return 0;
14833 }
14834 
14835 int
chk_len_parm_expr(int ast,int dtype,int flag)14836 chk_len_parm_expr(int ast, int dtype, int flag)
14837 {
14838   int sptr, offset, rslt;
14839 
14840   if (!ast)
14841     return 0;
14842 
14843   switch (A_TYPEG(ast)) {
14844 
14845   case A_CNST:
14846     return 1;
14847   case A_ID:
14848     sptr = A_SPTRG(ast);
14849     offset = get_len_parm(sptr, dtype);
14850     if (flag && !offset) {
14851       /* we might be in the middle of a derived type definition, so see if
14852        * there's a match in the type parameter queue.
14853        */
14854       offset = queue_type_param(sptr, 0, 0, 3);
14855     }
14856     if (offset) {
14857       IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */
14858       if (ST_ISVAR(STYPEG(sptr)) || STYPEG(sptr) == ST_IDENT) {
14859         /* This symbol is a len parameter place holder. */
14860         LENPHP(sptr, 1);
14861       }
14862     }
14863     return offset;
14864   case A_UNOP:
14865     return chk_len_parm_expr(A_LOPG(ast), dtype, flag);
14866   case A_BINOP:
14867     rslt = chk_len_parm_expr(A_LOPG(ast), dtype, flag);
14868     if (!rslt)
14869       return 0;
14870     rslt = chk_len_parm_expr(A_ROPG(ast), dtype, flag);
14871     if (!rslt)
14872       return 0;
14873     return rslt;
14874   }
14875 
14876   return 0;
14877 }
14878 
14879 static int
fix_kind_parm_expr(int ast,int dtype,int offset,int value)14880 fix_kind_parm_expr(int ast, int dtype, int offset, int value)
14881 {
14882   int sptr, rslt, newast, i;
14883 
14884   switch (A_TYPEG(ast)) {
14885 
14886   case A_CNST:
14887     break;
14888   case A_ID:
14889     sptr = A_SPTRG(ast);
14890     if (KINDG(sptr) == offset) {
14891       ast = mk_cval1(value, DT_INT);
14892     }
14893     break;
14894   case A_UNOP:
14895     newast = fix_kind_parm_expr(A_LOPG(ast), dtype, offset, value);
14896     A_LOPP(ast, newast);
14897     break;
14898   case A_BINOP:
14899     newast = fix_kind_parm_expr(A_LOPG(ast), dtype, offset, value);
14900     A_LOPP(ast, newast);
14901     newast = fix_kind_parm_expr(A_ROPG(ast), dtype, offset, value);
14902     A_ROPP(ast, newast);
14903     break;
14904   }
14905 
14906   return ast;
14907 }
14908 
14909 int
get_len_set_parm_by_name(char * np,int dtype,int * val)14910 get_len_set_parm_by_name(char *np, int dtype, int *val)
14911 {
14912   int rslt, tag, parent, mem;
14913 
14914   if (DTY(dtype) != TY_DERIVED)
14915     return 0;
14916 
14917   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14918     if (PARENTG(mem)) {
14919       rslt = get_len_set_parm_by_name(np, DTYPEG(mem), val);
14920       if (rslt)
14921         return rslt;
14922     }
14923     if (LENPARMG(mem) && SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) &&
14924         strcmp(SYMNAME(mem), np) == 0) {
14925       *val = LENG(mem);
14926       return KINDG(mem);
14927     }
14928   }
14929 
14930   return 0;
14931 }
14932 
14933 int
cmp_len_parms(int ast1,int ast2)14934 cmp_len_parms(int ast1, int ast2)
14935 {
14936 
14937   int sptr1, sptr2;
14938   int rslt;
14939 
14940   if (A_TYPEG(ast1) != A_TYPEG(ast2))
14941     return 0;
14942 
14943   switch (A_TYPEG(ast1)) {
14944 
14945   case A_CNST:
14946     if (CONVAL2G(A_SPTRG(ast1)) == CONVAL2G(A_SPTRG(ast2)))
14947       return 1;
14948     return 0;
14949   case A_ID:
14950     sptr1 = A_SPTRG(ast1);
14951     sptr2 = A_SPTRG(ast2);
14952     return sptr1 == sptr2;
14953   case A_UNOP:
14954     if (A_OPTYPEG(ast1) != A_OPTYPEG(ast2))
14955       return 0;
14956     return cmp_len_parms(A_LOPG(ast1), A_LOPG(ast2));
14957   case A_BINOP:
14958     if (A_OPTYPEG(ast1) != A_OPTYPEG(ast2))
14959       return 0;
14960     rslt = cmp_len_parms(A_LOPG(ast1), A_LOPG(ast2));
14961     if (!rslt)
14962       return 0;
14963     rslt = cmp_len_parms(A_ROPG(ast1), A_ROPG(ast2));
14964     if (!rslt)
14965       return 0;
14966     return 1;
14967   }
14968 
14969   return 0;
14970 }
14971 
14972 /** \brief Store dtypes of parameterized derived types in which a parameter was
14973            explicitly declared (as opposed to using just the default values).
14974  */
14975 int
defer_pt_decl(int dtype,int flag)14976 defer_pt_decl(int dtype, int flag)
14977 {
14978   typedef struct ptList {
14979     int dtype;
14980     struct ptList *next;
14981   } PL;
14982 
14983   static PL *pl = NULL;
14984   PL *curr, *newpl, *prev;
14985   int rslt;
14986 
14987   rslt = 0;
14988   if (flag == 0 && !sem.interface && sem.which_pass) {
14989     /* delete all entries from list */
14990     for (curr = pl; curr;) {
14991       prev = curr;
14992       curr = curr->next;
14993       FREE(prev);
14994       rslt = 1;
14995     }
14996     pl = NULL;
14997   } else if (flag == 1 && !sem.which_pass) {
14998     /* add entry */
14999     NEW(newpl, PL, 1);
15000     newpl->dtype = dtype;
15001     newpl->next = pl;
15002     pl = newpl;
15003     rslt = 1;
15004   } else if (flag == 2 && sem.which_pass) {
15005     /* is this list non-empty? */
15006     rslt = (pl != NULL);
15007   }
15008 
15009   return rslt;
15010 }
15011 
15012 static void
defer_put_kind_type_param(int offset,int value,char * name,int dtype,int ast,int flag)15013 defer_put_kind_type_param(int offset, int value, char *name, int dtype, int ast,
15014                           int flag)
15015 {
15016   typedef struct parmList {
15017     int offset;
15018     int value;
15019     char *name;
15020     int ast;
15021     int is_defer_len;
15022     int is_assume_sz;
15023     struct parmList *next;
15024   } PL;
15025 
15026   static PL *pl = NULL;
15027   PL *curr, *newpl, *prev;
15028   int i;
15029   int rslt;
15030   int flag2;
15031 
15032   rslt = 0;
15033   if (flag == 0) {
15034     /* delete all entries from list */
15035     for (curr = pl; curr;) {
15036       prev = curr;
15037       curr = curr->next;
15038       FREE(prev);
15039       rslt = 1;
15040     }
15041     pl = NULL;
15042   } else if (flag == 1) {
15043     /* add entry */
15044     NEW(newpl, PL, 1);
15045     newpl->offset = offset;
15046     newpl->value = value;
15047     newpl->name = name;
15048     newpl->ast = ast;
15049     newpl->is_defer_len = sem.param_defer_len;
15050     newpl->is_assume_sz = sem.param_assume_sz;
15051     newpl->next = pl;
15052     pl = newpl;
15053     rslt = 1;
15054   } else if (flag == 2) {
15055     /* process type params */
15056     if (DTY(dtype) != TY_DERIVED) {
15057       return;
15058     }
15059     for (curr = pl; curr; curr = curr->next) {
15060       rslt = 1;
15061       if (sem.new_param_dt == 0) {
15062         sem.new_param_dt = create_parameterized_dt(dtype, 0);
15063       }
15064       if (curr->is_defer_len) {
15065         flag2 = -1;
15066       } else if (curr->is_assume_sz) {
15067         flag2 = -2;
15068       } else
15069         flag2 = 0;
15070       if (!curr->name) {
15071         i = put_kind_type_param(sem.new_param_dt, curr->offset, curr->value,
15072                                 curr->ast, flag2);
15073         if (!i) {
15074           error(155, 3, gbl.lineno, "Too many type parameter specifiers", NULL);
15075         }
15076       } else {
15077         i = get_kind_parm_by_name(curr->name, sem.new_param_dt);
15078         if (i) {
15079           put_kind_type_param(sem.new_param_dt, i, curr->value, curr->ast,
15080                               flag2);
15081         } else {
15082           error(155, 3, gbl.lineno, "Undefined type parameter", curr->name);
15083         }
15084       }
15085     }
15086     check_kind_type_param(sem.new_param_dt);
15087   }
15088 }
15089 
15090 void
put_default_kind_type_param(int dtype,int flag,int flag2)15091 put_default_kind_type_param(int dtype, int flag, int flag2)
15092 {
15093 
15094   typedef struct dtyList {
15095     int dtype;
15096     struct dtyList *next;
15097   } DL;
15098 
15099   static DL *dl = NULL;
15100   DL *curr, *newdl, *prev;
15101 
15102   int mem_dtype, offset, val, mem;
15103 
15104   if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype))
15105     return;
15106   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15107     mem_dtype = DTYPEG(mem);
15108     if (PARENTG(mem)) {
15109       NEW(newdl, DL, 1);
15110       BZERO(newdl, DL, 1);
15111       newdl->dtype = dtype;
15112       newdl->next = dl;
15113       dl = newdl;
15114       put_default_kind_type_param(mem_dtype, 1, flag2);
15115     } else if (!SETKINDG(mem) && !USEKINDG(mem) && (offset = KINDG(mem)) &&
15116                (val = PARMINITG(mem))) {
15117       put_kind_type_param(dtype, offset, val, 0, flag2);
15118       for (curr = dl; curr; curr = curr->next) {
15119         put_kind_type_param(curr->dtype, offset, val, 0, flag2);
15120       }
15121     }
15122   }
15123   if (!flag) {
15124     for (curr = dl; curr;) {
15125       prev = curr;
15126       curr = curr->next;
15127       FREE(prev);
15128     }
15129     dl = NULL;
15130   }
15131   chkstruct(dtype);
15132 }
15133 
15134 void
put_length_type_param(DTYPE dtype,int flag)15135 put_length_type_param(DTYPE dtype, int flag)
15136 {
15137 
15138   typedef struct dtyList {
15139     DTYPE dtype;
15140     struct dtyList *next;
15141   } DL;
15142 
15143   typedef struct char_info {
15144     DTYPE dtype;
15145     int situation;
15146     int ast;
15147     struct char_info *next;
15148   } CL;
15149 
15150   static DL *dl = NULL;
15151   DL *curr, *newdl, *prev;
15152 
15153   static CL *cl = NULL;
15154   CL *ccl, *newcl, *pcl;
15155 
15156   int mem;
15157 
15158   if (flag == 2) {
15159     for (pcl = ccl = cl; ccl;) {
15160       ccl = ccl->next;
15161       FREE(pcl);
15162       pcl = ccl;
15163     }
15164     cl = NULL;
15165     return;
15166   }
15167 
15168   if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype))
15169     return;
15170 
15171   if (!sem.new_param_dt) {
15172     dtype = sem.new_param_dt = create_parameterized_dt(dtype, 0);
15173   }
15174 
15175   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15176     DTYPE mem_dtype = DTYPEG(mem);
15177     if (PTRVG(mem) || DESCARRAYG(mem)) {
15178       continue;
15179     }
15180     if (PARENTG(mem)) {
15181       NEW(newdl, DL, 1);
15182       BZERO(newdl, DL, 1);
15183       newdl->dtype = dtype;
15184       newdl->next = dl;
15185       dl = newdl;
15186       put_length_type_param(mem_dtype, flag + 1);
15187     }
15188 
15189     if (DTY(mem_dtype) == TY_CHAR || DTY(mem_dtype) == TY_NCHAR)
15190     {
15191       int ast = DTY(mem_dtype + 1);
15192       if (flag >= 3)
15193         continue;
15194       for (ccl = cl; ccl; ccl = ccl->next) {
15195         if (ccl->dtype == mem_dtype && ccl->situation) {
15196           goto do_assume_sz;
15197         }
15198       }
15199       if (A_TYPEG(ast) != A_CNST) {
15200         int i = chk_kind_parm_set_expr(ast, dtype);
15201         if (i > 0) {
15202           if (A_TYPEG(i) == A_CNST) {
15203             int con = CONVAL2G(A_SPTRG(i));
15204             if (con < 0) {
15205               i = chk_asz_deferlen(ast, dtype);
15206               if (i == -1 || i == -2) {
15207                 i = sym_get_scalar(SYMNAME(mem), "len", DT_INT);
15208                 DTY(mem_dtype + 1) = mk_id(i);
15209               do_assume_sz:
15210                 LENP(mem, ast);
15211                 NEW(newcl, CL, 1);
15212                 newcl->dtype = mem_dtype;
15213                 newcl->situation = 2;
15214                 newcl->ast = LENG(mem);
15215                 newcl->next = cl;
15216                 cl = newcl;
15217                 ALLOCATTRP(mem, 1);
15218                 TPALLOCP(mem, 1);
15219                 goto shared_alloc_char;
15220               } else {
15221                 interr("put_length_type_param: unexpected len type param", 0,
15222                        3);
15223                 LENP(mem, astb.i0);
15224                 DTY(mem_dtype + 1) = astb.i0;
15225               }
15226 
15227             } else {
15228               DTY(mem_dtype + 1) = i;
15229             }
15230           } else if (A_TYPEG(i) != A_CNST) {
15231             DTY(mem_dtype + 1) = i;
15232             LENP(mem, i);
15233 
15234           shared_alloc_char:
15235             if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem))
15236               TPALLOCP(mem, 1);
15237             ALLOCP(mem, TRUE);
15238             USELENP(mem, TRUE);
15239 
15240             DTYPEP(mem,
15241                    (DTY(mem_dtype) == TY_CHAR) ? DT_DEFERCHAR : DT_DEFERNCHAR);
15242             if (SDSCG(mem) || STYPEG(SDSCG(mem)) != ST_MEMBER) {
15243               ENCLDTYPEP(mem, dtype);
15244               SDSCP(mem, sym_get_sdescr(mem, 0));
15245               get_all_descriptors(mem);
15246             }
15247             ALLOCDESCP(mem, TRUE);
15248           } else
15249             DTY(mem_dtype + 1) = i;
15250         }
15251       }
15252     }
15253 
15254     if (DTY(mem_dtype) == TY_ARRAY && !DESCARRAYG(mem)) {
15255       int numdim, i, num_ast;
15256       ADSC *ad;
15257 
15258       mem_dtype = dup_array_dtype(mem_dtype);
15259       DTYPEP(mem, mem_dtype);
15260 
15261       ad = AD_DPTR(mem_dtype);
15262       numdim = AD_NUMDIM(ad);
15263       num_ast = 0;
15264 
15265       for (i = 0; i < numdim; i++) {
15266         int lb, ub, bndast, con;
15267 
15268         if (SDSCG(mem) != 0) {
15269           /* replace the descriptor in the bounds expressions with the
15270              descriptor created for mem in get_parameterized_dt() */
15271           replace_sdsc_in_bounds(SDSCG(mem), ad, i);
15272         }
15273 
15274         lb = bndast = AD_LWAST(ad, i);
15275         if (bndast != 0 && A_ALIASG(bndast) == 0) {
15276           int ast = chk_kind_parm_set_expr(bndast, dtype);
15277           if (ast > 0) {
15278             lb = AD_LWAST(ad, i) = ast;
15279             if (A_TYPEG(ast) != A_CNST) {
15280               if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem))
15281                 TPALLOCP(mem, TRUE);
15282               ALLOCP(mem, TRUE);
15283               USELENP(mem, TRUE);
15284               ADJARRP(mem, TRUE);
15285               if (!SDSCG(mem)) {
15286                 ENCLDTYPEP(mem, dtype);
15287                 get_static_descriptor(mem);
15288                 get_all_descriptors(mem);
15289               }
15290             }
15291           }
15292         }
15293 
15294         ub = bndast = AD_UPAST(ad, i);
15295         con = USEDEFERG(mem) && A_TYPEG(ub) == A_BINOP
15296                   ? 0
15297                   : chk_asz_deferlen(bndast, dtype);
15298         if (con == -1) {
15299           USEDEFERP(mem, TRUE);
15300           if (A_TYPEG(ub) == A_BINOP && flag < 3) {
15301             continue;
15302           }
15303         }
15304         if (!USEDEFERG(mem) && A_TYPEG(ub) == A_BINOP) {
15305           ub = mk_stmt(A_BINOP, 0);
15306           A_OPTYPEP(ub, A_OPTYPEG(bndast));
15307           A_LOPP(ub, A_LOPG(bndast));
15308           A_ROPP(ub, A_ROPG(bndast));
15309           A_DTYPEP(ub, A_DTYPEG(bndast));
15310           bndast = AD_UPAST(ad, i) = ub;
15311         }
15312         if (bndast != 0 && A_ALIASG(bndast) == 0) {
15313           int ast = chk_kind_parm_set_expr(bndast, dtype);
15314           if (ast <= 0 || A_TYPEG(ast) == A_CNST) {
15315             int con2 = ast <= 0 ? ast : CONVAL2G(A_SPTRG(ast));
15316             if (con2 <= 0 && (con == -1 || con == -2))
15317               ast = bndast;
15318           }
15319 
15320           if (ast > 0) {
15321             ub = AD_UPAST(ad, i) = ast;
15322             if (USELENG(mem)) {
15323               if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem))
15324                 TPALLOCP(mem, TRUE);
15325               ALLOCP(mem, TRUE);
15326               USELENP(mem, TRUE);
15327               ADJARRP(mem, TRUE);
15328               if (!SDSCG(mem) || STYPEG(SDSCG(mem)) != ST_MEMBER) {
15329                 ENCLDTYPEP(mem, dtype);
15330                 get_static_descriptor(mem);
15331                 get_all_descriptors(mem);
15332               }
15333 
15334               if (USEDEFERG(mem)) {
15335                 int mem2, mem3;
15336                 int mem1 = SYMLKG(mem);
15337                 int sdsc_mem = mem1;
15338                 if (sdsc_mem == MIDNUMG(mem) || PTRVG(sdsc_mem)) {
15339                   sdsc_mem = mem2 = SYMLKG(sdsc_mem);
15340                 }
15341                 if (PTRVG(sdsc_mem) || !DESCARRAYG(sdsc_mem)) {
15342                   sdsc_mem = mem3 = SYMLKG(sdsc_mem);
15343                 }
15344 
15345                 if (DESCARRAYG(sdsc_mem)) {
15346                   if (mem1 > NOSYM)
15347                     USEDEFERP(mem1, TRUE);
15348                   if (mem2 > NOSYM)
15349                     USEDEFERP(mem2, TRUE);
15350                   if (mem3 > NOSYM)
15351                     USEDEFERP(mem3, TRUE);
15352                 }
15353               }
15354             }
15355           }
15356         }
15357         AD_LWAST(ad, i) = mk_bnd_int(lb);
15358         AD_UPAST(ad, i) = mk_bnd_int(ub);
15359         bndast =
15360             mk_binop(OP_SUB, AD_UPAST(ad, i), AD_LWAST(ad, i), astb.bnd.dtype);
15361         bndast = mk_binop(OP_ADD, bndast, mk_isz_cval(1, astb.bnd.dtype),
15362                           astb.bnd.dtype);
15363 
15364         if (!SDSCG(mem)) {
15365           AD_EXTNTAST(ad, i) = bndast;
15366         } else {
15367           AD_EXTNTAST(ad, i) = get_extent(SDSCG(mem), i);
15368           AD_MLPYR(ad, i) = get_local_multiplier(SDSCG(mem), i);
15369         }
15370 
15371         if (!num_ast) {
15372           num_ast = bndast;
15373         } else {
15374           num_ast = mk_binop(OP_MUL, num_ast, bndast, astb.bnd.dtype);
15375         }
15376       }
15377       if (num_ast) {
15378         ADD_NUMELM(mem_dtype) = num_ast;
15379       }
15380     }
15381   }
15382   if (flag > 0) {
15383     for (curr = dl; curr;) {
15384       prev = curr;
15385       curr = curr->next;
15386       FREE(prev);
15387     }
15388     dl = NULL;
15389   }
15390   chkstruct(dtype);
15391 }
15392 
15393 /* Replace sdsc in the ASTs for each bound */
15394 static void
replace_sdsc_in_bounds(int sdsc,ADSC * ad,int i)15395 replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i)
15396 {
15397   int ast = replace_sdsc_in_ast(sdsc, AD_LWAST(ad, i));
15398   if (ast != 0) {
15399     AD_LWAST(ad, i) = ast;
15400   }
15401   ast = replace_sdsc_in_ast(sdsc, AD_LWBD(ad, i));
15402   if (ast != 0) {
15403     AD_LWBD(ad, i) = ast;
15404   }
15405   ast = replace_sdsc_in_ast(sdsc, AD_UPAST(ad, i));
15406   if (ast != 0) {
15407     AD_UPAST(ad, i) = ast;
15408   }
15409   ast = replace_sdsc_in_ast(sdsc, AD_UPBD(ad, i));
15410   if (ast != 0) {
15411     AD_UPBD(ad, i) = ast;
15412   }
15413 }
15414 
15415 /* If there is an ID node in the ast tree that matches the name of this
15416    descriptor,
15417    replace it with the sdsc symbol.  Return 0 if unchanged.
15418  */
15419 static int
replace_sdsc_in_ast(int sdsc,int ast)15420 replace_sdsc_in_ast(int sdsc, int ast)
15421 {
15422   int lop, rop, sptr;
15423   switch (A_TYPEG(ast)) {
15424   case A_ID:
15425     sptr = A_SPTRG(ast);
15426     if (DESCARRAYG(sptr) && sdsc != sptr &&
15427         strcmp(SYMNAME(sdsc), SYMNAME(sptr)) == 0) {
15428       return mk_id(sdsc);
15429     }
15430     break;
15431   case A_BINOP:
15432     lop = replace_sdsc_in_ast(sdsc, A_LOPG(ast));
15433     rop = replace_sdsc_in_ast(sdsc, A_ROPG(ast));
15434     if (lop != 0 || rop != 0) {
15435       return mk_binop(A_OPTYPEG(ast), lop != 0 ? lop : A_LOPG(ast),
15436                       rop != 0 ? rop : A_ROPG(ast), A_DTYPEG(ast));
15437     }
15438     break;
15439   case A_SUBSCR:
15440     lop = replace_sdsc_in_ast(sdsc, A_LOPG(ast));
15441     if (lop != 0) {
15442       return mk_subscr_copy(lop, A_ASDG(ast), A_DTYPEG(ast));
15443     }
15444     break;
15445   }
15446   return 0;
15447 }
15448 
15449 int
get_len_parm_by_number(int num,int dtype,int flag)15450 get_len_parm_by_number(int num, int dtype, int flag)
15451 {
15452   int mem, i;
15453 
15454   if (DTY(dtype) != TY_DERIVED)
15455     return 0;
15456 
15457   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15458     if (PARENTG(mem)) {
15459       i = get_len_parm_by_number(num, DTYPEG(PARENTG(mem)), flag);
15460       if (i)
15461         return i;
15462     }
15463     if (LENPARMG(mem) == num) {
15464       if (!flag || DEFERLENG(mem) || ASZG(mem)) {
15465         return mk_id(mem);
15466       } else {
15467         INT val[2];
15468         val[0] = 0;
15469         val[1] = PARMINITG(mem);
15470         return mk_cnst(getcon(val, DT_INT));
15471       }
15472     }
15473   }
15474 
15475   return 0;
15476 }
15477 
15478 /** \brief Return 0 if there's at least one length type parameter that is not
15479            assumed. Otherwise return 1.
15480  */
15481 int
all_len_parms_assumed(int dtype)15482 all_len_parms_assumed(int dtype)
15483 {
15484 
15485   int i, mem;
15486 
15487   if (DTY(dtype) != TY_DERIVED)
15488     return 0;
15489 
15490   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15491     if (PARENTG(mem)) {
15492       i = all_len_parms_assumed(DTYPEG(PARENTG(mem)));
15493       if (!i)
15494         return 0;
15495     }
15496     if (LENPARMG(mem) && !ASZG(mem))
15497       return 0;
15498   }
15499   return 1;
15500 }
15501 
15502 static void
check_kind_type_param(int dtype)15503 check_kind_type_param(int dtype)
15504 {
15505   int mem, mem_dtype;
15506 
15507   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15508     mem_dtype = DTYPEG(mem);
15509     if (PARENTG(mem)) {
15510       check_kind_type_param(mem_dtype);
15511     }
15512     if (!SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) && !LENPARMG(mem) &&
15513         !PARMINITG(mem)) {
15514       error(155, 3, gbl.lineno,
15515             "Missing constant value for kind type parameter", SYMNAME(mem));
15516     }
15517   }
15518 }
15519 
15520 LOGICAL
put_kind_type_param(DTYPE dtype,int offset,int value,int expr,int flag)15521 put_kind_type_param(DTYPE dtype, int offset, int value, int expr, int flag)
15522 {
15523   int mem;
15524   LOGICAL found = FALSE;
15525 
15526   if (DTY(dtype) != TY_DERIVED) {
15527     return FALSE;
15528   }
15529 
15530   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15531     DTYPE mem_dtype = DTYPEG(mem);
15532     if (PARENTG(mem)) {
15533       if (is_pdt_dtype(mem_dtype)) {
15534         found = put_kind_type_param(mem_dtype, offset, value, expr, flag);
15535       }
15536     } else if (USEKINDG(mem) && KINDG(mem) == offset) {
15537       if (expr && A_TYPEG(expr) != A_CNST) {
15538         error(155, ERR_Severe, gbl.lineno,
15539               "Kind type parameter value must be a compile-time constant"
15540               " for component",
15541               SYMNAME(mem));
15542       }
15543       if (DTY(mem_dtype) != TY_ARRAY) {
15544         int ast;
15545         DTYPE out_dtype;
15546         int ty;
15547         if (DT_ISINT(mem_dtype))
15548           ty = TY_INT;
15549         else if (DT_ISREAL(mem_dtype))
15550           ty = TY_REAL;
15551         else if (DT_ISCMPLX(mem_dtype))
15552           ty = TY_CMPLX;
15553         else
15554           ty = DTY(mem_dtype);
15555         /* Evaluate the kind expression. If we're processing the
15556          * default dtype, then ast is -1.
15557          */
15558         ast = chk_kind_parm_set_expr(KINDASTG(mem), dtype);
15559         if (ast > 0 && A_TYPEG(ast) == A_CNST) {
15560           value = CONVAL2G(A_SPTRG(ast));
15561         } else if (ast > 0) {
15562           error(155, ERR_Severe, gbl.lineno,
15563                 "Kind type parameter value must be a compile-time constant"
15564                 " for component",
15565                 SYMNAME(mem));
15566         }
15567         if (ast > 0 || value == 1 || value == 2 || value == 4 || value == 8) {
15568           out_dtype = select_kind(mem_dtype, ty, value);
15569         } else {
15570           out_dtype = mem_dtype;
15571         }
15572         ty = DTY(out_dtype);
15573         if (ty == TY_CHAR || ty == TY_NCHAR)
15574         {
15575           int sym;
15576 
15577           out_dtype = get_type(2, ty, DTY(mem_dtype + 1));
15578 
15579           ast = DTY(mem_dtype + 1);
15580           switch (A_TYPEG(ast)) {
15581           case A_ID:
15582           case A_LABEL:
15583           case A_ENTRY:
15584           case A_SUBSCR:
15585           case A_SUBSTR:
15586           case A_MEM:
15587             sym = sym_of_ast(ast);
15588             break;
15589           default:
15590             sym = 0;
15591           }
15592           if (!get_len_parm(sym, dtype) && LENG(mem) && USELENG(mem)) {
15593             ast = get_len_parm_by_number(LENG(mem), dtype,
15594                                          sem.type_mode || sem.new_param_dt);
15595           }
15596         } else {
15597           ast = 0;
15598         }
15599         if (ast)
15600           DTY(mem_dtype + 1) = ast;
15601         DTYPEP(mem, out_dtype);
15602       } else {
15603         int ast;
15604         DTYPE out_dtype;
15605         DTYPE base_dtype = DTY(mem_dtype + 1);
15606         int ty;
15607         if (DT_ISINT(base_dtype))
15608           ty = TY_INT;
15609         else if (DT_ISREAL(base_dtype))
15610           ty = TY_REAL;
15611         else if (DT_ISCMPLX(base_dtype))
15612           ty = TY_CMPLX;
15613         else
15614           ty = DTY(base_dtype);
15615         out_dtype = select_kind(base_dtype, ty, value);
15616         if (ty == TY_CHAR || ty == TY_NCHAR)
15617         {
15618           out_dtype = get_type(2, ty, DTY(base_dtype + 1));
15619           ast = DTY(base_dtype + 1);
15620         } else {
15621           ast = 0;
15622         }
15623 
15624         DTY(mem_dtype + 1) = out_dtype;
15625 
15626         if (ast)
15627           DTY(base_dtype + 1) = ast;
15628       }
15629       found = TRUE;
15630     } else if (flag <= 0 && !SETKINDG(mem) && !USEKINDG(mem) &&
15631                KINDG(mem) == offset) {
15632       if (flag == -1)
15633         DEFERLENP(mem, TRUE);
15634       if (flag == -2) {
15635         ASZP(mem, TRUE);
15636       }
15637       KINDP(mem, value);
15638       SETKINDP(mem, TRUE);
15639       if (LENPARMG(mem)) {
15640         LENP(mem, expr);
15641       }
15642       if (flag == 0 && !LENPARMG(mem) && expr &&
15643           !chk_kind_parm_expr(expr, dtype, 0, 1)) {
15644         error(155, 3, gbl.lineno, "Constant expression required for KIND type"
15645                                   " parameter",
15646               SYMNAME(mem));
15647       }
15648       found = TRUE;
15649     }
15650   }
15651   return found;
15652 }
15653 
15654 static void
chk_new_param_dt(int sptr,int dtype)15655 chk_new_param_dt(int sptr, int dtype)
15656 {
15657   int mem;
15658 
15659   if (DTY(dtype) != TY_DERIVED)
15660     return;
15661 
15662   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15663     if (DEFERLENG(mem)) {
15664       if (!LENPARMG(mem)) {
15665         error(155, 3, gbl.lineno,
15666               "Deferred type parameter (:) cannot be used with non-length type "
15667               "parameter",
15668               SYMNAME(mem));
15669       }
15670       if (!ALLOCATTRG(sptr) && !POINTERG(sptr)) {
15671         error(155, 3, gbl.lineno,
15672               "A deferred type parameter (:) must be used with "
15673               " an allocatable or pointer object",
15674               SYMNAME(sptr));
15675       }
15676     }
15677     if (ASZG(mem)) {
15678       if (!LENPARMG(mem)) {
15679         error(155, 3, gbl.lineno,
15680               "Assumed type parameter (*) cannot be used with non-length type "
15681               "parameter",
15682               SYMNAME(mem));
15683       }
15684       if (SCG(sptr) != SC_DUMMY) {
15685         error(155, 3, gbl.lineno,
15686               "An assumed type parameter (*) cannot be used with non-dummy "
15687               "argument",
15688               SYMNAME(sptr));
15689       }
15690     }
15691   }
15692 }
15693 
15694 static int
get_vtoff(int vtoff,DTYPE dtype)15695 get_vtoff(int vtoff, DTYPE dtype)
15696 {
15697   SPTR sym = get_struct_members(dtype);
15698 
15699   for (; sym > NOSYM; sym = SYMLKG(sym)) {
15700     if (PARENTG(sym)) {
15701       int parent_vtoff = VTOFFG(get_struct_tag_sptr(DTYPEG(sym)));
15702       if (parent_vtoff > vtoff) {
15703         vtoff = parent_vtoff;
15704       }
15705       vtoff = get_vtoff(vtoff, DTYPEG(sym));
15706     }
15707     if (is_tbp(sym)) {
15708       if (VTOFFG(BINDG(sym)) > vtoff) {
15709         vtoff = VTOFFG(BINDG(sym));
15710       }
15711     }
15712   }
15713   return vtoff;
15714 }
15715 
15716 int
get_unl_poly_sym(int mem_dtype)15717 get_unl_poly_sym(int mem_dtype)
15718 {
15719   int mem, dtype, i;
15720   int sptr = getsymf("_f03_unl_poly$%d", mem_dtype);
15721 
15722   if (STYPEG(sptr) == ST_UNKNOWN) {
15723     sptr = declsym(sptr, ST_TYPEDEF, TRUE);
15724     CCSYMP(sptr, 1);
15725     dtype = get_type(6, TY_DERIVED, NOSYM);
15726     DTYPEP(sptr, dtype);
15727     DTY(dtype + 1) = NOSYM;
15728     DTY(dtype + 2) = 0; /* will be filled in */
15729     DTY(dtype + 3) = sptr;
15730     DTY(dtype + 5) = 0;
15731     UNLPOLYP(sptr, 1);
15732     DCLDP(sptr, TRUE);
15733     if (!sem.interface)
15734       get_static_type_descriptor(sptr);
15735     if (mem_dtype) {
15736       mem = getccsym_sc('d', sem.dtemps++, ST_MEMBER, SC_NONE);
15737       DTYPEP(mem, mem_dtype);
15738       SYMLKP(mem, DTY(dtype + 1));
15739       DTY(dtype + 1) = mem;
15740     }
15741   } else {
15742     dtype = DTYPEG(sptr);
15743     if (DTY(dtype) == TY_DERIVED) {
15744       DTY(dtype + 3) = sptr;
15745       UNLPOLYP(sptr, 1);
15746       CCSYMP(sptr, 1);
15747       get_static_type_descriptor(sptr);
15748     }
15749   }
15750   return sptr;
15751 }
15752 
15753 /** \brief Returns true if dtype is a derived type that has a type parameter or
15754   * if it has a component that has a type parameter.
15755   *
15756   * This function also takes into account recursive components.
15757   */
15758 static int
has_type_parameter2(int dtype,int visit_flag)15759 has_type_parameter2(int dtype, int visit_flag)
15760 {
15761   typedef struct visitDty {
15762     int dty;
15763     struct visitDty *next;
15764   } VISITDTY;
15765 
15766   static VISITDTY *visit_list = 0;
15767   VISITDTY *curr, *new_visit, *prev;
15768 
15769   int rslt;
15770   int dty = dtype;
15771   int member, dty2;
15772 
15773   if (DTY(dty) == TY_ARRAY)
15774     dty = DTY(dty + 1);
15775 
15776   if (DTY(dty) != TY_DERIVED) {
15777     return 0;
15778   }
15779 
15780   if (visit_list) {
15781     for (curr = visit_list; curr; curr = curr->next) {
15782       if (curr->dty == dty) {
15783         return 0;
15784       }
15785     }
15786   }
15787 
15788   NEW(new_visit, VISITDTY, 1);
15789   new_visit->dty = dty;
15790   new_visit->next = visit_list;
15791   visit_list = new_visit;
15792 
15793   for (rslt = 0, member = DTY(dty + 1); member > NOSYM;
15794        member = SYMLKG(member)) {
15795     if (!USEKINDG(member) && KINDG(member)) {
15796       rslt = 1;
15797       break;
15798     }
15799     if (has_type_parameter2(DTYPEG(member), 1)) {
15800       rslt = 1;
15801       break;
15802     }
15803   }
15804 
15805   if (!visit_flag && visit_list) {
15806     for (prev = curr = visit_list; curr;) {
15807 
15808       curr = curr->next;
15809       FREE(prev);
15810       prev = curr;
15811     }
15812     visit_list = 0;
15813   }
15814 
15815   return rslt;
15816 }
15817 
15818 /** \brief checks to see if derived type record, dtype, has any type
15819   * parameters (kind or length type parameters).
15820   *
15821   * \param dtype is the derived type record we're searching
15822   *
15823   * \return integer > 0 if dtype has type parameters; else 0.
15824   */
15825 int
has_type_parameter(int dtype)15826 has_type_parameter(int dtype)
15827 {
15828   return has_type_parameter2(dtype, 0);
15829 }
15830 
15831 static int
has_length_type_parameter(int dtype)15832 has_length_type_parameter(int dtype)
15833 {
15834 
15835   int mem;
15836 
15837   if (DTY(dtype) != TY_DERIVED)
15838     return 0;
15839   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15840     if (PARENTG(mem) && has_length_type_parameter(DTYPEG(mem)))
15841       return 1;
15842     if (!USEKINDG(mem) && KINDG(mem) && LENPARMG(mem)) {
15843       return 1;
15844     }
15845   }
15846 
15847   return 0;
15848 }
15849 
15850 int
has_length_type_parameter_use(int dtype)15851 has_length_type_parameter_use(int dtype)
15852 {
15853   int mem;
15854 
15855   if (DTY(dtype) == TY_ARRAY)
15856     dtype = DTY(dtype + 1);
15857 
15858   if (DTY(dtype) != TY_DERIVED)
15859     return 0;
15860   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15861     if (PARENTG(mem) && has_length_type_parameter_use(DTYPEG(mem)))
15862       return 1;
15863     if (USELENG(mem)) {
15864       return 1;
15865     }
15866   }
15867   return 0;
15868 }
15869 
15870 static int
get_highest_param_offset(int dtype)15871 get_highest_param_offset(int dtype)
15872 {
15873 
15874   int mem, start, p;
15875 
15876   if (DTY(dtype) != TY_DERIVED)
15877     return -1;
15878 
15879   for (start = 0, mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15880     if (PARENTG(mem)) {
15881       start = get_highest_param_offset(DTYPEG(PARENTG(mem)));
15882     }
15883     if (!USEKINDG(mem) && (p = KINDG(mem))) {
15884       if (p > start)
15885         start = p;
15886     }
15887   }
15888 
15889   return start;
15890 }
15891 
15892 /** \brief Create a parameterized derived type based on dtype.
15893            If force is not set and dtype is already a PDT, return DT_NONE. */
15894 DTYPE
create_parameterized_dt(DTYPE dtype,LOGICAL force)15895 create_parameterized_dt(DTYPE dtype, LOGICAL force)
15896 {
15897   int mem;
15898   int prev_mem;
15899 
15900   if (!has_type_parameter(dtype)) {
15901     return DT_NONE;
15902   }
15903   if (!force && is_pdt_dtype(dtype)) {
15904     return DT_NONE;
15905   }
15906   dtype = get_parameterized_dt(dtype);
15907   prev_mem = NOSYM;
15908   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15909     if (PARENTG(mem)) {
15910       DTYPE new_dtype = create_parameterized_dt(DTYPEG(mem), force);
15911       if (new_dtype) {
15912         int new_mem = insert_dup_sym(mem);
15913         DTYPEP(new_mem, new_dtype);
15914         if (prev_mem == NOSYM) {
15915           DTY(dtype + 1) = new_mem;
15916         } else {
15917           SYMLKP(prev_mem, new_mem);
15918         }
15919       }
15920       break;
15921     }
15922     prev_mem = mem;
15923   }
15924 
15925   return dtype;
15926 }
15927 
15928 /** \brief Duplicate \a dtype by creating a new derived type with a $pt suffix.
15929            For use with processing parameterized derived type.
15930  */
15931 DTYPE
get_parameterized_dt(DTYPE dtype)15932 get_parameterized_dt(DTYPE dtype)
15933 {
15934   int tag, mem, sptr;
15935   int first_mem = NOSYM;
15936   int curr_mem = NOSYM;
15937   DTYPE new_dtype;
15938   ACL *ict;
15939 
15940   assert(DTY(dtype) == TY_DERIVED, "expected TY_DERIVED", DTY(dtype),
15941          ERR_Fatal);
15942 
15943   tag = DTY(dtype + 3);
15944   sptr = get_next_sym(SYMNAME(tag), "pt");
15945   DINITP(sptr, DINITG(tag));
15946 
15947   sptr = declsym(sptr, ST_TYPEDEF, TRUE);
15948   BASETYPEP(sptr, dtype);
15949   CCSYMP(sptr, 1);
15950   new_dtype = get_type(6, TY_DERIVED, NOSYM);
15951   DTYPEP(sptr, new_dtype);
15952   DTY(new_dtype + 2) = 0; /* will be filled in */
15953   DTY(new_dtype + 3) = sptr;
15954 
15955   for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15956     int new_mem = insert_dup_sym(mem);
15957     VARIANTP(new_mem, curr_mem);
15958     ENCLDTYPEP(new_mem, new_dtype);
15959     ADDRESSP(new_mem, 0);
15960     if (first_mem == NOSYM) {
15961       first_mem = new_mem;
15962     } else {
15963       SYMLKP(curr_mem, new_mem);
15964     }
15965     curr_mem = new_mem;
15966   }
15967   DTY(new_dtype + 1) = first_mem;
15968   for (mem = first_mem; mem > NOSYM; mem = SYMLKG(mem)) {
15969     int descr;
15970     if (MIDNUMG(mem) && STYPEG(MIDNUMG(mem)) == ST_MEMBER) {
15971       int mid_mem = SYMLKG(mem);
15972       if (PTRVG(mid_mem) &&
15973           strcmp(SYMNAME(mid_mem), SYMNAME(MIDNUMG(mem))) == 0) {
15974         int off_mem;
15975         MIDNUMP(mem, mid_mem);
15976         off_mem = SYMLKG(mid_mem);
15977         if (PTROFFG(mem) && STYPEG(PTROFFG(mem)) == ST_MEMBER)
15978           PTROFFP(mem, off_mem);
15979       }
15980     }
15981 
15982     if (SDSCG(mem) && STYPEG(mem) == ST_MEMBER) {
15983       /* Always dup the component descriptor's array dtype */
15984       int sdsc_mem = get_member_descriptor(mem);
15985       if (sdsc_mem > NOSYM && DESCARRAYG(sdsc_mem)) {
15986         DTYPEP(sdsc_mem, dup_array_dtype(DTYPEG(sdsc_mem)));
15987         SDSCP(mem, sdsc_mem);
15988       }
15989     }
15990     descr = DESCRG(mem);
15991     if (descr != 0) {
15992       /* duplicate the descr */
15993       int new_descr = insert_dup_sym(descr);
15994       DESCRP(mem, new_descr);
15995       SECDSCP(new_descr, match_memname(SECDSCG(new_descr), first_mem));
15996       ARRAYP(new_descr, match_memname(ARRAYG(new_descr), first_mem));
15997     }
15998   }
15999 
16000   ict = get_getitem_p(DTY(dtype + 5));
16001   if (ict != 0) {
16002     ACL *newict = dup_acl(ict, sptr);
16003     DTY(new_dtype + 5) = put_getitem_p(newict);
16004   } else {
16005     DTY(new_dtype + 5) = 0;
16006   }
16007 
16008   chkstruct(new_dtype);
16009   return new_dtype;
16010 }
16011 
16012 static ACL *
dup_acl(ACL * src,int sptr)16013 dup_acl(ACL *src, int sptr)
16014 {
16015   ACL *subc = src->subc;
16016   ACL *next = src->next;
16017   ACL *dst = GET_ACL(15);
16018   *dst = *src;
16019   dst->sptr = sptr;
16020   if (DTY(src->dtype) == TY_DERIVED) {
16021     dst->dtype = DTYPEG(sptr);
16022   }
16023   if (subc != 0) {
16024     dst->subc = dup_acl(subc, match_memname(subc->sptr, DTY(DTYPEG(sptr) + 1)));
16025   }
16026   if (next != 0) {
16027     dst->next = dup_acl(next, match_memname(next->sptr, SYMLKG(sptr)));
16028   }
16029   return dst;
16030 }
16031 
16032 /* Return the symbol in mem list (linked through SYMLK) whose name matches sptr.
16033    Return sptr if there is none. */
16034 static int
match_memname(int sptr,int mem)16035 match_memname(int sptr, int mem)
16036 {
16037   for (; mem > NOSYM; mem = SYMLKG(mem)) {
16038     if (NMPTRG(sptr) == NMPTRG(mem)) {
16039       return mem;
16040     }
16041   }
16042   return sptr;
16043 }
16044 
16045 /* Return TRUE if dtype represents a parameterized derived type. */
16046 static LOGICAL
is_pdt_dtype(DTYPE dtype)16047 is_pdt_dtype(DTYPE dtype)
16048 {
16049   return DTY(dtype) == TY_DERIVED &&
16050          strstr(SYMNAME(DTY(dtype + 3)), "$pt") != 0;
16051 }
16052 
16053 /** \brief allow other source files to check whether we're processing a
16054   * parameter construct.
16055   */
16056 int
is_parameter_context()16057 is_parameter_context()
16058 {
16059   return (entity_attr.exist & ET_B(ET_PARAMETER));
16060 }
16061 
16062 static int
mystrcasecmp(char * a,char * b)16063 mystrcasecmp(char *a, char *b)
16064 {
16065   while (*a && *b) {
16066     char aa = *a++, bb = *b++;
16067     if (aa >= 'A' && aa <= 'Z')
16068       aa = aa - 'A' + 'a';
16069     if (bb >= 'A' && bb <= 'Z')
16070       bb = bb - 'A' + 'a';
16071     if (aa != bb)
16072       return aa - bb;
16073   }
16074   return 0;
16075 } /* mystrcasecmp */
16076 
16077 static LOGICAL
ignore_common_decl(void)16078 ignore_common_decl(void)
16079 {
16080   if (sem.which_pass == 0) {
16081     if (sem.mod_cnt && gbl.currsub) {
16082       /*
16083        * Do not process the common declaration if in a module subroutine
16084        */
16085       return TRUE;
16086     }
16087   }
16088   return FALSE;
16089 }
16090 
16091 /** \brief Return the predicate: current entity has the INTRINSIC attribute. */
16092 bool
in_intrinsic_decl(void)16093 in_intrinsic_decl(void)
16094 {
16095   return (entity_attr.exist & ET_B(ET_INTRINSIC)) != 0;
16096 }
16097 
16098 /** \brief provide the current entity's access to other source files. */
16099 int
get_entity_access()16100 get_entity_access()
16101 {
16102   return entity_attr.access;
16103 }
16104 
16105 /** \brief provide mscall variable state to other source files. */
16106 int
getMscall()16107 getMscall()
16108 {
16109   return mscall;
16110 }
16111 
16112 /** \brief provide cref variable state to other source files. */
16113 int
getCref()16114 getCref()
16115 {
16116   return cref;
16117 }
16118 
16119 /** \brief Determine procedure symbol type for a set of attributes
16120  *
16121  *  \param attr attribute mask
16122  *
16123  *  \return symbol type index, zero on error
16124  */
16125 static int
get_procedure_stype(int attr)16126 get_procedure_stype(int attr)
16127 {
16128   if (attr & ET_B(ET_POINTER)) {
16129     if (!INSIDE_STRUCT) {
16130       return ST_VAR;
16131     }
16132 
16133     return ST_MEMBER;
16134   }
16135 
16136   if (INSIDE_STRUCT) {
16137     return 0;
16138   }
16139 
16140   return ST_PROC;
16141 }
16142 
16143 /** \brief Declare a procedure symbol
16144  *
16145  * Perform check nesessary for a declaration or procedure and produce a new
16146  * symbol that matches procedure interface and attributes
16147  *
16148  *  \param sptr symbol table index for the symbol
16149  *  \param proc_interf_sptr symbol table entry for procedure interface
16150  *  \param attr attributes (bit vector), same as entity_attr.exist
16151  *
16152  *  \return symbol table index for created symbol
16153  */
16154 static int
decl_procedure_sym(int sptr,int proc_interf_sptr,int attr)16155 decl_procedure_sym(int sptr, int proc_interf_sptr, int attr)
16156 {
16157   /* First get expected symbol type */
16158   int stype = get_procedure_stype(attr);
16159 
16160   if (!stype) {
16161     /* TODO better place for this error message? */
16162     error(155, 3, gbl.lineno,
16163           "PROCEDURE component must have the POINTER attribute -",
16164           SYMNAME(sptr));
16165     return 0;
16166   }
16167 
16168   /* Create a new symbol */
16169   if (stype != ST_MEMBER) {
16170     sptr = declsym(sptr, stype, FALSE);
16171   } else {
16172     if (STYPEG(sptr) != ST_UNKNOWN)
16173       sptr = insert_sym(sptr);
16174     SYMLKP(sptr, NOSYM);
16175     STYPEP(sptr, ST_MEMBER);
16176     if (attr & ET_B(ET_NOPASS)) {
16177       NOPASSP(sptr, 1);
16178     } else {
16179       if (!proc_interf_sptr) {
16180         error(155, 3, gbl.lineno, "The NOPASS attribute must be present for",
16181               SYMNAME(sptr));
16182       }
16183       if (attr & ET_B(ET_PASS)) {
16184         PASSP(sptr, entity_attr.pass_arg);
16185         if (IN_MODULE_SPEC) {
16186           /* Pop the pass arg so it does not pollute
16187            * other dummy arguments with same name in module.
16188            * That's because we do not rewrite the pass arg when
16189            * it's encountered in the contains subroutine. We only
16190            * write out new symbols. The pass arg does not get its
16191            * STYPE and CLASS fields, for example, set until we
16192            * process the contains subroutine. Later, when we use
16193            * the module, we pull in the uninitialized pass argument
16194            * which leads to problems if arg is declared CLASS and
16195            * it does not have CLASS set.
16196            */
16197           pop_sym(entity_attr.pass_arg);
16198         }
16199       }
16200     }
16201   }
16202 
16203   return sptr;
16204 }
16205 
16206 /** \brief Process procedure declaration
16207  *
16208  * Modify symbol table entry for a procedure declaration, producing the right
16209  * datatype for procedure pointers or members.
16210  *
16211  *  \param sptr symbol table index for the symbol
16212  *  \param proc_interf_sptr symbol table entry for procedure interface
16213  *  \param attr attributes (bit vector), same as entity_attr.exist
16214  *  \param access access level, same as entity_attr.access
16215  *
16216  *  \return index of produced symbol table entry, 0 if error
16217  *
16218  */
16219 static int
setup_procedure_sym(int sptr,int proc_interf_sptr,int attr,char access)16220 setup_procedure_sym(int sptr, int proc_interf_sptr, int attr, char access)
16221 {
16222   int ast;
16223   int stype;
16224   int dtype;
16225   ACL *ict;
16226   VAR *ivl;
16227 
16228   /* ********** Determine symbol type ********** */
16229   stype = get_procedure_stype(attr);
16230 
16231   /*
16232    * Check for required attributes
16233    */
16234   if (!stype) {
16235     /* TODO better place for this error message? */
16236     error(155, 3, gbl.lineno,
16237           "PROCEDURE component must have the POINTER attribute -",
16238           SYMNAME(sptr));
16239     return 0;
16240   }
16241 
16242   if ((stype != ST_MEMBER) && (attr & (ET_B(ET_SAVE) | ET_B(ET_INTENT)))) {
16243     if (!(attr & ET_B(ET_POINTER))) {
16244       error(155, 3, gbl.lineno, "The POINTER attribute must be present for",
16245             SYMNAME(sptr));
16246       return sptr;
16247     }
16248   }
16249 
16250   STYPEP(sptr, stype);
16251 
16252   if (sem.gdtype != -1) {
16253     dtype = sem.gdtype;
16254   } else if (proc_interf_sptr) {
16255     dtype = DTYPEG(proc_interf_sptr);
16256   } else {
16257     dtype = DTYPEG(sptr);
16258   }
16259   DCLDP(sptr, TRUE);
16260   if (stype == ST_PROC) {
16261     if (proc_interf_sptr && (!gbl.currsub || SCG(sptr))) {
16262       defer_iface(proc_interf_sptr, 0, sptr, 0);
16263     } else if (scn.stmtyp == TK_PROCEDURE)
16264       /* have a procedure without an interface, i.e.,
16265        *   procedure() [...] :: foo
16266        * Assume 'subroutine'
16267        */
16268       dtype = DT_NONE;
16269   } else {
16270     /* stype == ST_MEMBER or ST_VAR => have an entity-style declaration with
16271      * the POINTER attribute
16272      */
16273     dtype = get_type(6, TY_PROC, dtype);
16274     DTY(dtype + 2) = 0; /* interface */
16275     DTY(dtype + 3) = 0; /* PARAMCT */
16276     DTY(dtype + 4) = 0; /* DPDSC */
16277     DTY(dtype + 5) = 0; /* FVAL */
16278 
16279     if (proc_interf_sptr) {
16280       DTY(dtype + 2) = proc_interf_sptr; /* Set interface */
16281       defer_iface(proc_interf_sptr, dtype, 0, sptr);
16282     } else if (sem.gdtype == -1)
16283       /*
16284        * Have procedure( ), pointer [...] :: foo k
16285        * If a type appears as the interface name, sem.gdtype will be set to
16286        * that type.
16287        */
16288       DTY(dtype + 1) = DT_NONE;
16289 
16290     dtype = get_type(2, TY_PTR, dtype);
16291     if (STYPEG(sptr) != ST_VAR || !IS_PROC_DUMMYG(sptr))
16292       POINTERP(sptr, TRUE);
16293 
16294     if (access == 'v' || (sem.accl.type == 'v' && access != 'u')) {
16295       /* Set PRIVATE here for procedure pointers. */
16296       PRIVATEP(sptr, 1);
16297     }
16298   }
16299   DTYPEP(sptr, dtype);
16300 
16301   /* ********** Add any additional attributes and return ********** */
16302   if (stype == ST_MEMBER) {
16303     stsk = &STSK_ENT(0);
16304     /* link field-namelist into member list at this level */
16305     link_members(stsk, sptr);
16306   }
16307 
16308   if (attr & ET_B(ET_SAVE))
16309     SAVEP(sptr, 1);
16310   if (attr & ET_B(ET_OPTIONAL))
16311     OPTARGP(sptr, 1);
16312   if (attr & ET_B(ET_PROTECTED))
16313     PROTECTEDP(sptr, 1);
16314   if (attr & ET_B(ET_BIND))
16315     process_bind(sptr);
16316 
16317   return sptr;
16318 }
16319 
16320 static void
record_func_result(int func_sptr,int func_result_sptr,LOGICAL in_ENTRY)16321 record_func_result(int func_sptr, int func_result_sptr, LOGICAL in_ENTRY)
16322 {
16323   if (gbl.rutype != RU_FUNC)
16324     return; /* can't have a RESULT clause unless a function */
16325   if (in_ENTRY && FVALG(func_sptr) != 0) {
16326     if (func_result_sptr)
16327       error(155, 3, gbl.lineno, "The ENTRY cannot have a result name -",
16328             SYMNAME(func_sptr));
16329     return;
16330   }
16331   if (func_result_sptr != 0) {
16332     /* result variable from RESULT(func_result_sptr) clause */
16333     RESULTP(func_sptr, TRUE);
16334     if (in_ENTRY)
16335       DCLDP(func_sptr, TRUE);
16336   } else {
16337     /* insert a dummy variable with the name of the function */
16338     func_result_sptr = insert_sym(func_sptr);
16339     pop_sym(func_result_sptr);
16340     STYPEP(func_result_sptr, ST_IDENT);
16341     SCOPEP(func_result_sptr, stb.curr_scope);
16342     SCP(func_result_sptr, SC_DUMMY);
16343     if (!in_ENTRY && sem.interface) {
16344       NODESCP(func_result_sptr, TRUE);
16345       IGNOREP(func_result_sptr, TRUE);
16346     }
16347   }
16348   if (in_ENTRY && RESULTG(func_result_sptr) != 0) {
16349     /* create_func_entry_result() discovered that a variable
16350      * named the same as the result-name was already declared.
16351      * transfer data type to entry
16352      */
16353     DTYPEP(func_sptr, DTYPEG(func_result_sptr));
16354   } else {
16355     if (DTYPEG(func_sptr)) {
16356       /* transfer data type from FUNCTION statement to func_result_sptr */
16357       DTYPEP(func_result_sptr, DTYPEG(func_sptr));
16358       ADJLENP(func_result_sptr, ADJLENG(func_sptr));
16359     }
16360     RESULTP(func_result_sptr, TRUE);
16361   }
16362   FVALP(func_sptr, func_result_sptr);
16363   if (DCLDG(func_sptr))
16364     DCLDP(func_result_sptr, TRUE);
16365 }
16366 
16367 /** \brief Determine if a type bound procedure (tbp) binding name requires
16368  * overloading.
16369  *
16370  * This is called by the <binding name> ::= <id> '=>' <id> production
16371  * above. After the tbp is set up, we perform additional overloading checks
16372  * in resolveBind() of semtbp.c.
16373  *
16374  * \pararm sptr is the binding name that we are checking.
16375  *
16376  * \return true if it is an overloaded binding name, else false.
16377  */
16378 static bool
bindingNameRequiresOverloading(SPTR sptr)16379 bindingNameRequiresOverloading(SPTR sptr)
16380 {
16381   if (STYPEG(sptr) == ST_PD) {
16382     /* Overloaded intrinsic with same name. */
16383     return true;
16384   }
16385 
16386   if (STYPEG(sptr) == ST_PROC) {
16387 
16388     if (SCOPEG(sptr) != stb.curr_scope) {
16389       /* Another use associated symbol with same name. */
16390       return true;
16391     }
16392 
16393     if (IN_MODULE_SPEC && TBPLNKG(sptr) == 0) {
16394       /* Another symbol in module specification section with same name and
16395        * same scope.
16396        * This is possibly a procedure with the same name declared in an
16397        * interface block.
16398        */
16399       return true;
16400     }
16401   }
16402   return false;
16403 }
16404 
16405 const char *
sem_pgphase_name()16406 sem_pgphase_name()
16407 {
16408   switch (sem.pgphase) {
16409   case PHASE_END_MODULE:
16410     return "END_MODULE";
16411   case PHASE_INIT:
16412     return "INIT";
16413   case PHASE_HEADER:
16414     return "HEADER";
16415   case PHASE_USE:
16416     return "USE";
16417   case PHASE_IMPORT:
16418     return "IMPORT";
16419   case PHASE_IMPLICIT:
16420     return "IMPLICIT";
16421   case PHASE_SPEC:
16422     return "SPEC";
16423   case PHASE_EXEC:
16424     return "EXEC";
16425   case PHASE_CONTAIN:
16426     return "CONTAIN";
16427   case PHASE_INTERNAL:
16428     return "INTERNAL";
16429   case PHASE_END:
16430     return "END";
16431   default:
16432     return "unknown";
16433   }
16434 }
16435 
16436 /** \brief To re-initialize an array of derived types when found the
16437  *         following conditions are satisfied:
16438            1. the element of the array is a derived type.
16439            2. the array has been initialized before and needs to be
16440               re-initialized.
16441            3. none of any entity attributes used for array definition.
16442  */
16443 static bool
do_fixup_param_vars_for_derived_arrays(bool inited,SPTR sptr,int sst_idg)16444 do_fixup_param_vars_for_derived_arrays(bool inited, SPTR sptr, int sst_idg)
16445 {
16446   return sem.dinit_count > 0 && inited && !entity_attr.exist &&
16447          STYPEG(sptr) == ST_IDENT && sst_idg == S_ACONST &&
16448          DTY(DTYPEG(sptr)) == TY_ARRAY && DTYG(DTYPEG(sptr)) == TY_DERIVED &&
16449          /* found the tag has been initialized already with a valid sptr*/
16450          DINITG(DTY(DTY(DTYPEG(sptr)+1)+3));
16451 }
16452