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, ¶mct, &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