1 /*
2 * Copyright (c) 1995-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 /** \file
19 \brief Fortran utility routines used by Semantic Analyzer to process
20 user-defined generics including overloaded operators
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "gramtk.h"
26 #include "error.h"
27 #include "symtab.h"
28 #include "symutl.h"
29 #include "dtypeutl.h"
30 #include "semant.h"
31 #include "scan.h"
32 #include "semstk.h"
33 #include "pd.h"
34 #include "machar.h"
35 #include "ast.h"
36 #include "state.h"
37
38 static int silent_error_mode = 0;
39 #undef E155
40 #define E155(s1, s2) \
41 if (!silent_error_mode) \
42 error(155, 3, gbl.lineno, s1, s2)
43
44 static int resolve_generic(int, SST *, ITEM *);
45 static long *args_match(int, int, int, ITEM *, LOGICAL, LOGICAL);
46 static LOGICAL tkr_match(int, SST *, int, LOGICAL);
47 static LOGICAL kwd_match(ITEM *, int, char *);
48 static void get_type_rank(SST *, int *, int *);
49 static ITEM *make_list(SST *, SST *);
50 static int resolve_operator(int, SST *, SST *);
51 static int find_operator(int, SST *, SST *, LOGICAL);
52 static bool queue_generic_tbp_once(SPTR gnr);
53 static bool is_conflicted_generic(SPTR, SPTR);
54
55 /* macros used by the arg scoring routines */
56 #define UNIT_SZ 3 /**< bits necessary to hold the max *_MATCH value */
57 #define NBR_DISTANCE_ELM_BITS ((sizeof(long) * 8 - 1) / UNIT_SZ)
58 #define DISTANCE_BIT(i) (i % NBR_DISTANCE_ELM_BITS)
59 #define DISTANCE_ELM(distance, i) (distance[i / NBR_DISTANCE_ELM_BITS])
60
61 /* constants returned by by args_match and tkr_match */
62 #define INF_DISTANCE ((long)-1)
63 #define MIN_DISTANCE 0
64 /* also returned by tkr_match */
65 #define EXACT_MATCH 0
66 #define EXTND_MATCH 4
67 /* UNIT_SZ (above) must be the number of bits necessary to hold the max *_MATCH
68 * value */
69
70 #define MAN_MAN_MATCH 0
71 #define MAN_DEV_MATCH 1
72 #define MAN_HOST_MATCH 2
73
74 static int resolved_to_self = 0;
75
76 /*
77 * Table used to record and return the ST_OPERATOR symbols corresponding
78 * to the intrinsic and the assignment operators.
79 */
80 static struct optabstruct {
81 int opr; /* if non-zero, locates the ST_OPERATOR symbol */
82 char *name; /* name of the corresponding ST_OPERATOR symbol */
83 } optab[] = {
84 {0, ""}, /* OP_NEG 0 */
85 {0, "+"}, /* OP_ADD 1 */
86 {0, "-"}, /* OP_SUB 2 */
87 {0, "*"}, /* OP_MUL 3 */
88 {0, "/"}, /* OP_DIV 4 */
89 {0, "**"}, /* OP_XTOI 5 */
90 {0, ""}, /* OP_XTOX 6 */
91 {0, ""}, /* OP_CMP 7 */
92 {0, ""}, /* OP_AIF 8 */
93 {0, ""}, /* OP_LD 9 */
94 {0, "="}, /* OP_ST 10 */
95 {0, ""}, /* OP_FUNC 11 */
96 {0, ""}, /* OP_CON 12 */
97 {0, "//"}, /* OP_CAT 13 */
98 {0, ""}, /* OP_LOG 14 */
99 {0, ".eqv."}, /* OP_LEQV 15 */
100 {0, ".neqv."}, /* OP_LNEQV 16 */
101 {0, ".or."}, /* OP_LOR 17 */
102 {0, ".and."}, /* OP_LAND 18 */
103 {0, "=="}, /* OP_EQ 19 */
104 {0, ">="}, /* OP_GE 20 */
105 {0, ">"}, /* OP_GT 21 */
106 {0, "<="}, /* OP_LE 22 */
107 {0, "<"}, /* OP_LT 23 */
108 {0, "!="}, /* OP_NE 24 */
109 {0, ".not."}, /* OP_LNOT 25 */
110 {0, ""}, /* OP_LOC 26 */
111 {0, ""}, /* OP_REF 27 */
112 {0, ""}, /* OP_VAL 28 */
113 };
114 #define OPTABSIZE 29
115
116 /** \brief Determines if we should (re)generate generic type bound procedure
117 * (tbp) bindings based on scope. This should only be done once per scope.
118 *
119 * \param gnr is the SPTR of the symbol to check or 0 if N/A.
120 *
121 * \return true if we should (re)generate generic tbp bindings, else false.
122 */
123 static bool
queue_generic_tbp_once(SPTR gnr)124 queue_generic_tbp_once(SPTR gnr)
125 {
126 if (GNCNTG(gnr) == 0 || gbl.internal > 1) {
127 static int generic_tbp_scope = 0;
128 bool rslt = (generic_tbp_scope != stb.curr_scope);
129 generic_tbp_scope = stb.curr_scope;
130 return rslt;
131 }
132 return false;
133 }
134
135 /** \brief Determines if two generic procedures from different
136 modules are conflicted or not.
137 *
138 * \param found_sptrgen is the first generic procedure sptr.
139 * \param func_sptrgen is the second generic procedure sptr.
140 *
141 * \return true if the func_sptrgen and found_sptrgen are not conflicted, else
142 * false.
143 */
144 static bool
is_conflicted_generic(SPTR func_sptrgen,SPTR found_sptrgen)145 is_conflicted_generic(SPTR func_sptrgen, SPTR found_sptrgen) {
146 return func_sptrgen != found_sptrgen &&
147 (PRIVATEG(func_sptrgen) != PRIVATEG(found_sptrgen) ||
148 NOT_IN_USEONLYG(func_sptrgen) != NOT_IN_USEONLYG(found_sptrgen));
149 }
150
151 void
check_generic(int gnr)152 check_generic(int gnr)
153 {
154 if (STYPEG(gnr) == ST_USERGENERIC) {
155 ;
156 } else {
157 #if DEBUG
158 assert(STYPEG(gnr) == ST_OPERATOR, "check_generic, expected ST_OPERATOR",
159 STYPEG(gnr), 3);
160 #endif
161 }
162 }
163
164 int
generic_tbp_call(int gnr,SST * stktop,ITEM * list,ITEM * chevlist)165 generic_tbp_call(int gnr, SST *stktop, ITEM *list, ITEM *chevlist)
166 {
167 int sptr;
168 int dtype;
169 int mem;
170
171 #if DEBUG
172 if (DBGBIT(3, 256))
173 fprintf(gbl.dbgfil, "user generic, call %s\n", SYMNAME(gnr));
174 #endif
175 if (queue_generic_tbp_once(gnr)) {
176 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_GENERIC);
177 }
178
179 if (list == NULL)
180 list = ITEM_END;
181 sptr = resolve_generic(gnr, stktop, list);
182 return sptr;
183 }
184
185 void
generic_call(int gnr,SST * stktop,ITEM * list,ITEM * chevlist)186 generic_call(int gnr, SST *stktop, ITEM *list, ITEM *chevlist)
187 {
188 int sptr;
189
190 #if DEBUG
191 if (DBGBIT(3, 256))
192 fprintf(gbl.dbgfil, "user generic, call %s\n", SYMNAME(gnr));
193 #endif
194 if (list == NULL)
195 list = ITEM_END;
196 sptr = resolve_generic(gnr, stktop, list);
197 if (sptr == 0) {
198 SST_ASTP(stktop, 0);
199 return;
200 }
201 #if DEBUG
202 if (DBGBIT(3, 256))
203 fprintf(gbl.dbgfil, "user generic resolved to %s\n", SYMNAME(sptr));
204 #endif
205 SST_SYMP(stktop, -sptr);
206
207 subr_call2(stktop, list, 1);
208
209 }
210
211 int
generic_tbp_func(int gnr,SST * stktop,ITEM * list)212 generic_tbp_func(int gnr, SST *stktop, ITEM *list)
213 {
214 int sptr;
215
216 #if DEBUG
217 if (DBGBIT(3, 256))
218 fprintf(gbl.dbgfil, "user generic %s\n", SYMNAME(gnr));
219 #endif
220
221 if (queue_generic_tbp_once(gnr)) {
222 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_GENERIC);
223 }
224
225 if (list == NULL)
226 list = ITEM_END;
227 sptr = resolve_generic(gnr, stktop, list);
228 return sptr;
229 }
230
231 int
generic_func(int gnr,SST * stktop,ITEM * list)232 generic_func(int gnr, SST *stktop, ITEM *list)
233 {
234 int sptr;
235
236 #if DEBUG
237 if (DBGBIT(3, 256))
238 fprintf(gbl.dbgfil, "user generic %s\n", SYMNAME(gnr));
239 #endif
240 if (list == NULL)
241 list = ITEM_END;
242 sptr = resolve_generic(gnr, stktop, list);
243 if (sptr == 0) {
244 SST_IDP(stktop, S_CONST);
245 SST_DTYPEP(stktop, DT_INT);
246 return 3;
247 }
248 if (sptr == -1) {
249 /* the generic resolve to a structure constructor */
250 return 1;
251 }
252 #if DEBUG
253 if (DBGBIT(3, 256)) {
254 fprintf(gbl.dbgfil, "user generic resolved to %s\n", SYMNAME(sptr));
255 if (sptr < stb.firstosym)
256 fprintf(gbl.dbgfil, "USING intrinsic generic\n");
257 }
258 #endif
259 mkident(stktop);
260 SST_SYMP(stktop, sptr);
261 SST_DTYPEP(stktop, DTYPEG(sptr));
262 if (sptr < stb.firstosym) {
263 if (STYPEG(sptr) == ST_PD)
264 return ref_pd(stktop, list);
265 return ref_intrin(stktop, list);
266 }
267 SST_ASTP(stktop, mk_id(sptr));
268 return func_call2(stktop, list, 1);
269 }
270
271 static long *
set_distance_to(long value,long * distance,int sz)272 set_distance_to(long value, long *distance, int sz)
273 {
274 int i;
275
276 for (i = 0; i < sz; i++)
277 distance[i] = value;
278
279 return distance;
280 }
281
282 /* compare distance, distance; return
283 * -1 if distance1 < distance2
284 * 0 if distance1 == distance2
285 * 1 if distance1 > distance2
286 */
287 static int
cmp_arg_score(long * distance1,long * distance2,int sz)288 cmp_arg_score(long *distance1, long *distance2, int sz)
289 {
290 int i;
291 if (*distance1 != INF_DISTANCE && *distance2 == INF_DISTANCE) {
292 return -1;
293 } else if (*distance1 == INF_DISTANCE && *distance2 != INF_DISTANCE) {
294 return 1;
295 } else if (*distance1 == INF_DISTANCE && *distance2 == INF_DISTANCE) {
296 return 0;
297 }
298
299 for (i = 0; i < sz; ++i) {
300 if (distance1[i] < distance2[i])
301 return -1;
302 else if (distance1[i] > distance2[i])
303 return 1;
304 }
305 return 0;
306 }
307
308 static int
find_best_generic(int gnr,ITEM * list,int arg_cnt,int try_device,LOGICAL chk_elementals)309 find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device,
310 LOGICAL chk_elementals)
311 {
312 int gndsc, nmptr;
313 int sptr;
314 int sptrgen;
315 int found;
316 int bind;
317 int found_bind;
318 int func;
319 long *argdistance;
320 long *min_argdistance = 0;
321 int distance_sz;
322 LOGICAL gnr_in_active_scope;
323 int dscptr;
324 int paramct, curr_paramct;
325 SPTR found_sptrgen, func_sptrgen;
326
327 /* find the generic's max nbr of formal args and use it to compute
328 * the size of the arg distatnce data item.
329 */
330 paramct = 0;
331 for (sptr = first_hash(gnr); sptr > NOSYM; sptr = HASHLKG(sptr)) {
332 sptrgen = sptr;
333 while (STYPEG(sptrgen) == ST_ALIAS)
334 sptrgen = SYMLKG(sptrgen);
335 for (gndsc = GNDSCG(sptrgen); gndsc; gndsc = SYMI_NEXT(gndsc)) {
336 func = SYMI_SPTR(gndsc);
337 while (STYPEG(func) == ST_MODPROC || STYPEG(func) == ST_ALIAS) {
338 /* Need to get the actual routine symbol in order to
339 * access the arguments and number of arguments of the routine.
340 */
341 func = SYMLKG(func);
342 }
343 dscptr = DPDSCG(func);
344 curr_paramct = PARAMCTG(func);
345 if (curr_paramct > paramct) {
346 paramct = curr_paramct;
347 }
348 }
349 }
350 /* initialize arg distance data item */
351 distance_sz = paramct / NBR_DISTANCE_ELM_BITS + 1;
352 NEW(min_argdistance, long, distance_sz);
353 (void)set_distance_to(INF_DISTANCE, min_argdistance, distance_sz);
354
355 nmptr = NMPTRG(gnr);
356
357 found = 0;
358 found_bind = 0;
359 for (sptr = first_hash(gnr); sptr > NOSYM; sptr = HASHLKG(sptr)) {
360 gnr_in_active_scope = FALSE;
361 sptrgen = sptr;
362 if (NMPTRG(sptrgen) != nmptr)
363 continue;
364 if (PRIVATEG(sptr) && gbl.currmod && SCOPEG(sptr) != gbl.currmod)
365 continue;
366 while (STYPEG(sptrgen) == ST_ALIAS)
367 sptrgen = SYMLKG(sptrgen);
368 if (STYPEG(sptrgen) != ST_USERGENERIC)
369 continue;
370 /* is the original symbol (sptr, not sptrgen) in an active scope */
371 if (test_scope(sptr) >= 0 ||
372 (STYPEG(SCOPEG(sptr)) == ST_MODULE && !PRIVATEG(SCOPEG(sptr)))) {
373 gnr_in_active_scope = TRUE;
374 }
375 if (!gnr_in_active_scope && !CLASSG(sptrgen))
376 continue;
377 if (GNCNTG(sptrgen) == 0 && GTYPEG(sptrgen)) {
378 continue; /* Could be an overloaded type */
379 }
380 if (queue_generic_tbp_once(sptrgen)) {
381 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_GENERIC);
382 }
383 if (GNCNTG(sptrgen) == 0 && !IS_TBP(sptrgen)) {
384 /* Ignore if generic tbp overloads sptrgen. This might be
385 * an overloaded intrinsic. We check for an overloaded intrinsic
386 * below.
387 */
388
389 E155("Empty generic procedure -", SYMNAME(sptr));
390 }
391
392 for (gndsc = GNDSCG(sptrgen); gndsc; gndsc = SYMI_NEXT(gndsc)) {
393 func = SYMI_SPTR(gndsc);
394 func_sptrgen = sptrgen;
395 if (IS_TBP(func)) {
396 /* For generic type bound procedures, use the implementation
397 * of the generic bind name for the argument comparison.
398 */
399 int mem, dty;
400 bind = func;
401 dty = TBPLNKG(func /*sptrgen*/);
402 func = get_implementation(dty, func, 0, &mem);
403 if (STYPEG(BINDG(mem)) == ST_OPERATOR ||
404 STYPEG(BINDG(mem)) == ST_USERGENERIC) {
405 mem = get_specific_member(dty, func);
406 func = VTABLEG(mem);
407 bind = BINDG(mem);
408 }
409 if (!func)
410 continue;
411 mem = get_generic_member(dty, bind);
412 if (NOPASSG(mem) && generic_tbp_has_pass_and_nopass(dty, BINDG(mem)))
413 continue;
414 if (mem && PRIVATEG(mem) && SCOPEG(stb.curr_scope) != SCOPEG(mem))
415 continue;
416 } else
417 bind = 0;
418 if (STYPEG(func) == ST_MODPROC) {
419 func = SYMLKG(func);
420 if (func == 0)
421 continue;
422 }
423 if (STYPEG(func) == ST_ALIAS)
424 func = SYMLKG(func);
425 if (chk_elementals && ELEMENTALG(func)) {
426 argdistance =
427 args_match(func, arg_cnt, distance_sz, list, TRUE, try_device == 1);
428 } else {
429 argdistance = args_match(func, arg_cnt, distance_sz, list, FALSE,
430 try_device == 1);
431 }
432 if (found && func && found != func && *min_argdistance != INF_DISTANCE &&
433 !is_conflicted_generic(func_sptrgen, found_sptrgen) &&
434 cmp_arg_score(argdistance, min_argdistance, distance_sz) == 0) {
435 int len;
436 char *name, *name_cpy;
437 len = strlen(SYMNAME(gnr)) + 1;
438 name_cpy = getitem(0, len);
439 strcpy(name_cpy, SYMNAME(gnr));
440 name = strchr(name_cpy, '$');
441 if (name)
442 *name = '\0';
443 E155("Ambiguous interfaces for generic procedure", name_cpy);
444 FREE(argdistance);
445 break;
446 } else if (cmp_arg_score(argdistance, min_argdistance, distance_sz) ==
447 -1) {
448 FREE(min_argdistance);
449 min_argdistance = argdistance;
450 found = func;
451 found_bind = bind;
452 found_sptrgen = sptrgen;
453 } else {
454 FREE(argdistance);
455 }
456 }
457 }
458 FREE(min_argdistance);
459 found = (found_bind) ? found_bind : found;
460 return found;
461 }
462
463 /*
464 * Possible return values:
465 * -1 : generic resolves to a struct constructor
466 * 0 : error
467 * >0 : sptr of the 'specific'
468 */
469 static int
resolve_generic(int gnr,SST * stktop,ITEM * list)470 resolve_generic(int gnr, SST *stktop, ITEM *list)
471 {
472 int nmptr;
473 int arg_cnt;
474 ITEM *itemp;
475 SST *sp;
476 int sptr;
477 int found;
478 int try_device = 0;
479
480 arg_cnt = 0;
481 for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
482 arg_cnt++;
483 sp = itemp->t.stkp;
484 if (SST_IDG(sp) == S_TRIPLE) {
485 /* form is e1:e2:e3 */
486 error(76, 3, gbl.lineno, SYMNAME(gnr), CNULL);
487 return 0;
488 }
489 if (SST_IDG(sp) == S_ACONST) {
490 mkexpr(sp);
491 }
492 }
493 #if DEBUG
494 if (DBGBIT(3, 256))
495 fprintf(gbl.dbgfil, "resolve_generic: %s, count %d\n", SYMNAME(gnr),
496 arg_cnt);
497 #endif
498
499 nmptr = NMPTRG(gnr);
500 /* search HASH list for all user generics of the same name */
501 {
502 if ((found = find_best_generic(gnr, list, arg_cnt, try_device, FALSE))) {
503 return found;
504 }
505 }
506
507 if ((found = find_best_generic(gnr, list, arg_cnt, 0, TRUE))) {
508 return found;
509 }
510
511 /* search HASH list for intrinsic generic of the same name */
512 for (sptr = gnr; sptr; sptr = HASHLKG(sptr)) {
513 if (NMPTRG(sptr) == nmptr && IS_INTRINSIC(STYPEG(sptr)) &&
514 sptr < stb.firstosym) {
515 return sptr;
516 }
517 }
518 if (STYPEG(gnr) == ST_ENTRY || STYPEG(gnr) == ST_PROC) {
519 /* allow specific name to be used also */
520 return gnr;
521 }
522 if (CLASSG(gnr)) {
523 char *name_cpy, *name;
524 name_cpy = getitem(0, strlen(SYMNAME(gnr)) + 1);
525 strcpy(name_cpy, SYMNAME(gnr));
526 name = strchr(name_cpy, '$');
527 if (name)
528 *name = '\0';
529 E155("Could not resolve generic type bound procedure", name_cpy);
530 }
531 if (GTYPEG(gnr)) {
532 ACL *aclp, *hd, *tl;
533 /*
534 * build the ACL list from the list of arguments
535 */
536 hd = tl = NULL;
537 for (itemp = list; itemp != ITEM_END; itemp = itemp->next) {
538 sp = itemp->t.stkp;
539 if (SST_IDG(sp) == S_ACONST || SST_IDG(sp) == S_SCONST) {
540 aclp = SST_ACLG(sp);
541 } else {
542 /* put in ACL */
543 aclp = GET_ACL(15);
544 aclp->id = AC_EXPR;
545 aclp->repeatc = aclp->size = 0;
546 aclp->next = NULL;
547 aclp->subc = NULL;
548 aclp->u1.stkp = sp;
549 }
550 if (!hd) {
551 hd = aclp;
552 } else {
553 tl->next = aclp;
554 }
555 tl = aclp;
556 }
557 sptr = GTYPEG(gnr);
558 /* create head AC_SCONST for element list */
559 aclp = GET_ACL(15);
560 aclp->id = AC_SCONST;
561 aclp->next = NULL;
562 aclp->subc = hd;
563 aclp->dtype = DTYPEG(sptr);
564 SST_IDP(stktop, S_SCONST);
565 SST_DTYPEP(stktop, aclp->dtype);
566 SST_ACLP(stktop, aclp);
567 chk_struct_constructor(aclp);
568 SST_SYMP(stktop, sptr);
569 return -1; /* generic resolves to a struct constructor */
570 }
571 if (CLASSG(gnr)) {
572 char *name_cpy, *name;
573 name_cpy = getitem(0, strlen(SYMNAME(gnr)) + 1);
574 strcpy(name_cpy, SYMNAME(gnr));
575 name = strchr(name_cpy, '$');
576 if (name)
577 *name = '\0';
578 E155("Could not resolve generic type bound procedure", name_cpy);
579 } else
580 E155("Could not resolve generic procedure", SYMNAME(gnr));
581 return 0;
582 }
583
584 /*
585 * check if arguments passed to a generic match the arguments of the given
586 * specific.
587 */
588 static long *
args_match(int ext,int count,int distance_sz,ITEM * list,LOGICAL elemental,LOGICAL usedevcopy)589 args_match(int ext, int count, int distance_sz, ITEM *list, LOGICAL elemental,
590 LOGICAL usedevcopy)
591 {
592 int dscptr;
593 int paramct;
594 int actual_cnt;
595 int i;
596 char *kwd_str; /* where keyword string for 'ext' is stored */
597 long arg_distance;
598 long *distance;
599
600 NEW(distance, long, distance_sz);
601
602 dscptr = DPDSCG(ext);
603 paramct = PARAMCTG(ext);
604
605 if (count == 0 && paramct == 0)
606 return set_distance_to(MIN_DISTANCE, distance, distance_sz);
607 if (count > paramct)
608 return set_distance_to(INF_DISTANCE, distance, distance_sz);
609 kwd_str = make_kwd_str(ext);
610 if (!kwd_match(list, paramct, kwd_str)) {
611 FREE(kwd_str);
612 return set_distance_to(INF_DISTANCE, distance, distance_sz);
613 }
614 FREE(kwd_str);
615
616 (void)set_distance_to(MIN_DISTANCE, distance, distance_sz);
617 for (i = 0, actual_cnt = 0; i < paramct && actual_cnt < count;
618 i++, dscptr++) {
619 SST *sp;
620 int dum;
621 int actual;
622 int arg;
623 int distance_dx;
624 sp = ARG_STK(i);
625 if (sp) {
626 (void)chkarg(sp, &dum);
627 XFR_ARGAST(i);
628 }
629 actual = ARG_AST(i);
630 arg = *(aux.dpdsc_base + dscptr);
631 if (arg) {
632 if (actual) {
633 actual_cnt++;
634 arg_distance = tkr_match(arg, sp, actual, elemental);
635 if (arg_distance == INF_DISTANCE) {
636 return set_distance_to(INF_DISTANCE, distance, distance_sz);
637 } else {
638 DISTANCE_ELM(distance, i) =
639 (DISTANCE_ELM(distance, i) << UNIT_SZ) + arg_distance;
640 }
641 } else {
642 DISTANCE_ELM(distance, i) =
643 (DISTANCE_ELM(distance, i) << UNIT_SZ) + MIN_DISTANCE;
644 }
645 } else if (actual == 0 || A_TYPEG(actual) != A_LABEL) {
646 /* alternate returns */
647 return set_distance_to(INF_DISTANCE, distance, distance_sz);
648 }
649 }
650
651 return distance;
652 }
653
654 /* Check TYPE-KIND-RANK */
655 static int
tkr_match(int formal,SST * opnd,int actual,int elemental)656 tkr_match(int formal, SST *opnd, int actual, int elemental)
657 {
658 int ddum, dact, elddum, eldact;
659 int rank;
660 int sptr;
661 LOGICAL match_found;
662 int mng_match;
663 LOGICAL formal_assumesz = FALSE;
664
665 if (!ignore_tkr(formal, IGNORE_M) && ast_is_sym(actual)) {
666 sptr = memsym_of_ast(actual);
667 if ( (ALLOCATTRG(formal) && !ALLOCATTRG(sptr)) ||
668 (POINTERG(formal) && !POINTERG(sptr)) ) {
669 return INF_DISTANCE;
670 }
671 }
672
673 mng_match = 0;
674 ddum = DTYPEG(formal);
675 elddum = DDTG(ddum);
676 get_type_rank(opnd, &dact, &rank);
677 eldact = DDTG(dact);
678 if (elemental) {
679 dact = eldact;
680 rank = 0;
681 }
682 if (STYPEG(formal) == ST_PROC) {
683 if (actual == 0)
684 return INF_DISTANCE;
685 /* actual must be an ID that is another PROC or ENTRY */
686 if (A_TYPEG(actual) != A_ID)
687 return INF_DISTANCE;
688 sptr = A_SPTRG(actual);
689 if (STYPEG(sptr) != ST_PROC && STYPEG(sptr) != ST_ENTRY &&
690 !IS_INTRINSIC(STYPEG(sptr)))
691 return INF_DISTANCE;
692 } else if (A_TYPEG(actual) == A_ID && (STYPEG(A_SPTRG(actual)) == ST_PROC ||
693 STYPEG(A_SPTRG(actual)) == ST_ENTRY) &&
694 !IS_INTRINSIC(STYPEG(A_SPTRG(actual)))) {
695 /* formal is not an ST_PROC, so return INF_DISTANCE */
696 return INF_DISTANCE;
697 }
698 if (!ignore_tkr(formal, IGNORE_R)) {
699 if (DTY(ddum) == TY_ARRAY) {
700 if (AD_NUMDIM(AD_DPTR(ddum)) != rank) {
701 if (rank && AD_ASSUMSZ(AD_DPTR(ddum)) &&
702 AD_NUMDIM(AD_DPTR(ddum)) == 1) {
703 formal_assumesz = TRUE;
704 } else {
705 return INF_DISTANCE;
706 }
707 }
708 } else /* formal is not an array */
709 if (rank)
710 return INF_DISTANCE;
711 }
712
713 if (STYPEG(formal) == ST_PROC) {
714 if (IS_INTRINSIC(STYPEG(sptr))) {
715 setimplicit(sptr);
716 dact = DTYPEG(sptr);
717 /* TBD: should EXPST be set??? */
718 }
719 if (ddum == 0) {
720 /* formal has no datatype; was the actual really typed? */
721 if (DCLDG(sptr) && DTYPEG(sptr)) /* actual was given a datatype */
722 return INF_DISTANCE;
723 return EXACT_MATCH + mng_match;
724 }
725 if (dact == 0) {
726 /* actual has no datatype; was the formal explicitly typed? */
727 if (DCLDG(formal) && DTYPEG(formal)) /* formal was declared */
728 return INF_DISTANCE;
729 return EXACT_MATCH + mng_match;
730 }
731 if (!DCLDG(formal) && !FUNCG(formal) && !DCLDG(sptr) && !FUNCG(sptr))
732 /* formal & actual are subroutines?? */
733 return EXACT_MATCH + mng_match;
734 }
735
736 /* check if type and kind of the data types match */
737 if (DTY(elddum) != DTY(eldact)) {
738 /* element TY_ values are not the same */
739 if (ignore_tkr(formal, IGNORE_K)) {
740 if (same_type_different_kind(elddum, eldact))
741 return EXACT_MATCH + mng_match;
742 } else if (ignore_tkr(formal, IGNORE_T) &&
743 different_type_same_kind(elddum, eldact))
744 return EXACT_MATCH + mng_match;
745 }
746 if (ignore_tkr(formal, IGNORE_T)) {
747 if (ignore_tkr(formal, IGNORE_K))
748 return EXACT_MATCH + mng_match;
749 /* cannot ignore the kind, so it must be the same! */
750 if (different_type_same_kind(elddum, eldact))
751 return EXACT_MATCH + mng_match;
752 }
753
754 /* check for an exact match first */
755 if (tk_match_arg(ddum, dact, FALSE)) {
756 return formal_assumesz ? EXTND_MATCH + mng_match : EXACT_MATCH + mng_match;
757 } else if (tk_match_arg(ddum, dact, CLASSG(formal))) {
758 return EXTND_MATCH + mng_match;
759 } else if (DTY(elddum) == TY_DERIVED && UNLPOLYG(DTY(elddum + 3))) {
760 /* Dummy argument is declared CLASS(*), so it can
761 * take any rank compatible actual argument.
762 */
763 return formal_assumesz ? EXTND_MATCH + mng_match : EXACT_MATCH + mng_match;
764 }
765 return INF_DISTANCE;
766 }
767
768 static LOGICAL
kwd_match(ITEM * list,int cnt,char * kwdarg)769 kwd_match(ITEM *list, /* list of arguments */
770 int cnt, /* maximum number of arguments allowed for intrinsic */
771 char *kwdarg /* string defining position and keywords of arguments*/
772 )
773 {
774 SST *stkp;
775 int pos;
776 int i;
777 char *kwd, *np;
778 int kwd_len;
779 char *actual_kwd; /* name of keyword used with the actual arg */
780 int actual_kwd_len;
781 LOGICAL kwd_present;
782
783 /*
784 * NOTE: 'variable' arguments (see get_kwd_args in semfunc2.c)
785 * will not be seen for user-defined interfaces.
786 */
787
788 kwd_present = FALSE;
789 sem.argpos = (argpos_t *)getitem(0, sizeof(argpos_t) * cnt);
790
791 for (i = 0; i < cnt; i++) {
792 ARG_STK(i) = NULL;
793 ARG_AST(i) = 0;
794 }
795
796 for (pos = 0; list != ITEM_END; list = list->next, pos++) {
797 stkp = list->t.stkp;
798 if (SST_IDG(stkp) == S_KEYWORD) {
799 kwd_present = TRUE;
800 actual_kwd = scn.id.name + SST_CVALG(stkp);
801 actual_kwd_len = strlen(actual_kwd);
802 kwd = kwdarg;
803 for (i = 0; TRUE; i++) {
804 #if DEBUG
805 assert(*kwd != '#', "kwd_match, unexp. #", pos, 3);
806 #endif
807 if (*kwd == '*')
808 kwd++;
809 kwd_len = 0;
810 for (np = kwd; TRUE; np++, kwd_len++)
811 if (*np == ' ' || *np == '\0')
812 break;
813 if (kwd_len == actual_kwd_len &&
814 strncmp(kwd, actual_kwd, actual_kwd_len) == 0)
815 break;
816 if (*np == '\0')
817 return FALSE;
818 kwd = np + 1; /* skip over blank */
819 }
820 if (ARG_STK(i))
821 return FALSE;
822 stkp = SST_E3G(stkp);
823 ARG_STK(i) = stkp;
824 ARG_AST(i) = SST_ASTG(stkp);
825 } else {
826 if (ARG_STK(pos)) {
827 kwd = kwdarg;
828 for (i = 0; TRUE; i++) {
829 if (*kwd == '*' || *kwd == ' ')
830 kwd++;
831 if (*kwd == '\0')
832 return FALSE;
833 kwd_len = 0;
834 for (np = kwd; TRUE; np++) {
835 if (*np == ' ' || *np == '\0')
836 break;
837 kwd_len++;
838 }
839 if (i == pos)
840 break;
841 kwd = np;
842 }
843 return FALSE;
844 }
845 ARG_STK(pos) = stkp;
846 ARG_AST(pos) = SST_ASTG(stkp);
847 }
848 }
849
850 /* determine if required argument is not present */
851
852 kwd = kwdarg;
853 for (pos = 0; pos < cnt; pos++, kwd = np) {
854 if (*kwd == ' ')
855 kwd++;
856 if (*kwd == '#' || *kwd == '!')
857 break;
858 kwd_len = 0;
859 for (np = kwd; TRUE; np++) {
860 if (*np == ' ' || *np == '\0')
861 break;
862 kwd_len++;
863 }
864 if (*kwd == '*')
865 continue;
866 if (ARG_STK(pos) == NULL)
867 return FALSE;
868 }
869
870 return TRUE;
871 }
872
873 int
defined_operator(int opr,SST * stktop,SST * lop,SST * rop)874 defined_operator(int opr, SST *stktop, SST *lop, SST *rop)
875 {
876 int sptr;
877 ITEM *list;
878 int i;
879
880 #if DEBUG
881 if (DBGBIT(3, 256))
882 fprintf(gbl.dbgfil, "user operator %s\n", SYMNAME(opr));
883 #endif
884 if (queue_generic_tbp_once(0))
885 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_GENERIC);
886 if (STYPEG(opr) != ST_OPERATOR) {
887 i = findByNameStypeScope(SYMNAME(opr), ST_OPERATOR, stb.curr_scope);
888 if (i) {
889 opr = i;
890 }
891 }
892 sptr = resolve_operator(opr, lop, rop);
893 if (sptr == 0) {
894 SST_IDP(stktop, S_CONST);
895 SST_DTYPEP(stktop, DT_INT);
896 return 1;
897 }
898 #if DEBUG
899 if (DBGBIT(3, 256))
900 fprintf(gbl.dbgfil, "user operator resolved to %s\n", SYMNAME(sptr));
901 #endif
902
903 list = make_list(lop, rop);
904 mkident(stktop);
905 SST_SYMP(stktop, sptr);
906 SST_DTYPEP(stktop, DTYPEG(sptr));
907 SST_ASTP(stktop, mk_id(sptr));
908 return func_call2(stktop, list, 1);
909 }
910
911 static int
resolve_operator(int opr,SST * lop,SST * rop)912 resolve_operator(int opr, SST *lop, SST *rop)
913 {
914 int func;
915 #if DEBUG
916 if (DBGBIT(3, 256))
917 fprintf(gbl.dbgfil, "resolve_operator: %s, count %d\n", SYMNAME(opr),
918 rop == NULL ? 1 : 2);
919 #endif
920 func = find_operator(opr, lop, rop, FALSE);
921 if (func != 0) {
922 return func;
923 }
924 /* Redo the search, this time allow type matching for elemental subprograms */
925 func = find_operator(opr, lop, rop, TRUE);
926 if (func != 0) {
927 return func;
928 }
929
930 /* Overloading did not occur; issue error message only if this is not
931 * an intrinsic operator.
932 */
933 if (INKINDG(opr) == 0) {
934 if (GNCNTG(opr) == 0) {
935 E155("Empty operator -", SYMNAME(opr));
936 } else {
937 E155("Could not resolve operator", SYMNAME(opr));
938 }
939 }
940 return 0;
941 }
942
943 static int
find_operator(int opr,SST * lop,SST * rop,LOGICAL elemental)944 find_operator(int opr, SST *lop, SST *rop, LOGICAL elemental)
945 {
946 int sptr;
947 int opnd_cnt = rop == NULL ? 1 : 2;
948 int nmptr = NMPTRG(opr);
949 for (sptr = first_hash(opr); sptr; sptr = HASHLKG(sptr)) {
950 int gndsc;
951 int sptrgen = sptr;
952 if (NMPTRG(sptrgen) != nmptr)
953 continue;
954 if (STYPEG(sptrgen) == ST_ALIAS)
955 sptrgen = SYMLKG(sptrgen);
956 if (STYPEG(sptrgen) != ST_OPERATOR)
957 continue;
958 /* is the ST_OPERATOR or ST_ALIAS in an active scope */
959 if (test_scope(sptr) < 0 && !CLASSG(sptrgen))
960 continue;
961
962 for (gndsc = GNDSCG(sptrgen); gndsc; gndsc = SYMI_NEXT(gndsc)) {
963 int dscptr;
964 int paramct;
965 int bind;
966 int func = SYMI_SPTR(gndsc);
967 if (IS_TBP(func)) {
968 /* For generic type bound procedures, use the implementation
969 * of the generic bind name for the argument comparison.
970 */
971 int mem, dty;
972 bind = func;
973 dty = TBPLNKG(func);
974 func = get_implementation(dty, func, 0, &mem);
975 if (STYPEG(BINDG(mem)) == ST_OPERATOR ||
976 STYPEG(BINDG(mem)) == ST_USERGENERIC) {
977 mem = get_specific_member(dty, func);
978 func = VTABLEG(mem);
979 bind = BINDG(mem);
980 }
981 if (!func)
982 continue;
983 mem = get_generic_member(dty, bind);
984 if (mem && PRIVATEG(mem) && SCOPEG(stb.curr_scope) != SCOPEG(mem))
985 continue;
986 } else {
987 bind = 0;
988 }
989 if (STYPEG(func) == ST_MODPROC) {
990 func = SYMLKG(func);
991 if (func == 0)
992 continue;
993 }
994 if (STYPEG(func) == ST_ALIAS)
995 func = SYMLKG(func);
996 paramct = PARAMCTG(func);
997
998 if (paramct != opnd_cnt) {
999 if (!bind) {
1000 continue;
1001 } else {
1002 dscptr = DPDSCG(func);
1003 if (paramct == 2 && opnd_cnt == 1) {
1004 int arg = *(aux.dpdsc_base + dscptr + 1);
1005 if (!CCSYMG(arg) || !CLASSG(arg))
1006 continue;
1007 } else if (paramct == 4 && opnd_cnt == 2) {
1008 int arg = *(aux.dpdsc_base + dscptr + 2);
1009 if (!CCSYMG(arg) || !CLASSG(arg))
1010 continue;
1011 arg = *(aux.dpdsc_base + dscptr + 3);
1012 if (!CCSYMG(arg) || !CLASSG(arg))
1013 continue;
1014 } else {
1015 continue;
1016 }
1017 }
1018 }
1019 dscptr = DPDSCG(func);
1020 if (!elemental || ELEMENTALG(func)) {
1021 int arg = *(aux.dpdsc_base + dscptr);
1022 if (arg && (tkr_match(arg, lop, 0, elemental) == INF_DISTANCE))
1023 continue;
1024 if (rop != NULL) {
1025 int arg = *(aux.dpdsc_base + dscptr + 1);
1026 if (arg && (tkr_match(arg, rop, 0, elemental) == INF_DISTANCE))
1027 continue;
1028 }
1029 return bind ? bind : func;
1030 }
1031 }
1032 }
1033 return 0; // not found
1034 }
1035
1036 void
init_intrinsic_opr(void)1037 init_intrinsic_opr(void)
1038 {
1039 int i;
1040
1041 for (i = 0; i <= OP_VAL; i++)
1042 optab[i].opr = 0;
1043 }
1044
1045 void
bind_intrinsic_opr(int val,int opr)1046 bind_intrinsic_opr(int val, int opr)
1047 {
1048 optab[val].opr = opr;
1049 INKINDP(opr, 1); /* intrinsic or assignment operator */
1050 PDNUMP(opr, val); /* OP_... value */
1051 }
1052
1053 static int
tkn_alias_sym(int tkn_alias)1054 tkn_alias_sym(int tkn_alias)
1055 {
1056 int sym;
1057 switch (tkn_alias) {
1058 case TK_XORX:
1059 sym = getsymbol("x");
1060 break;
1061 case TK_XOR:
1062 sym = getsymbol("xor");
1063 break;
1064 case TK_ORX:
1065 sym = getsymbol("o");
1066 break;
1067 case TK_NOTX:
1068 sym = getsymbol("n");
1069 break;
1070 default:
1071 interr("tkn_alias_sym: no token", 0, 3);
1072 sym = getsymbol("..zz");
1073 }
1074 return sym;
1075 }
1076
1077 int
get_intrinsic_oprsym(int val,int tkn_alias)1078 get_intrinsic_oprsym(int val, int tkn_alias)
1079 {
1080 int sym;
1081 if (!tkn_alias)
1082 sym = getsymbol(optab[val].name);
1083 else
1084 sym = tkn_alias_sym(tkn_alias);
1085 return sym;
1086 }
1087
1088 int
get_intrinsic_opr(int val,int tkn_alias)1089 get_intrinsic_opr(int val, int tkn_alias)
1090 {
1091 int opr;
1092 opr = get_intrinsic_oprsym(val, tkn_alias);
1093 opr = declsym(opr, ST_OPERATOR, FALSE);
1094 bind_intrinsic_opr(val, opr);
1095
1096 return opr;
1097 }
1098
1099 LOGICAL
is_intrinsic_opr(int val,SST * stktop,SST * lop,SST * rop,int tkn_alias)1100 is_intrinsic_opr(int val, SST *stktop, SST *lop, SST *rop, int tkn_alias)
1101 {
1102 /* tkn_alias is currently not referenced */
1103 int opr;
1104 int func;
1105 ITEM *list;
1106 int rank, dtype;
1107 char buf[100];
1108
1109 opr = optab[val].opr;
1110 if (opr) {
1111 func = resolve_operator(opr, lop, rop);
1112 if (!func && /*IN_MODULE*/ sem.mod_cnt && sem.which_pass) {
1113 if (queue_generic_tbp_once(0))
1114 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_GENERIC);
1115 func = resolve_operator(opr, lop, rop);
1116 }
1117 if (CLASSG(func) && IS_TBP(func)) {
1118 int ast, mem, inv;
1119 get_implementation(TBPLNKG(func), func, 0, &mem);
1120 if (NOPASSG(mem)) {
1121 if (val != OP_ST) {
1122 E155("Type bound procedure with NOPASS attribute not valid "
1123 "for generic operator",
1124 SYMNAME(opr));
1125 } else {
1126 E155("Type bound procedure with NOPASS attribute not valid "
1127 "for generic assignment",
1128 SYMNAME(opr));
1129 }
1130 inv = 0;
1131 } else {
1132 inv = get_tbp_argno(func, TBPLNKG(func));
1133 }
1134 if (inv < 1 || inv > 2) {
1135 if (val != OP_ST) {
1136 E155("Invalid type bound procedure in generic set "
1137 "for generic operator",
1138 SYMNAME(opr));
1139 } else {
1140 E155("Invalid type bound procedure in generic set "
1141 "for generic assignment",
1142 SYMNAME(opr));
1143 }
1144 inv = 0;
1145 }
1146 list = make_list(lop, rop);
1147 if (rop != NULL && (inv == 1 || inv == 2)) {
1148 if (SST_IDG(rop) == S_SCONST) {
1149 /* Support operator look up with structure
1150 * constructor argument on RHS.
1151 */
1152 int tmp = getccsym_sc('d', sem.dtemps++, ST_VAR, SC_LOCAL);
1153 DTYPEP(tmp, SST_DTYPEG(rop));
1154 ast = mk_id(tmp);
1155 } else if (inv == 1) {
1156 mkexpr(lop);
1157 ast = SST_ASTG(lop);
1158 if (A_TYPEG(ast) == A_INTR) {
1159 mkexpr(rop);
1160 ast = SST_ASTG(rop);
1161 }
1162
1163 } else {
1164 mkexpr(rop);
1165 ast = SST_ASTG(rop);
1166 if (A_TYPEG(ast) == A_INTR) {
1167 mkexpr(lop);
1168 ast = SST_ASTG(lop);
1169 }
1170 }
1171 } else {
1172 mkexpr(lop);
1173 ast = SST_ASTG(lop);
1174 }
1175 ast = mkmember(TBPLNKG(func), ast, NMPTRG(mem));
1176 SST_ASTP(stktop, ast);
1177 SST_SYMP(stktop, -func);
1178 if (val == OP_ST)
1179 subr_call2(stktop, list, 1);
1180 else
1181 func_call2(stktop, list, 1);
1182 return TRUE;
1183 }
1184 if (func != 0) {
1185 #if DEBUG
1186 if (DBGBIT(3, 256))
1187 fprintf(gbl.dbgfil, "intrinsic operator resolved to %s\n",
1188 SYMNAME(func));
1189 #endif
1190 list = make_list(lop, rop);
1191 mkident(stktop);
1192 SST_SYMP(stktop, -func);
1193 if (val == OP_ST)
1194 subr_call2(stktop, list, 1);
1195 else {
1196 SST_ASTP(stktop, mk_id(func));
1197 SST_DTYPEP(stktop, DTYPEG(func));
1198 func_call2(stktop, list, 1);
1199 }
1200 return TRUE;
1201 }
1202 }
1203
1204 /* Check for illegal use of an operator on a derived type. */
1205 if (val == OP_ST) /* Assignment is ok. */
1206 return FALSE;
1207 get_type_rank(lop, &dtype, &rank);
1208 if (DTYG(dtype) == TY_DERIVED) {
1209 /*
1210 * (reference f20848) - long ago, semgnr.c spelled .ne. as "!=".
1211 * As a consequence, operator(/=) would show up as != in the
1212 * symbol table and propagated to .mod files, such as
1213 * iso_c_binding. Fixing semgnr means that we will fail to
1214 * process '!=' from mod files; interf.c needs to change '!=' to '/=';
1215 * and the mod file version needs to incremented. SO, just hack the
1216 * error message when appropriate.
1217 */
1218 if (strcmp(optab[val].name, "!="))
1219 sprintf(buf, "operator %s on a derived type", optab[val].name);
1220 else
1221 sprintf(buf, "operator %s on a derived type", "/=");
1222 error(99, 3, gbl.lineno, buf, CNULL);
1223 } else if (rop != NULL) {
1224 get_type_rank(rop, &dtype, &rank);
1225 if (DTYG(dtype) == TY_DERIVED) {
1226 if (strcmp(optab[val].name, "!="))
1227 sprintf(buf, "operator %s on a derived type", optab[val].name);
1228 else
1229 sprintf(buf, "operator %s on a derived type", "/=");
1230 error(99, 3, gbl.lineno, buf, CNULL);
1231 }
1232 }
1233 return FALSE;
1234 }
1235
1236 static void
get_type_rank(SST * stkptr,int * dt_p,int * rank_p)1237 get_type_rank(SST *stkptr, int *dt_p, int *rank_p)
1238 {
1239 int dtype;
1240 int sptr;
1241 int shape;
1242
1243 dtype = 0;
1244 shape = 0;
1245 switch (SST_IDG(stkptr)) {
1246 case S_IDENT:
1247 sptr = SST_SYMG(stkptr);
1248 switch (STYPEG(sptr)) {
1249 case ST_INTRIN:
1250 case ST_GENERIC:
1251 case ST_PD:
1252 if (!EXPSTG(sptr)) {
1253 /* Not a frozen intrinsic, so assume its a variable */
1254 sptr = newsym(sptr);
1255 STYPEP(sptr, ST_VAR);
1256 /* need storage class (local) */
1257 sem_set_storage_class(sptr);
1258 SST_SYMP(stkptr, sptr);
1259 dtype = DTYPEG(sptr);
1260 }
1261 break;
1262 case ST_UNKNOWN:
1263 case ST_IDENT:
1264 case ST_VAR:
1265 case ST_ARRAY:
1266 case ST_STRUCT:
1267 case ST_ENTRY:
1268 case ST_USERGENERIC:
1269 case ST_PROC:
1270 dtype = DTYPEG(sptr);
1271 break;
1272 default:
1273 break;
1274 }
1275 break;
1276 case S_LVALUE:
1277 case S_LOGEXPR:
1278 case S_EXPR:
1279 dtype = SST_DTYPEG(stkptr);
1280 shape = SST_SHAPEG(stkptr);
1281 break;
1282 case S_CONST:
1283 case S_SCONST:
1284 case S_ACONST:
1285 dtype = SST_DTYPEG(stkptr);
1286 break;
1287 case S_STFUNC:
1288 case S_DERIVED:
1289 dtype = DTYPEG(SST_SYMG(stkptr));
1290 break;
1291 default:
1292 break;
1293 }
1294
1295 *dt_p = dtype;
1296 *rank_p = 0;
1297
1298 if (dtype) {
1299 if (shape)
1300 *rank_p = SHD_NDIM(shape);
1301 else if (DTY(dtype) == TY_ARRAY)
1302 *rank_p = AD_NUMDIM(AD_DPTR(dtype));
1303 }
1304
1305 }
1306
1307 static ITEM *
make_list(SST * lop,SST * rop)1308 make_list(SST *lop, SST *rop)
1309 {
1310 ITEM *list;
1311
1312 list = (ITEM *)getitem(0, sizeof(ITEM));
1313 list->t.stkp = (SST *)getitem(0, sizeof(SST));
1314 *list->t.stkp = *lop;
1315
1316 if (rop != NULL) {
1317 ITEM *tmp;
1318 tmp = (ITEM *)getitem(0, sizeof(ITEM));
1319 tmp->t.stkp = (SST *)getitem(0, sizeof(SST));
1320 *tmp->t.stkp = *rop;
1321 list->next = tmp;
1322 tmp->next = ITEM_END;
1323 } else
1324 list->next = ITEM_END;
1325
1326 return list;
1327 }
1328
rw_gnr_state(RW_ROUTINE,RW_FILE)1329 void rw_gnr_state(RW_ROUTINE, RW_FILE)
1330 {
1331 int nw;
1332 RW_FD(optab, struct optabstruct, OPTABSIZE);
1333 } /* rw_gnr_state */
1334
1335 static void
defined_io_error(char * proc,int is_unformatted,char * msg,int func)1336 defined_io_error(char *proc, int is_unformatted, char *msg, int func)
1337 {
1338
1339 char *buf;
1340
1341 buf = getitem(0, strlen("for defined WRITE(UNFORMATTED), in subroutine") +
1342 strlen(msg) + 1);
1343 sprintf(buf, "for defined %s(%s), %s in subroutine",
1344 (strcmp(proc, ".read") == 0) ? "READ" : "WRITE",
1345 (is_unformatted) ? "UNFORMATTED" : "FORMATTED", msg);
1346
1347 error(155, 3, gbl.lineno, buf, SYMNAME(func));
1348 }
1349
1350 static void
check_defined_io2(char * proc,int silentmode,int chk_dtype)1351 check_defined_io2(char *proc, int silentmode, int chk_dtype)
1352 {
1353 int gnr, sptr, sptrgen;
1354 LOGICAL gnr_in_active_scope;
1355 int gn_cnt;
1356 int gndsc, nmptr;
1357 int func, paramct, dpdsc, iface, i;
1358 int psptr, dtype, tag;
1359 int mem, is_unformatted, func2;
1360 int seen_error, dtv_dtype;
1361 int extensible, found;
1362 int bind, dt_int;
1363 int second_arg_error;
1364
1365 if (!proc)
1366 return;
1367 if (XBIT(124, 0x10)) {
1368 dt_int = DT_INT8; /* -i8 */
1369 } else {
1370 dt_int = DT_INT;
1371 }
1372 if (chk_dtype) {
1373 if (DTY(chk_dtype) == TY_ARRAY)
1374 chk_dtype = DTY(chk_dtype + 1);
1375 if (DTY(chk_dtype) != TY_DERIVED)
1376 return;
1377 }
1378 gnr = getsymbol(proc);
1379 found = 0;
1380 if (STYPEG(gnr) == ST_USERGENERIC) {
1381 gnr_in_active_scope = FALSE;
1382 nmptr = NMPTRG(gnr);
1383 for (sptr = first_hash(gnr); sptr > NOSYM; sptr = HASHLKG(sptr)) {
1384 sptrgen = sptr;
1385 second_arg_error = seen_error = 0;
1386 dtv_dtype = 0;
1387 extensible = 0;
1388 if (NMPTRG(sptrgen) != nmptr)
1389 continue;
1390 if (STYPEG(sptrgen) == ST_ALIAS)
1391 sptrgen = SYMLKG(sptrgen);
1392 if (STYPEG(sptrgen) != ST_USERGENERIC)
1393 continue;
1394 /* is the original symbol (sptr, not sptrgen) in an active scope */
1395 if (test_scope(sptr)) {
1396 gnr_in_active_scope = TRUE;
1397 }
1398 if (!gnr_in_active_scope && !CLASSG(sptrgen))
1399 continue;
1400 if (GNCNTG(sptrgen) == 0 && GTYPEG(sptrgen))
1401 continue;
1402 if (queue_generic_tbp_once(sptrgen)) {
1403 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_GENERIC);
1404 }
1405
1406 for (gndsc = GNDSCG(sptrgen); gndsc; gndsc = SYMI_NEXT(gndsc)) {
1407 func = SYMI_SPTR(gndsc);
1408 is_unformatted = 0;
1409
1410 if (IS_TBP(func)) {
1411 /* For generic type bound procedures, use the implementation
1412 * of the generic bind name for the argument comparison.
1413 */
1414 int mem, dty;
1415 bind = func;
1416 dty = TBPLNKG(func);
1417
1418 func = get_implementation(dty, func, 0, &mem);
1419 if (STYPEG(BINDG(mem)) == ST_OPERATOR ||
1420 STYPEG(BINDG(mem)) == ST_USERGENERIC) {
1421 mem = get_specific_member(dty, func);
1422 func = VTABLEG(mem);
1423 bind = BINDG(mem);
1424 }
1425 if (!func)
1426 continue;
1427 mem = get_generic_member(dty, bind);
1428 if (NOPASSG(mem) && generic_tbp_has_pass_and_nopass(dty, BINDG(mem)))
1429 continue;
1430 if (mem && PRIVATEG(mem) && SCOPEG(stb.curr_scope) != SCOPEG(mem))
1431 continue;
1432 } else
1433 bind = 0;
1434
1435 for (func2 = (!bind) ? first_hash(func) : first_hash(bind);
1436 func2 > NOSYM; func2 = HASHLKG(func2)) {
1437 if (!test_scope(func2))
1438 continue;
1439 if (UNFMTG(func2)) {
1440 is_unformatted = 1;
1441 break;
1442 }
1443 }
1444 if (FVALG(func)) {
1445 seen_error++;
1446 if (!silentmode) {
1447 if (is_unformatted) {
1448 if (strcmp(proc, ".read") == 0) {
1449 error(155, 3, gbl.lineno,
1450 "The generic set for a defined"
1451 "READ(UNFORMATTED) contains non-subroutine",
1452 SYMNAME(func));
1453 } else {
1454 error(155, 3, gbl.lineno,
1455 "The generic set for a defined"
1456 "WRITE(UNFORMATTED) contains non-subroutine",
1457 SYMNAME(func));
1458 }
1459 } else {
1460 if (strcmp(proc, ".read") == 0) {
1461 error(155, 3, gbl.lineno,
1462 "The generic set for a defined"
1463 "READ(FORMATTED) contains non-subroutine",
1464 SYMNAME(func));
1465 } else {
1466 error(155, 3, gbl.lineno,
1467 "The generic set for a defined"
1468 "WRITE(FORMATTED) contains non-subroutine",
1469 SYMNAME(func));
1470 }
1471 }
1472 }
1473 continue;
1474 }
1475 paramct = dpdsc = iface = 0;
1476 if (STYPEG(func) == ST_MODPROC) {
1477 func = SYMLKG(func);
1478 if (func <= NOSYM)
1479 continue;
1480 }
1481 if (STYPEG(func) == ST_ALIAS) {
1482 func = SYMLKG(func);
1483 if (func <= NOSYM)
1484 continue;
1485 }
1486 if (STYPEG(func) != ST_PROC && STYPEG(func) != ST_ENTRY)
1487 continue;
1488
1489 proc_arginfo(func, ¶mct, &dpdsc, &iface);
1490 if (!dpdsc)
1491 continue;
1492
1493 if (paramct > 4) {
1494 psptr = *(aux.dpdsc_base + dpdsc + (paramct - 1));
1495 if (CLASSG(psptr) && CCSYMG(psptr)) {
1496 --paramct; /* don't count type descriptor arg */
1497 }
1498 }
1499
1500 if (is_unformatted && paramct == 4) {
1501 psptr = *(aux.dpdsc_base + dpdsc);
1502 dtype = DTYPEG(psptr);
1503 if (DTY(dtype) == TY_ARRAY)
1504 dtype = DTY(dtype + 1);
1505 if (DTY(dtype) != TY_DERIVED) {
1506 seen_error++;
1507 if (!silentmode)
1508 defined_io_error(proc, is_unformatted,
1509 "first argument must be a derived type", func);
1510 continue;
1511 }
1512 dtv_dtype = dtype;
1513 tag = DTY(dtype + 3);
1514 if (!CLASSG(psptr) && !CFUNCG(tag) && !SEQG(tag)) {
1515 seen_error++;
1516 if (!silentmode)
1517 defined_io_error(proc, is_unformatted,
1518 "first argument with extensible type"
1519 " must be declared CLASS",
1520 func);
1521 }
1522 if (CLASSG(psptr) && !CFUNCG(tag) && !SEQG(tag)) {
1523 extensible = 1;
1524 }
1525 if (!all_len_parms_assumed(dtype)) {
1526 seen_error++;
1527 if (!silentmode)
1528 defined_io_error(proc, is_unformatted,
1529 "all length type parameters must be assumed"
1530 " for derived type argument 1",
1531 func);
1532 }
1533 if (INTENTG(psptr) != INTENT_INOUT && INTENTG(psptr) != INTENT_IN) {
1534 seen_error++;
1535 if (!silentmode)
1536 defined_io_error(proc, is_unformatted,
1537 "first argument must be declared INTENT(IN)"
1538 " or INTENT(INOUT)",
1539 func);
1540 }
1541
1542 psptr = *(aux.dpdsc_base + dpdsc + 1);
1543 dtype = DTYPEG(psptr);
1544 if (DT_ISINT(dtype)) {
1545 dt_int = dtype;
1546 }
1547 if (dtype != dt_int) {
1548 seen_error++;
1549 second_arg_error = 1;
1550 if (!silentmode)
1551 defined_io_error(proc, is_unformatted,
1552 "second argument must be declared INTEGER",
1553 func);
1554 }
1555 if (INTENTG(psptr) != INTENT_IN) {
1556 seen_error++;
1557 if (!silentmode)
1558 defined_io_error(proc, is_unformatted,
1559 "second argument must be declared"
1560 " INTENT(IN)",
1561 func);
1562 }
1563 psptr = *(aux.dpdsc_base + dpdsc + 2);
1564 dtype = DTYPEG(psptr);
1565 if (dtype != dt_int) {
1566 seen_error++;
1567 if (!silentmode) {
1568 if (second_arg_error) {
1569 defined_io_error(proc, is_unformatted,
1570 "third argument must be declared INTEGER",
1571 func);
1572 } else {
1573 defined_io_error(proc, is_unformatted,
1574 "second and third argument must be declared "
1575 "INTEGER",
1576 func);
1577 }
1578 }
1579 }
1580 if (INTENTG(psptr) != INTENT_OUT) {
1581 seen_error++;
1582 if (!silentmode)
1583 defined_io_error(proc, is_unformatted,
1584 "third argument must be declared "
1585 "INTENT(INOUT)",
1586 func);
1587 }
1588 psptr = *(aux.dpdsc_base + dpdsc + 3);
1589 dtype = DTYPEG(psptr);
1590 if (dtype != DT_ASSCHAR) {
1591 seen_error++;
1592 if (!silentmode)
1593 defined_io_error(proc, is_unformatted,
1594 "fourth argument must be declared "
1595 "CHARACTER(LEN=*)",
1596 func);
1597 }
1598 if (INTENTG(psptr) != INTENT_INOUT) {
1599 seen_error++;
1600 if (!silentmode)
1601 defined_io_error(proc, is_unformatted,
1602 "fourth argument must be declared "
1603 "INTENT(INOUT)",
1604 func);
1605 }
1606 if (!seen_error) {
1607 /* set UFIO flag on the tag */
1608 if (strcmp(proc, ".read") == 0) {
1609 UFIOP(tag, (DT_IO_UREAD | UFIOG(tag)));
1610 } else {
1611 UFIOP(tag, (DT_IO_UWRITE | UFIOG(tag)));
1612 }
1613 if (chk_dtype && eq_dtype2(dtv_dtype, chk_dtype, extensible)) {
1614 int tag2;
1615 tag2 = DTY(chk_dtype + 3);
1616 found++;
1617 if (strcmp(proc, ".read") == 0) {
1618 UFIOP(tag2, (DT_IO_UREAD | UFIOG(tag2)));
1619 } else {
1620 UFIOP(tag2, (DT_IO_UWRITE | UFIOG(tag2)));
1621 }
1622 UFIOP(tag2, (UFIOG(tag2) & ~(DT_IO_NONE)));
1623 }
1624 }
1625 } else if (!is_unformatted && paramct == 6) {
1626 psptr = *(aux.dpdsc_base + dpdsc);
1627 dtype = DTYPEG(psptr);
1628 if (DTY(dtype) == TY_ARRAY)
1629 dtype = DTY(dtype + 1);
1630 if (DTY(dtype) != TY_DERIVED) {
1631 seen_error++;
1632 if (!silentmode)
1633 defined_io_error(proc, is_unformatted,
1634 "first argument must be a derived type", func);
1635 continue;
1636 }
1637 dtv_dtype = dtype;
1638 tag = DTY(dtype + 3);
1639 if (!CLASSG(psptr) && !CFUNCG(tag) && !SEQG(tag)) {
1640 seen_error++;
1641 if (!silentmode)
1642 defined_io_error(proc, is_unformatted,
1643 "first argument with extensible type"
1644 " must be declared CLASS",
1645 func);
1646 }
1647 if (CLASSG(psptr) && !CFUNCG(tag) && !SEQG(tag)) {
1648 extensible = 1;
1649 }
1650 if (!all_len_parms_assumed(dtype)) {
1651 seen_error++;
1652 if (!silentmode)
1653 defined_io_error(proc, is_unformatted,
1654 "all length type parameters must be assumed"
1655 " for derived type argument 1",
1656 func);
1657 }
1658 if (INTENTG(psptr) != INTENT_INOUT && INTENTG(psptr) != INTENT_IN) {
1659 seen_error++;
1660 if (!silentmode)
1661 defined_io_error(proc, is_unformatted,
1662 "first argument must be declared INTENT(IN)"
1663 " or INTENT(INOUT)",
1664 func);
1665 }
1666
1667 psptr = *(aux.dpdsc_base + dpdsc + 1);
1668 dtype = DTYPEG(psptr);
1669 if (DT_ISINT(dtype)) {
1670 dt_int = dtype;
1671 }
1672 if (dtype != dt_int) {
1673 seen_error++;
1674 second_arg_error = 1;
1675 if (!silentmode)
1676 defined_io_error(proc, is_unformatted,
1677 "second argument must be declared INTEGER",
1678 func);
1679 }
1680 if (INTENTG(psptr) != INTENT_IN) {
1681 seen_error++;
1682 if (!silentmode)
1683 defined_io_error(proc, is_unformatted,
1684 "second argument must be declared"
1685 " INTENT(IN)",
1686 func);
1687 }
1688 psptr = *(aux.dpdsc_base + dpdsc + 2);
1689 dtype = DTYPEG(psptr);
1690 if (dtype != DT_ASSCHAR) {
1691 seen_error++;
1692 if (!silentmode)
1693 defined_io_error(proc, is_unformatted,
1694 "third argument must be declared "
1695 "CHARACTER(LEN=*)",
1696 func);
1697 }
1698 if (INTENTG(psptr) != INTENT_IN) {
1699 seen_error++;
1700 if (!silentmode)
1701 defined_io_error(proc, is_unformatted,
1702 "third argument must be declared INTENT(IN)",
1703 func);
1704 }
1705 psptr = *(aux.dpdsc_base + dpdsc + 3);
1706 dtype = DTYPEG(psptr);
1707 if (DTY(dtype) != TY_ARRAY || DTY(dtype + 1) != dt_int ||
1708 !ASSUMSHPG(psptr) || rank_of_sym(psptr) != 1) {
1709 seen_error++;
1710 if (!silentmode) {
1711 if (!second_arg_error) {
1712 defined_io_error(proc, is_unformatted,
1713 "second argument must be declared INTEGER",
1714 func);
1715 }
1716 defined_io_error(proc, is_unformatted,
1717 "fourth argument must be a rank 1 assumed"
1718 " shape array of type INTEGER",
1719 func);
1720 }
1721 }
1722 if (INTENTG(psptr) != INTENT_IN) {
1723 seen_error++;
1724 if (!silentmode)
1725 defined_io_error(proc, is_unformatted,
1726 "fourth argument must be declared INTENT(IN)",
1727 func);
1728 }
1729 psptr = *(aux.dpdsc_base + dpdsc + 4);
1730 dtype = DTYPEG(psptr);
1731 if (dtype != dt_int) {
1732 seen_error++;
1733 if (!silentmode) {
1734 if (second_arg_error) {
1735 defined_io_error(proc, is_unformatted,
1736 "fifth argument must be declared INTEGER",
1737 func);
1738 } else {
1739 defined_io_error(proc, is_unformatted,
1740 "second and fifth argument must be declared "
1741 "INTEGER",
1742 func);
1743 }
1744 }
1745 }
1746 if (INTENTG(psptr) != INTENT_OUT) {
1747 seen_error++;
1748 if (!silentmode)
1749 defined_io_error(proc, is_unformatted,
1750 "fifth argument must be declared "
1751 "INTENT(OUT)",
1752 func);
1753 }
1754 psptr = *(aux.dpdsc_base + dpdsc + 5);
1755 dtype = DTYPEG(psptr);
1756 if (dtype != DT_ASSCHAR) {
1757 seen_error++;
1758 if (!silentmode)
1759 defined_io_error(proc, is_unformatted,
1760 "sixth argument must be declared "
1761 "CHARACTER(LEN=*)",
1762 func);
1763 }
1764 if (INTENTG(psptr) != INTENT_INOUT) {
1765 seen_error++;
1766 if (!silentmode)
1767 defined_io_error(proc, is_unformatted,
1768 "sixth argument must be declared "
1769 "INTENT(INOUT)",
1770 func);
1771 }
1772
1773 if (!seen_error) {
1774 /* set UFIO flag on the tag */
1775 if (strcmp(proc, ".read") == 0) {
1776 UFIOP(tag, (DT_IO_FREAD | UFIOG(tag)));
1777 } else {
1778 UFIOP(tag, (DT_IO_FWRITE | UFIOG(tag)));
1779 }
1780 if (chk_dtype && eq_dtype2(dtv_dtype, chk_dtype, extensible)) {
1781 int tag2;
1782 tag2 = DTY(chk_dtype + 3);
1783 found++;
1784 if (strcmp(proc, ".read") == 0) {
1785 UFIOP(tag2, (DT_IO_FREAD | UFIOG(tag2)));
1786 } else {
1787 UFIOP(tag2, (DT_IO_FWRITE | UFIOG(tag2)));
1788 }
1789 UFIOP(tag2, (UFIOG(tag2) & ~(DT_IO_NONE)));
1790 }
1791 }
1792 } else {
1793 seen_error++;
1794 if (!silentmode)
1795 defined_io_error(proc, is_unformatted, "invalid argument list",
1796 func);
1797 }
1798 }
1799 }
1800 }
1801 if (!found && chk_dtype) {
1802 tag = DTY(chk_dtype + 3);
1803 if (!UFIOG(tag)) {
1804 UFIOP(tag, DT_IO_NONE);
1805 }
1806 }
1807 }
1808
1809 /** \brief Return a bit mask indicating which I/O routines are defined for a
1810 derived type.
1811 */
1812 int
dtype_has_defined_io(int dtype)1813 dtype_has_defined_io(int dtype)
1814 {
1815 int tag;
1816
1817 if (DTY(dtype) == TY_ARRAY)
1818 dtype = DTY(dtype + 1);
1819 if (DTY(dtype) != TY_DERIVED)
1820 return 0;
1821
1822 tag = DTY(dtype + 3);
1823
1824 if (!UFIOG(tag)) {
1825 check_defined_io2(".read", 1, dtype);
1826 check_defined_io2(".write", 1, dtype);
1827 }
1828 return UFIOG(tag);
1829 }
1830
1831 void
check_defined_io(void)1832 check_defined_io(void)
1833 {
1834
1835 check_defined_io2(".write", 0, 0);
1836 check_defined_io2(".read", 0, 0);
1837 }
1838
1839 /**
1840 \param read_or_write 0 specifies read, 1 specifies write
1841 \param stktop SST we're processing.
1842 \param list argument list for read/write
1843 \return
1844 <pre>
1845 = -1 : error (resolves to struct constructor -- should never happen)
1846 = 0 : error or no I/O subroutine
1847 \> 0 : sptr of the 'specific' defined I/O subroutine
1848 </pre>
1849 */
1850 int
resolve_defined_io(int read_or_write,SST * stktop,ITEM * list)1851 resolve_defined_io(int read_or_write, SST *stktop, ITEM *list)
1852 {
1853 int i;
1854 int gnr = getsymbol(read_or_write ? ".write" : ".read");
1855
1856 if (STYPEG(gnr) != ST_USERGENERIC) {
1857 return 0;
1858 }
1859
1860 resolved_to_self = 0;
1861 silent_error_mode = 1;
1862 i = resolve_generic(gnr, stktop, list);
1863 silent_error_mode = 0;
1864 if (resolved_to_self) {
1865 if (i > NOSYM && !RECURG(gbl.currsub)) {
1866 error(155, 3, gbl.lineno,
1867 "Subroutines that participate in recursive"
1868 " defined I/O operations must be declared RECURSIVE -",
1869 SYMNAME(gbl.currsub));
1870 }
1871 resolved_to_self = 0;
1872 }
1873 return i;
1874 }
1875
1876 void
add_overload(int gnr,int func)1877 add_overload(int gnr, int func)
1878 {
1879 int gnidx;
1880 if (sem.defined_io_type == 2 || sem.defined_io_type == 4) {
1881 UNFMTP(func, 1);
1882 }
1883 gnidx = add_symitem(func, GNDSCG(gnr));
1884 GNDSCP(gnr, gnidx);
1885 GNCNTP(gnr, GNCNTG(gnr) + 1);
1886 #if DEBUG
1887 if (DBGBIT(3, 256))
1888 fprintf(gbl.dbgfil, "overload %s --> %s, symi_base+%d\n", SYMNAME(gnr),
1889 SYMNAME(func), gnidx);
1890 #endif
1891 }
1892
1893 void
copy_specifics(int fromsptr,int tosptr)1894 copy_specifics(int fromsptr, int tosptr)
1895 {
1896 int symi_src;
1897
1898 assert((STYPEG(fromsptr) == ST_OPERATOR || STYPEG(fromsptr) == ST_USERGENERIC) &&
1899 (STYPEG(tosptr) == ST_OPERATOR || STYPEG(tosptr) == ST_USERGENERIC),
1900 "copy_specifics src or dest not user generic or operator", 0, 3);
1901
1902 for (symi_src = GNDSCG(fromsptr); symi_src; symi_src = SYMI_NEXT(symi_src)) {
1903 /* don't copy if the specific is already in the generic's list */
1904 /* TODO: is comparison of sptrs good enough or is comparison
1905 * of nmptr and signature necessary?
1906 */
1907 int src = SYMI_SPTR(symi_src);
1908 if (!sym_in_sym_list(src, GNDSCG(tosptr))) {
1909 add_overload(tosptr, src);
1910 }
1911 }
1912 }
1913