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 /** \file
19 * \brief Utility routines used by semantic analyzer.
20 *
21 * Fortran front-end utility routines used by Semantic Analyzer to process
22 * functions, subroutines, predeclareds, statement functions, etc.
23 */
24
25 #include "gbldefs.h"
26 #include "global.h"
27 #include "error.h"
28 #include "symtab.h"
29 #include "symutl.h"
30 #include "dtypeutl.h"
31 #include "semant.h"
32 #include "scan.h"
33 #include "semstk.h"
34 #include "pd.h"
35 #include "machar.h"
36 #include "ast.h"
37 #include "rte.h"
38 #include "rtlRtns.h"
39
40 static LOGICAL get_keyword_args(ITEM *, int, char *, int, int);
41 static int get_fval_array(int);
42 static LOGICAL cmpat_arr_arg(int, int);
43 static void dump_stfunc(int);
44
45 /*---------------------------------------------------------------------*/
46
47 /*
48 routines to define statement functions and reference statement
49 functions
50 */
51
52 /* define structures needed for statement function processing: */
53
54 /** \brief Information about statement function arguments. */
55 typedef struct _arginfo {
56 int dtype; /**< data type of dummy argument */
57 int formal; /**< dummy's ast */
58 int actual; /**< ast of argument to replace corresponding dummy */
59 int save; /**< save/restore field */
60 unsigned refd : 1; /**< if set, formal is referenced */
61 struct _arginfo *next; /**< next argument info record */
62 } ARGINFO;
63
64 /** \brief Statement function used in the right-hand side. */
65 typedef struct _sfuse {
66 int node; /**< unique id ast to be replaced when invoked */
67 struct _sfdsc *dsc; /**< its statement function descriptor */
68 ARGINFO *args; /**< arguments to the statement function */
69 struct _sfuse *next; /**< next statement function used */
70 } SFUSE;
71
72 /** \brief Statement function descriptor. */
73 typedef struct _sfdsc {
74 int dtype; /**< dtype of the statement function */
75 int rhs; /**< ast of right hand side */
76 ARGINFO *args; /**< ptr to list of arginfo records */
77 SFUSE *l_use; /**< list of statement functions used in rhs */
78 } SFDSC;
79
80 /** \brief List of statement functions used in a definition.
81 *
82 * Keep track of the statement functions used in a definition and the
83 * arguments to those statement functions which need to be evaluated
84 * and saved in a temporary. The order of the list is in 'evaluation' order.
85 */
86 static SFUSE *l_sfuse = NULL;
87 static SFUSE *end_sfuse = NULL; /**< End of list -- always add here */
88
89 static void asn_sfuse(SFUSE *);
90
91 static void _non_private(int, int *);
92 static ITEM *stfunc_argl;
93
94 static int pass_position = 0;
95 static int pass_object_dummy = 0;
96
97 /** \brief Set position of type-bound procedure passed object location. */
98 void
set_pass_objects(int pos,int pod)99 set_pass_objects(int pos, int pod)
100 {
101 pass_position = pos;
102 pass_object_dummy = pod;
103 }
104
105 /** \brief Perform error checking and create statement function descriptor
106 * for statement function definition.
107 */
108 int
define_stfunc(int sptr,ITEM * argl,SST * estk)109 define_stfunc(int sptr, ITEM *argl, SST *estk)
110 {
111 int expr;
112 int arg, dtype;
113 ITEM *itemp;
114 ARGINFO *arginfo, *lastarg;
115 SFDSC *sfdsc;
116 SST *stkptr;
117 int ast;
118 int argt;
119 int i;
120 static int last_stfunc; /* last ST_FUNC created */
121 SFUSE *sfuse;
122
123 expr = mkexpr(estk);
124 ast = SST_ASTG(estk);
125 stfunc_argl = argl;
126
127 ast_visit(1, 1); /* marks ast#1 visited */
128 ast_traverse(ast, NULL, _non_private, NULL); /* vist each ast in the rhs */
129
130 /* traverse the args to any statement functions ref'd in this one */
131 for (sfuse = l_sfuse; sfuse; sfuse = sfuse->next)
132 for (arginfo = sfuse->args; arginfo; arginfo = arginfo->next)
133 ast_traverse(arginfo->actual, NULL, NULL, NULL);
134
135 /* allocate and initialize statement function descriptor */
136
137 /* NOTE: 9/17/97, area 8 is used for stmt functions -- need to keep
138 * just in case the defs appear in a containing subprogram.
139 */
140 sfdsc = (SFDSC *)getitem(8, sizeof(SFDSC));
141 sfdsc->args = NULL;
142
143 /* scan list of dummy arguments and process each argument; all arguments
144 * have been validated by semant.
145 */
146 lastarg = NULL;
147 for (itemp = argl; itemp != ITEM_END; itemp = itemp->next) {
148 int old, new;
149 stkptr = itemp->t.stkp;
150 arg = SST_SYMG(stkptr);
151 if (ARGINFOG(arg)) { /* duplicate dummy */
152 error(42, 3, gbl.lineno, SYMNAME(arg), CNULL);
153 ast_unvisit();
154 return 0;
155 }
156 dtype = DTYPEG(arg);
157 /*
158 * allocate and initialize an arginfo record for this dummy,
159 * and link it into end of argument list
160 */
161 arginfo = (ARGINFO *)getitem(8, sizeof(ARGINFO));
162 old = SST_ASTG(itemp->t.stkp);
163 /*
164 * replace the ast of the formal argument with a unique ast; can't
165 * share asts of any formals with any nested statement functions.
166 */
167 new = new_node(A_ID);
168 A_SPTRP(new, arg);
169 A_DTYPEP(new, dtype);
170 ast_replace(old, new);
171 arginfo->formal = new;
172 arginfo->dtype = dtype;
173 arginfo->next = NULL;
174 arginfo->refd = A_VISITG(old) != 0;
175 if (lastarg == NULL) /* this is first argument */
176 sfdsc->args = arginfo;
177 else
178 lastarg->next = arginfo;
179 lastarg = arginfo;
180 ARGINFOP(arg, put_getitem_p(arginfo));
181 }
182 /*
183 * rewrite the rhs of the statement function and the actual argument
184 * asts of any statement functions ref'd in this one; this replaces
185 * the original asts of the formal arguments with their new asts.
186 */
187 ast = ast_rewrite(ast);
188 for (sfuse = l_sfuse; sfuse; sfuse = sfuse->next)
189 for (arginfo = sfuse->args; arginfo; arginfo = arginfo->next)
190 arginfo->actual = ast_rewrite(arginfo->actual);
191
192 ast_unvisit();
193
194 sfdsc->rhs = ast;
195 sfdsc->l_use = l_sfuse; /* list of statement functions used */
196 end_sfuse = l_sfuse = NULL;
197
198 /* set ARGINFO fields of dummies back to 0 */
199
200 for (itemp = argl; itemp != ITEM_END; itemp = itemp->next)
201 ARGINFOP(SST_SYMG(itemp->t.stkp), 0);
202
203 SFDSCP(sptr, put_getitem_p(sfdsc));
204 STYPEP(sptr, ST_STFUNC);
205 SFASTP(sptr, ast);
206 sfdsc->dtype = DTYPEG(sptr);
207 if (gbl.stfuncs == NOSYM)
208 gbl.stfuncs = sptr;
209 else
210 SYMLKP(last_stfunc, sptr);
211 last_stfunc = sptr;
212
213 if (DBGBIT(3, 16))
214 dump_stfunc(sptr);
215
216 return ast;
217 }
218
219 /** \brief AST visitor function
220 *
221 * This is passed to ast_traverse() to add variables with add_non_private.
222 */
223 static void
_non_private(int ast,int * dummy)224 _non_private(int ast, int *dummy)
225 {
226 int sptr;
227 if (!flg.smp)
228 return;
229 if (A_TYPEG(ast) != A_ID)
230 return;
231 sptr = A_SPTRG(ast);
232 if (ST_ISVAR(STYPEG(sptr))) {
233 /*
234 * Make sure that sptr is not the dummy arg to the statement function.
235 */
236 ITEM *itemp;
237 for (itemp = stfunc_argl; itemp != ITEM_END; itemp = itemp->next) {
238 SST *stkptr;
239 int arg;
240 stkptr = itemp->t.stkp;
241 arg = SST_SYMG(stkptr);
242 if (arg == sptr)
243 break;
244 }
245 if (itemp == ITEM_END)
246 add_non_private(sptr);
247 }
248 }
249
250 /*---------------------------------------------------------------------*/
251
252 /** \brief Write out statement function descriptor to debug file. */
253 static void
dump_stfunc(int sptr)254 dump_stfunc(int sptr)
255 {
256 SFDSC *sfdsc;
257 ARGINFO *arginfo;
258 SFUSE *sfuse;
259
260 sfdsc = (SFDSC *)get_getitem_p(SFDSCG(sptr));
261 fprintf(gbl.dbgfil, "\nSTATEMENT FUNCTION DEFN: %s, sfdsc: %p, dtype: %d\n",
262 SYMNAME(sptr), (void *)sfdsc, sfdsc->dtype);
263
264 for (arginfo = sfdsc->args; arginfo; arginfo = arginfo->next) {
265 fprintf(gbl.dbgfil, " arg: %p ast: %d dtype: %d refd: %d\n",
266 (void *)arginfo, arginfo->formal, arginfo->dtype, arginfo->refd);
267 dump_one_ast(arginfo->formal);
268 }
269 fprintf(gbl.dbgfil, "\nRHS:");
270 dump_ast_tree(sfdsc->rhs);
271 fprintf(gbl.dbgfil, "\n");
272 fprintf(gbl.dbgfil, "sfuse:\n");
273 for (sfuse = sfdsc->l_use; sfuse; sfuse = sfuse->next) {
274 fprintf(gbl.dbgfil, "<sfdsc %p, exprs: %p>\n", (void *)sfuse->dsc,
275 (void *)sfuse->args);
276 for (arginfo = sfuse->args; arginfo; arginfo = arginfo->next) {
277 fprintf(gbl.dbgfil, " arginfo: %p actual: %d dtype: %d\n",
278 (void *)arginfo, arginfo->actual, arginfo->dtype);
279 dump_one_ast(arginfo->actual);
280 }
281 }
282 fprintf(gbl.dbgfil, "\n");
283 }
284
285 /*---------------------------------------------------------------------*/
286
287 int
ref_stfunc(SST * stktop,ITEM * args)288 ref_stfunc(SST *stktop, ITEM *args)
289 {
290 int sptr;
291 int dtype;
292 ITEM *itemp;
293 SFDSC *sfdsc;
294 ARGINFO *arginfo;
295 SFUSE *sfuse;
296 ARGINFO *ai;
297 int ast;
298 int i;
299 int tmp;
300 int new;
301 int asn;
302
303 sptr = SST_SYMG(stktop);
304 if (DBGBIT(3, 16))
305 fprintf(gbl.dbgfil, "\nInvoking statement function %s\n", SYMNAME(sptr));
306 dtype = DTYPEG(sptr);
307 sfdsc = (SFDSC *)get_getitem_p(SFDSCG(sptr));
308 if (sem.in_stfunc) {
309 /* NOTE: 9/17/97, area 8 is used for stmt functions -- need to keep
310 * just in case the defs appear in a containing subprogram.
311 */
312 sfuse = (SFUSE *)getitem(8, sizeof(SFUSE));
313 sfuse->dsc = sfdsc;
314 sfuse->args = NULL;
315 /*
316 * create a unique id AST whose sptr is the statement function
317 * which is referenced; this id will be replaced by the statement
318 * function's right-hand side (after argument substitution).
319 */
320 sfuse->node = new_node(A_ID);
321 A_SPTRP(sfuse->node, sptr);
322 A_DTYPEP(sfuse->node, dtype);
323 /*
324 * add this statement function to the 'global' statement function
325 * use; when the definition ultimately occurs, the pointer to the
326 * list will be stored in the descriptor of the statement which
327 * is defined.
328 */
329 if (end_sfuse == NULL)
330 end_sfuse = l_sfuse = sfuse;
331 else
332 end_sfuse->next = sfuse;
333 end_sfuse = sfuse;
334 sfuse->next = NULL;
335 if (DBGBIT(3, 16))
336 fprintf(gbl.dbgfil, "%s in statement fcn def, use %p, node %d\n",
337 SYMNAME(sptr), (void *)sfuse, sfuse->node);
338 }
339 /*
340 * scan thru actual argument list, and list of dummy arg info
341 * records in parallel to check type and create asts for actual args
342 */
343 for (itemp = args, arginfo = sfdsc->args;
344 itemp != ITEM_END && arginfo != NULL;
345 itemp = itemp->next, arginfo = arginfo->next) {
346 if (SST_IDG(itemp->t.stkp) == S_KEYWORD) {
347 error(79, 3, gbl.lineno, scn.id.name + SST_CVALG(itemp->t.stkp), CNULL);
348 itemp->t.stkp = SST_E3G(itemp->t.stkp);
349 arginfo->refd = 0;
350 } else if (SST_IDG(itemp->t.stkp) == S_TRIPLE ||
351 SST_IDG(itemp->t.stkp) == S_STAR) {
352 error(155, 3, gbl.lineno,
353 "An argument to this statement function looks "
354 "like an array section subscript",
355 CNULL);
356 continue;
357 }
358
359 if (arginfo->refd)
360 (void)chktyp(itemp->t.stkp, arginfo->dtype, TRUE);
361 else /* although arg isn't refd, ensure ast for the actual exists */
362 (void)mkexpr(itemp->t.stkp);
363 ast = SST_ASTG(itemp->t.stkp);
364 arginfo->actual = ast;
365 }
366
367 /* check that number of arguments is correct */
368
369 if (itemp != ITEM_END || arginfo != NULL)
370 error(85, 3, gbl.lineno, SYMNAME(sptr), CNULL);
371 /*
372 * If in a statement function definition, create a list of actual
373 * arguments passed to the statement function.
374 */
375 if (sem.in_stfunc) {
376 for (arginfo = sfdsc->args; arginfo != NULL; arginfo = arginfo->next) {
377 ai = (ARGINFO *)getitem(8, sizeof(ARGINFO));
378 ai->next = sfuse->args;
379 sfuse->args = ai;
380 ai->actual = arginfo->actual;
381 ai->formal = arginfo->formal;
382 ai->dtype = arginfo->dtype;
383 ai->refd = arginfo->refd;
384 if (DBGBIT(3, 16)) {
385 fprintf(gbl.dbgfil, "expr to be substituted, ast %d, arginfo %p\n",
386 ai->actual, (void *)ai);
387 fprintf(gbl.dbgfil, "formal(%d):\n", ai->formal);
388 dbg_print_ast(ai->formal, gbl.dbgfil);
389 fprintf(gbl.dbgfil, "actual(%d):\n", ai->actual);
390 dbg_print_ast(ai->actual, gbl.dbgfil);
391 }
392 }
393 ast = sfuse->node;
394 goto return_it;
395 }
396 /*
397 * replace uses of the dummy arguments with the actual arguments.
398 */
399 ast_visit(1, 1);
400 for (arginfo = sfdsc->args; arginfo != NULL; arginfo = arginfo->next) {
401 if (!arginfo->refd) {
402 if (DBGBIT(3, 16)) {
403 fprintf(gbl.dbgfil, "\n skipping unref'd arg");
404 dump_ast_tree(arginfo->formal);
405 }
406 continue;
407 }
408 ast = arginfo->actual;
409 if (A_CALLFGG(ast) || A_TYPEG(ast) == A_CONV) {
410 /*
411 * evaluate and assign the argument to a temporary if:
412 * 1. argument contains a function call - ensure the
413 * the function is evaluated just once, or
414 * 2. the argument is converted to another type - need to
415 * preserve the type.
416 */
417 tmp = get_temp(arginfo->dtype);
418 if (DBGBIT(3, 16))
419 fprintf(gbl.dbgfil, "\n create temp.1 %s\n", SYMNAME(tmp));
420 new = mk_id(tmp);
421 asn = mk_assn_stmt(new, ast, arginfo->dtype);
422 (void)add_stmt(asn);
423 arginfo->actual = new;
424 }
425 ast_replace(arginfo->formal, arginfo->actual);
426 if (DBGBIT(3, 16)) {
427 fprintf(gbl.dbgfil, "\n replace %d:\n", arginfo->formal);
428 dbg_print_ast(arginfo->formal, gbl.dbgfil);
429 fprintf(gbl.dbgfil, " with %d:\n", arginfo->actual);
430 /*dump_ast_tree(arginfo->actual);*/
431 dbg_print_ast(arginfo->actual, gbl.dbgfil);
432 }
433 }
434
435 /* evaluate any statement functions which appeared in the definition
436 * of the statement function.
437 */
438 asn_sfuse(sfdsc->l_use);
439
440 ast = ast_rewrite(sfdsc->rhs);
441 ast_unvisit();
442 if (DBGBIT(3, 16)) {
443 fprintf(gbl.dbgfil, "\n statement function result %d\n", ast);
444 /*dump_ast_tree(ast);*/
445 dbg_print_ast(ast, gbl.dbgfil);
446 fprintf(gbl.dbgfil, "\n");
447 }
448 if (!sem.in_stfunc && A_TYPEG(ast) == A_CONV) {
449 /* TBD: replace with an expression to convert the type.
450 * For now, just
451 * assign the result to a temporary if the result is converted
452 * to another type - need to preserve the type.
453 */
454 tmp = get_temp(dtype);
455 if (DBGBIT(3, 16))
456 fprintf(gbl.dbgfil, "\n create temp.2 %s\n", SYMNAME(tmp));
457 new = mk_id(tmp);
458 asn = mk_assn_stmt(new, ast, dtype);
459 (void)add_stmt(asn);
460 ast = new;
461 }
462 if (gbl.internal > 1) {
463 ast_visit(1, 1); /* marks ast#1 visited */
464 ast_traverse(ast, NULL, set_internref_stfunc,
465 NULL); /* vist each ast in the rhs */
466 ast_unvisit();
467 }
468
469 return_it:
470 SST_ASTP(stktop, ast);
471 SST_SHAPEP(stktop, 0);
472 SST_DTYPEP(stktop, dtype);
473 SST_IDP(stktop, S_EXPR);
474
475 return 1;
476 }
477
478 static void
asn_sfuse(SFUSE * l_use)479 asn_sfuse(SFUSE *l_use)
480 {
481 SFUSE *sfuse;
482 ARGINFO *expr;
483 int ast;
484 int tmp;
485 int asn;
486 int new;
487
488 if (DBGBIT(3, 16))
489 fprintf(gbl.dbgfil, "asn_sfuse entered\n");
490 for (sfuse = l_use; sfuse != NULL; sfuse = sfuse->next) {
491 if (DBGBIT(3, 16))
492 fprintf(gbl.dbgfil, "\n asn_sfuse, begin sfuse %p, node %d\n",
493 (void *)sfuse, sfuse->node);
494
495 /* substitute the actual arguments for the corresponding formals */
496
497 for (expr = sfuse->args; expr != NULL; expr = expr->next) {
498 expr->save = A_REPLG(expr->formal);
499 if (!expr->refd) {
500 if (DBGBIT(3, 16)) {
501 fprintf(gbl.dbgfil, "\n asn_sfuse: skipping unref'd arg");
502 dump_ast_tree(expr->formal);
503 }
504 continue;
505 }
506 ast = ast_rewrite(expr->actual);
507 if (A_CALLFGG(ast) || A_TYPEG(ast) == A_CONV) {
508 tmp = get_temp(expr->dtype);
509 new = mk_id(tmp);
510 asn = mk_assn_stmt(new, ast, expr->dtype);
511 (void)add_stmt(asn);
512 ast = new;
513 }
514 ast_replace(expr->formal, ast);
515 if (DBGBIT(3, 16)) {
516 fprintf(gbl.dbgfil, " asn_sfuse, replace formal %d\n", expr->formal);
517 dbg_print_ast(expr->formal, gbl.dbgfil);
518 fprintf(gbl.dbgfil, " asn_sfuse, with %d\n", ast);
519 dbg_print_ast(ast, gbl.dbgfil);
520 }
521 }
522 /*
523 * evaluate any statement functions which were invoked in this
524 * statement function.
525 */
526 asn_sfuse(sfuse->dsc->l_use);
527 /*
528 * replace the statement function with the evaluation of its
529 * right-hand side.
530 */
531 ast = ast_rewrite(sfuse->dsc->rhs);
532 if (DBGBIT(3, 16)) {
533 fprintf(gbl.dbgfil, " asn_sfuse, rewrite %d:\n", sfuse->dsc->rhs);
534 dbg_print_ast(sfuse->dsc->rhs, gbl.dbgfil);
535 fprintf(gbl.dbgfil, " asn_sfuse, as %d:\n", ast);
536 dbg_print_ast(ast, gbl.dbgfil);
537 }
538 if (A_CALLFGG(ast) || A_TYPEG(ast) == A_CONV) {
539 tmp = get_temp(sfuse->dsc->dtype);
540 if (DBGBIT(3, 16))
541 fprintf(gbl.dbgfil, " asn_sfuse, create temp %s\n", SYMNAME(tmp));
542 new = mk_id(tmp);
543 asn = mk_assn_stmt(new, ast, sfuse->dsc->dtype);
544 (void)add_stmt(asn);
545 ast = new;
546 }
547 ast_replace(sfuse->node, ast);
548 if (DBGBIT(3, 16))
549 fprintf(gbl.dbgfil, " asn_sfuse, end sfuse %p, node %d\n",
550 (void *)sfuse, A_REPLG(sfuse->node));
551 /*
552 * cleanup in this order: zero out the REPL fields of the right-hand
553 * side and restore the state of the formals to the statement function.
554 */
555 ast_clear_repl(sfuse->dsc->rhs);
556 for (expr = sfuse->args; expr != NULL; expr = expr->next)
557 A_REPLP(expr->formal, expr->save);
558 }
559 if (DBGBIT(3, 16))
560 fprintf(gbl.dbgfil, "asn_sfuse returned\n");
561 }
562
563 /*---------------------------------------------------------------------*/
564
565 /** \brief Check and write ILMs for a subprogram argument.
566 * \param stkptr a stack entry representing a subprogram argument
567 * \param dtype used to pass out data type of argument
568 * \return sptr for alternate return label
569 */
570 int
mkarg(SST * stkptr,int * dtype)571 mkarg(SST *stkptr, int *dtype)
572 {
573 int sptr, cp, sp2, ast;
574 int dt;
575
576 again:
577 switch (SST_IDG(stkptr)) {
578 case S_STFUNC: /* delayed var ref */
579 SST_IDP(stkptr, S_IDENT);
580 (void)mkvarref(stkptr, SST_ENDG(stkptr));
581 goto again;
582
583 case S_DERIVED:
584 if (SST_DBEGG(stkptr)) {
585 (void)mkvarref(stkptr, SST_DBEGG(stkptr));
586 return 1;
587 }
588 sptr = SST_SYMG(stkptr);
589 mkident(stkptr);
590 SST_SYMP(stkptr, sptr);
591 goto add_sym_arg;
592
593 case S_CONST:
594 SST_CVLENP(stkptr, 0);
595 if (SST_DTYPEG(stkptr) == DT_HOLL) {
596 SST_DTYPEP(stkptr, DT_INT);
597 SST_IDP(stkptr, S_EXPR);
598 } else {
599 if (SST_DTYPEG(stkptr) == DT_WORD)
600 SST_DTYPEP(stkptr, DT_INT);
601 mkexpr(stkptr);
602 }
603 *dtype = SST_DTYPEG(stkptr);
604 return 1;
605
606 case S_ACONST:
607 /* resolve it */
608 if (!SST_ACLG(stkptr)) { /* zero-sized array */
609 int sdtype;
610 sptr = sym_get_array("zs", "array", SST_DTYPEG(stkptr), 1);
611 sdtype = DTYPEG(sptr);
612 ADD_LWBD(sdtype, 0) = ADD_LWAST(sdtype, 0) = astb.bnd.one;
613 ADD_UPBD(sdtype, 0) = ADD_UPAST(sdtype, 0) = astb.bnd.zero;
614 ADD_EXTNTAST(sdtype, 0) =
615 mk_extent(ADD_LWAST(sdtype, 0), ADD_UPAST(sdtype, 0), 0);
616 } else {
617 sptr = init_sptr_w_acl(0, SST_ACLG(stkptr));
618 }
619 mkident(stkptr);
620 SST_SYMP(stkptr, sptr);
621 goto add_const_sym_arg;
622
623 case S_IDENT:
624 /* resolve it */
625 sptr = SST_SYMG(stkptr);
626 switch (STYPEG(sptr)) {
627 case ST_PD:
628 sp2 = sptr;
629 if (!EXPSTG(sptr)) {
630 sptr = newsym(sptr);
631 STYPEP(sptr, ST_VAR);
632 sem_set_storage_class(sptr);
633 goto add_sym_arg;
634 }
635 goto common_intrinsic;
636 case ST_ENTRY:
637 if (gbl.rutype == RU_SUBR && (flg.recursive || RECURG(sptr)))
638 ;
639 else if (gbl.rutype != RU_FUNC)
640 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
641 else if (!RESULTG(sptr))
642 sptr = ref_entry(sptr);
643 /* if RESULTG is set, the reference to the function name
644 * must mean the function itself; if not, the function name
645 * must mean the function result variable */
646 goto add_sym_arg;
647 case ST_UNKNOWN:
648 case ST_IDENT:
649 STYPEP(sptr, ST_VAR);
650 /* fall through to ... */
651 case ST_VAR:
652 case ST_ARRAY:
653 if (DTY(DTYPEG(sptr)) != TY_ARRAY || DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
654 DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR) {
655 /* test for scalar pointer */
656 if ((ALLOCATTRG(sptr) || POINTERG(sptr)) && SDSCG(sptr) == 0 &&
657 !F90POINTERG(sptr)) {
658 if (SCG(sptr) == SC_NONE)
659 SCP(sptr, SC_BASED);
660 get_static_descriptor(sptr);
661 get_all_descriptors(sptr);
662 }
663 }
664 goto add_sym_arg;
665 case ST_USERGENERIC:
666 if (GSAMEG(sptr)) {
667 /* use the specific of the same name */
668 sptr = GSAMEG(sptr);
669 goto add_sym_arg;
670 }
671 /* can't pass the generic name as an argument */
672 error(73, 3, gbl.lineno, SYMNAME(sptr), CNULL);
673 SST_DTYPEP(stkptr, *dtype = DT_INT);
674 return 1;
675 case ST_GENERIC:
676 /* Generic used as an actual argument. Use specific of same name.
677 * If none, then assume its a variable unless generic is frozen.
678 */
679 sp2 = select_gsame(sptr); /* intrinsic of same name */
680 if (sp2 == 0 || !EXPSTG(sptr)) {
681 sptr = newsym(sptr);
682 STYPEP(sptr, ST_VAR);
683 sem_set_storage_class(sptr);
684 goto add_sym_arg;
685 }
686 sp2 = intrinsic_as_arg(sptr);
687 if (sp2 == 0) {
688 /* may not be passed as argument */
689 error(73, 3, gbl.lineno, SYMNAME(sptr), CNULL);
690 SST_DTYPEP(stkptr, *dtype = DT_INT);
691 return 1;
692 }
693 if (STYPEG(sp2) == ST_PROC)
694 sptr = sp2;
695 else if (sp2 != GSAMEG(sptr)) {
696 DTYPEP(sp2, INTTYPG(sp2));
697 sptr = sp2;
698 } else
699 DTYPEP(sptr, INTTYPG(sp2));
700 goto add_sym_arg;
701 case ST_INTRIN:
702 sp2 = sptr;
703 if (!EXPSTG(sptr)) {
704 sptr = newsym(sptr);
705 STYPEP(sptr, ST_VAR);
706 sem_set_storage_class(sptr);
707 goto add_sym_arg;
708 }
709 common_intrinsic:
710 sp2 = intrinsic_as_arg(sptr);
711 if (sp2 == 0) {
712 /* may not be passed as argument */
713 error(73, 3, gbl.lineno, SYMNAME(sptr), CNULL);
714 SST_DTYPEP(stkptr, *dtype = DT_INT);
715 return 1;
716 }
717 if (STYPEG(sp2) != ST_PROC)
718 DTYPEP(sp2, INTTYPG(sp2));
719 sptr = sp2;
720 goto add_sym_arg;
721 case ST_PROC:
722 sp2 = SCOPEG(sptr);
723 if (STYPEG(sp2) == ST_ALIAS)
724 sp2 = SYMLKG(sp2);
725 if (ELEMENTALG(sptr)) {
726 error(464, 3, gbl.lineno, SYMNAME(sptr), CNULL);
727 SST_DTYPEP(stkptr, *dtype = DTYPEG(sptr));
728 return 1;
729 }
730 TYPDP(sptr, 1); /* force it to appear in an EXTERNAL stmt */
731 goto add_sym_arg;
732 case ST_STFUNC:
733 case ST_STRUCT:
734 case ST_TYPEDEF:
735 goto add_sym_arg;
736
737 default:
738 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
739 SST_DTYPEP(stkptr, *dtype = DTYPEG(sptr));
740 SST_ASTP(stkptr, mk_id(sptr));
741 SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
742 return 3;
743 }
744
745 case S_LVALUE:
746 *dtype = SST_DTYPEG(stkptr);
747 ARGP(SST_LSYMG(stkptr), 1);
748 ast = SST_ASTG(stkptr);
749 if (ast && A_TYPEG(ast) == A_MEM) {
750 /* this is a derived-type member reference, see if the
751 * member needs a static descriptor */
752 sptr = find_pointer_variable(ast);
753 if (DTY(DTYPEG(sptr)) != TY_ARRAY) {
754 if (POINTERG(sptr) && SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
755 if (STYPEG(sptr) != ST_MEMBER && SCG(sptr) == SC_NONE)
756 SCP(sptr, SC_BASED);
757 get_static_descriptor(sptr);
758 get_all_descriptors(sptr);
759 }
760 }
761 }
762 sptr = SST_LSYMG(stkptr);
763 SST_CVLENP(stkptr, 0);
764 dt = DDTG(DTYPEG(sptr)); /* element dtype record */
765 if ((DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) && ADJLENG(sptr)) {
766 SST_CVLENP(stkptr, size_ast(sptr, dt));
767 }
768 return 1;
769
770 case S_EXPR:
771 case S_LOGEXPR:
772 *dtype = SST_DTYPEG(stkptr);
773 if (flg.endian) {
774 switch (DTY(SST_DTYPEG(stkptr))) {
775 case TY_BINT:
776 case TY_BLOG:
777 case TY_SINT:
778 case TY_SLOG:
779 return tempify(stkptr);
780 default:
781 break;
782 }
783 }
784 return 1;
785
786 case S_REF:
787 *dtype = SST_DTYPEG(stkptr);
788 return 1;
789
790 case S_VAL:
791 *dtype = SST_DTYPEG(stkptr);
792 return 1;
793
794 case S_LABEL:
795 *dtype = 0;
796 return -SST_SYMG(stkptr);
797
798 case S_SCONST:
799 if (!SST_ACLG(stkptr)) {
800 sptr = getcctmp_sc('d', sem.dtemps++, ST_VAR, SST_DTYPEG(stkptr), sem.sc);
801 } else {
802 sptr = init_derived_w_acl(0, SST_ACLG(stkptr));
803 }
804 mkident(stkptr);
805 SST_SYMP(stkptr, sptr);
806 goto add_const_sym_arg;
807
808 case S_KEYWORD:
809 return mkarg(SST_E3G(stkptr), dtype);
810
811 case S_STAR:
812 case S_TRIPLE:
813 error(
814 155, 3, gbl.lineno,
815 "An argument to this subprogram looks like an array section subscript",
816 CNULL);
817 /* change to constant zero, see if we can avoid further errors */
818 SST_DTYPEP(stkptr, *dtype = DT_INT);
819 SST_ASTP(stkptr, astb.i0);
820 SST_SHAPEP(stkptr, 0);
821 SST_IDP(stkptr, S_CONST);
822 return 3;
823
824 default:
825 interr("mkarg: arg has bad stkid", SST_IDG(stkptr), 3);
826 return 3;
827 }
828
829 add_sym_arg:
830 sptr = ref_object(sptr);
831 add_const_sym_arg:
832 ARGP(sptr, 1);
833 SST_DTYPEP(stkptr, *dtype = DTYPEG(sptr));
834 SST_ASTP(stkptr, mk_id(sptr));
835 SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
836 SST_CVLENP(stkptr, 0);
837 dt = DDTG(DTYPEG(sptr)); /* element dtype record */
838 if ((DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) && ADJLENG(sptr)) {
839 SST_CVLENP(stkptr, size_ast(sptr, dt));
840 }
841 return 1;
842 }
843
844 #if defined(TARGET_WIN_X86) && defined(PGFTN)
845 /*
846 * convert to upper case
847 */
848 static void
upcase_name(char * name)849 upcase_name(char *name)
850 {
851 char *p;
852 int ch;
853 for (p = name; ch = *p; ++p)
854 if (ch >= 'a' && ch <= 'z')
855 *p = ch + ('A' - 'a');
856 }
857 #endif
858
859 int
intrinsic_as_arg(int intr)860 intrinsic_as_arg(int intr)
861 {
862 int sp2;
863 int cp;
864 FtnRtlEnum rtlRtn;
865
866 sp2 = intr;
867 switch (STYPEG(intr)) {
868 case ST_GENERIC:
869 sp2 = select_gsame(intr);
870 if (sp2 == 0)
871 return 0;
872 case ST_PD:
873 case ST_INTRIN:
874 cp = PNMPTRG(sp2);
875 if (cp == 0 || stb.n_base[cp] == '-')
876 return 0;
877 if (stb.n_base[cp] != '*' || stb.n_base[++cp] != '\0') {
878 int dt;
879
880 dt = INTTYPG(sp2);
881
882 switch (INTASTG(sp2)) {
883 case I_INDEX:
884 case I_KINDEX:
885 case I_NINDEX:
886 if (XBIT(58, 0x40)) { /* input is f90 */
887 #ifdef CREFP
888 if (WINNT_CREF) {
889 rtlRtn = WINNT_NOMIXEDSTRLEN ? RTE_indexx_cr_nma : RTE_indexx_cra;
890 } else
891 #endif
892 {
893 rtlRtn = RTE_indexxa;
894 }
895 } else if (XBIT(124, 0x10)) { /* -i8 for f77 */
896 sp2 = intast_sym[I_KINDEX];
897 dt = DT_INT8;
898 rtlRtn = RTE_lenDsc;
899 } else {
900 rtlRtn = RTE_indexDsc;
901 }
902 break;
903 case I_LEN:
904 case I_ILEN:
905 case I_KLEN:
906 if (XBIT(58, 0x40)) { /* input is f90 */
907 #ifdef CREFP
908 if (WINNT_CREF) {
909 rtlRtn = WINNT_NOMIXEDSTRLEN ? RTE_lenx_cr_nma : RTE_lenx_cra;
910 } else
911 #endif
912 {
913 rtlRtn = RTE_lenxa;
914 }
915 } else if (XBIT(124, 0x10)) { /* -i8 for f77 */
916 sp2 = intast_sym[I_KLEN];
917 dt = DT_INT8;
918 rtlRtn = RTE_lenDsc;
919 break;
920 } else {
921 rtlRtn = RTE_lenDsc;
922 }
923 break;
924 }
925 sp2 = sym_mkfunc(mkRteRtnNm(rtlRtn), dt);
926 TYPDP(sp2, 1); /* force it to appear in an EXTERNAL stmt */
927 if (WINNT_CALL)
928 MSCALLP(sp2, 1);
929 #ifdef CREFP
930 if (WINNT_CREF) {
931 CREFP(sp2, 1);
932 CCSYMP(sp2, 1);
933 }
934 #endif
935 break;
936 }
937 if (XBIT(124, 0x10)) { /* -i8 */
938 switch (INTASTG(sp2)) {
939 case I_IABS:
940 sp2 = intast_sym[I_KIABS];
941 break;
942 case I_IDIM:
943 sp2 = intast_sym[I_KIDIM];
944 break;
945 case I_MOD:
946 sp2 = intast_sym[I_KMOD];
947 break;
948 case I_NINT:
949 sp2 = intast_sym[I_KNINT];
950 break;
951 case I_IDNINT:
952 sp2 = intast_sym[I_KIDNNT];
953 break;
954 case I_ISIGN:
955 sp2 = intast_sym[I_KISIGN];
956 break;
957 /*
958 * For the following, the integer specifics have been changed
959 * to their corresponding integer*8 versions; however, the
960 * function names are still refer to the integer forms.
961 * Need to returning the sptr of the integer*8 intrinsic
962 * so that the function name is correctly constructed.
963 */
964 case I_KIABS:
965 sp2 = intast_sym[I_KIABS];
966 break;
967 case I_KIDIM:
968 sp2 = intast_sym[I_KIDIM];
969 break;
970 case I_KIDNNT:
971 sp2 = intast_sym[I_KIDNNT];
972 break;
973 case I_KISIGN:
974 sp2 = intast_sym[I_KISIGN];
975 break;
976 default:
977 break;
978 }
979 }
980 if (XBIT(124, 0x8)) { /* -r8 */
981 switch (INTASTG(sp2)) {
982 case I_ALOG:
983 sp2 = intast_sym[I_DLOG];
984 break;
985 case I_ALOG10:
986 sp2 = intast_sym[I_DLOG10];
987 break;
988 case I_CABS:
989 sp2 = intast_sym[I_CDABS];
990 break;
991 case I_AMOD:
992 sp2 = intast_sym[I_DMOD];
993 break;
994 case I_ABS:
995 sp2 = intast_sym[I_DABS];
996 break;
997 case I_SIGN:
998 sp2 = intast_sym[I_DSIGN];
999 break;
1000 case I_DIM:
1001 sp2 = intast_sym[I_DDIM];
1002 break;
1003 case I_SQRT:
1004 sp2 = intast_sym[I_DSQRT];
1005 break;
1006 case I_EXP:
1007 sp2 = intast_sym[I_DEXP];
1008 break;
1009 case I_SIN:
1010 sp2 = intast_sym[I_DSIN];
1011 break;
1012 case I_COS:
1013 sp2 = intast_sym[I_DCOS];
1014 break;
1015 case I_TAN:
1016 sp2 = intast_sym[I_DTAN];
1017 break;
1018 case I_AINT:
1019 sp2 = intast_sym[I_DINT];
1020 break;
1021 case I_ANINT:
1022 sp2 = intast_sym[I_DNINT];
1023 break;
1024 case I_ASIN:
1025 sp2 = intast_sym[I_DASIN];
1026 break;
1027 case I_ACOS:
1028 sp2 = intast_sym[I_DACOS];
1029 break;
1030 case I_ATAN:
1031 sp2 = intast_sym[I_DATAN];
1032 break;
1033 case I_SINH:
1034 sp2 = intast_sym[I_DSINH];
1035 break;
1036 case I_COSH:
1037 sp2 = intast_sym[I_DCOSH];
1038 break;
1039 case I_TANH:
1040 sp2 = intast_sym[I_DTANH];
1041 break;
1042 case I_ATAN2:
1043 sp2 = intast_sym[I_DATAN2];
1044 break;
1045 case I_SIND:
1046 sp2 = intast_sym[I_DSIND];
1047 break;
1048 case I_COSD:
1049 sp2 = intast_sym[I_DCOSD];
1050 break;
1051 case I_TAND:
1052 sp2 = intast_sym[I_DTAND];
1053 break;
1054 case I_AIMAG:
1055 sp2 = intast_sym[I_DIMAG];
1056 break;
1057 case I_ASIND:
1058 sp2 = intast_sym[I_DASIND];
1059 break;
1060 case I_ACOSD:
1061 sp2 = intast_sym[I_DACOSD];
1062 break;
1063 case I_ATAND:
1064 sp2 = intast_sym[I_DATAND];
1065 break;
1066 case I_ATAN2D:
1067 sp2 = intast_sym[I_DATAN2D];
1068 break;
1069 case I_CSQRT:
1070 sp2 = intast_sym[I_CDSQRT];
1071 break;
1072 case I_CLOG:
1073 sp2 = intast_sym[I_CDLOG];
1074 break;
1075 case I_CEXP:
1076 sp2 = intast_sym[I_CDEXP];
1077 break;
1078 case I_CSIN:
1079 sp2 = intast_sym[I_CDSIN];
1080 break;
1081 case I_CCOS:
1082 sp2 = intast_sym[I_CDCOS];
1083 break;
1084 case I_CONJG:
1085 sp2 = intast_sym[I_DCONJG];
1086 break;
1087 /*
1088 * For the following, the real/complex specifics have been changed
1089 * to their corresponding double real/complex versions; however, the
1090 * function names are still refer to the real/complex forms.
1091 * Need to returning the sptr of the 'double real/complex' intrinsic
1092 * so that the function name is correctly constructed.
1093 */
1094 case I_DLOG:
1095 sp2 = intast_sym[I_DLOG];
1096 break;
1097 case I_DLOG10:
1098 sp2 = intast_sym[I_DLOG10];
1099 break;
1100 case I_CDABS:
1101 sp2 = intast_sym[I_CDABS];
1102 break;
1103 case I_DMOD:
1104 sp2 = intast_sym[I_DMOD];
1105 break;
1106 case I_CDSQRT:
1107 sp2 = intast_sym[I_CDSQRT];
1108 break;
1109 case I_CDLOG:
1110 sp2 = intast_sym[I_CDLOG];
1111 break;
1112 case I_CDEXP:
1113 sp2 = intast_sym[I_CDEXP];
1114 break;
1115 case I_CDSIN:
1116 sp2 = intast_sym[I_CDSIN];
1117 break;
1118 case I_CDCOS:
1119 sp2 = intast_sym[I_CDCOS];
1120 break;
1121 }
1122 }
1123 break;
1124 default:;
1125 }
1126 if (SYMNAME(sp2)[0] != '.')
1127 TYPDP(sp2, 1); /* force it to appear in an INTRINSIC statement */
1128 return sp2;
1129 }
1130
1131 /** \brief Performing checking on an argument to determine if it needs to be
1132 * "protected".
1133 * \param stkptr a stack entry representing a subprogram argument
1134 * \param dtype used to pass out data type of argument
1135 * \return sptr for alternate return label
1136 *
1137 * When an argument needs to be protected, its value may be have to be stored
1138 * in a temp and then the temp's address becomes the actual argument. This
1139 * occurs when a parenthesized expression is an actual argument. NOTE that
1140 * the logic in chkarg relies on an argument being `<expression>`; a flag
1141 * (SST_PARENG/P) in the semantic stack is used and is only defined for
1142 * `<expression>`; the flag is cleared when `<expression> ::= ...` occurs and
1143 * is set when `<primary> ::= ( <expression> )` occurs.
1144 */
1145 int
chkarg(SST * stkptr,int * dtype)1146 chkarg(SST *stkptr, int *dtype)
1147 {
1148 int argtyp;
1149 int sptr, sp2;
1150
1151 if (SST_PARENG(stkptr)) {
1152 switch (SST_IDG(stkptr)) {
1153 case S_CONST:
1154 argtyp = SST_DTYPEG(stkptr);
1155 if (argtyp == DT_HOLL || argtyp == DT_WORD || argtyp == DT_DWORD)
1156 argtyp = DT_INT;
1157 break;
1158
1159 case S_ACONST:
1160 /* just let mkarg() deal with it */
1161 goto call_mkarg;
1162
1163 case S_IDENT:
1164 /* resolve it */
1165 sptr = SST_SYMG(stkptr);
1166 switch (STYPEG(sptr)) {
1167 case ST_ENTRY:
1168 if (gbl.rutype != RU_FUNC)
1169 goto call_mkarg;
1170 sptr = ref_entry(sptr);
1171 goto store_var;
1172 case ST_UNKNOWN:
1173 case ST_IDENT:
1174 STYPEP(sptr, ST_VAR);
1175 /* fall through to ... */
1176 case ST_VAR:
1177 store_var:
1178 argtyp = DTYPEG(sptr);
1179 if (!DT_ISSCALAR(argtyp)) {
1180 /* could issue error message */
1181 goto call_mkarg;
1182 }
1183 if (argtyp == DT_ASSCHAR || argtyp == DT_ASSNCHAR) {
1184 /* could issue error message */
1185 goto call_mkarg;
1186 }
1187 break;
1188 case ST_USERGENERIC:
1189 if (GSAMEG(sptr)) {
1190 sptr = GSAMEG(sptr);
1191 goto call_mkarg;
1192 }
1193 /* make a scalar symbol here */
1194 sptr = newsym(sptr);
1195 STYPEP(sptr, ST_VAR);
1196 sem_set_storage_class(sptr);
1197 goto store_var;
1198 case ST_GENERIC:
1199 /* Generic used as an actual argument. Use specific of same
1200 * name. If none, then assume its a variable unless generic is
1201 * frozen.
1202 */
1203 sp2 = select_gsame(sptr); /* intrinsic of same name */
1204 if (sp2 == 0 || !EXPSTG(sptr)) {
1205 sptr = newsym(sptr);
1206 STYPEP(sptr, ST_VAR);
1207 sem_set_storage_class(sptr);
1208 goto store_var;
1209 }
1210 goto common_intrinsic;
1211 /* fall through to ... */
1212 case ST_INTRIN:
1213 case ST_PD:
1214 sp2 = sptr;
1215 if (!EXPSTG(sptr)) {
1216 sptr = newsym(sptr);
1217 STYPEP(sptr, ST_VAR);
1218 sem_set_storage_class(sptr);
1219 goto store_var;
1220 }
1221 common_intrinsic:
1222 /* fall thorugh to ... */
1223 case ST_PROC:
1224 case ST_STFUNC:
1225 case ST_STRUCT:
1226 case ST_ARRAY:
1227 goto call_mkarg;
1228
1229 default:
1230 goto call_mkarg;
1231 }
1232 break;
1233
1234 case S_LVALUE:
1235 argtyp = SST_DTYPEG(stkptr);
1236 if (!DT_ISSCALAR(argtyp)) {
1237 /* perhaps, we could issue an error message */
1238 goto call_mkarg;
1239 }
1240 if (DTY(argtyp) == TY_CHAR || DTY(argtyp) == TY_NCHAR) {
1241 /* we can't do much about char lvalues; if a substring, we
1242 * don't pass up the new length. This will lead to an incorrect
1243 * length for the temporary. Also, the same is true if it's a
1244 * subscripted passed length char array.
1245 * EVENTUALLY, will probably allocate a temp, and use the
1246 * temp's address.
1247 */
1248 goto call_mkarg;
1249 }
1250 break;
1251 default:
1252 goto call_mkarg;
1253 }
1254 /*
1255 * must parenthesize the argument.
1256 */
1257 *dtype = argtyp;
1258 (void)mkexpr(stkptr);
1259 /* always generate parens */
1260 SST_ASTP(stkptr, mk_paren((int)SST_ASTG(stkptr), argtyp));
1261 return 1;
1262 }
1263 if (SST_IDG(stkptr) == S_EXPR) {
1264 /* need to protect a scalar expression whose ast is a reference;
1265 * an example is if the expression was 'id + 0', which is reduced
1266 * to just 'id'
1267 */
1268 int ast;
1269 ast = SST_ASTG(stkptr);
1270 if (DT_ISSCALAR(A_DTYPEG(ast)) && A_ISLVAL(A_TYPEG(ast)) &&
1271 (A_TYPEG(ast) != A_ID || !POINTERG(A_SPTRG(ast)))) {
1272 ast = mk_paren(ast, (int)A_DTYPEG(ast));
1273 SST_ASTP(stkptr, ast);
1274 ;
1275 return 1;
1276 }
1277 }
1278
1279 call_mkarg:
1280 return (mkarg(stkptr, dtype));
1281 }
1282
1283 /** \brief Allocate a temporary, assign it the value, and return the temp's
1284 * base.
1285 */
1286 int
tempify(SST * stkptr)1287 tempify(SST *stkptr)
1288 {
1289 int argtyp;
1290 SST tmpsst;
1291 int tmpsym;
1292
1293 argtyp = SST_DTYPEG(stkptr);
1294 tmpsym = get_temp(argtyp);
1295 mkident(&tmpsst);
1296 SST_SYMP(&tmpsst, tmpsym);
1297 SST_LSYMP(&tmpsst, tmpsym);
1298 SST_DTYPEP(&tmpsst, argtyp);
1299 SST_SHAPEP(&tmpsst, 0);
1300 (void)add_stmt(assign(&tmpsst, stkptr));
1301 mkexpr(&tmpsst);
1302 *stkptr = tmpsst;
1303 return 1;
1304 }
1305
1306 /*---------------------------------------------------------------------*/
1307
1308 /* A function entry is referenced where the intent is to reference the
1309 * "local" variable (a ccsym created for the result). Since entries may
1310 * have different types, a "local" variable which is compatible for the
1311 * data type is found; if not, one is created.
1312 */
1313 int
ref_entry(int ent)1314 ref_entry(int ent)
1315 {
1316 int fval;
1317 int dtype;
1318 int sptr;
1319
1320 fval = FVALG(ent);
1321 if (fval) {
1322 if (DCLDG(ent) && !DCLDG(fval))
1323 DTYPEP(fval, DTYPEG(ent)); /* watch out for type after function/entry */
1324 } else {
1325 dtype = DTYPEG(ent);
1326 if (DTY(dtype) == TY_ARRAY) {
1327 fval = get_fval_array(ent);
1328 } else {
1329 fval = insert_sym(ent);
1330 pop_sym(fval);
1331 if (POINTERG(ent)) {
1332 HCCSYMP(fval, 1);
1333 }
1334 SCP(fval, SC_DUMMY); /* so optimizer doesn't delete */
1335 DCLDP(fval, 1); /* so 'undeclared' messages don't occur */
1336 if (dtype == DT_NONE) {
1337 /* an error message has been issued; just set dtype */
1338 dtype = DT_INT;
1339 }
1340 DTYPEP(fval, dtype);
1341 {
1342 STYPEP(fval, ST_VAR);
1343 }
1344 if (POINTERG(ent)) {
1345 POINTERP(fval, 1);
1346 F90POINTERP(fval, F90POINTERG(ent));
1347 if (!F90POINTERG(fval)) {
1348 get_static_descriptor(fval);
1349 get_all_descriptors(fval);
1350 }
1351 INTENTP(fval, INTENT_OUT);
1352 }
1353 ADJLENP(fval, ADJLENG(ent));
1354 ASSUMLENP(fval, ASSUMLENG(ent));
1355 }
1356 FVALP(ent, fval);
1357 if (STYPEG(ent) != ST_ENTRY) {
1358 /* prevent astout from processing */
1359 IGNOREP(fval, 1);
1360 }
1361 }
1362 if (sem.parallel || sem.task || sem.target || sem.teams
1363 || sem.orph
1364 ) {
1365 /* if in a parallel region, need to first determine if a private copy
1366 * was declared for the entry's variable in the parallel directive.
1367 * Then need to check the current scope for a default clause.
1368 */
1369 char *name;
1370 int new;
1371 if (ent == gbl.currsub) {
1372 name = SYMNAME(fval);
1373 new = getsymbol(name);
1374 } else {
1375 new = fval;
1376 }
1377 new = sem_check_scope(new, ent);
1378 if (new != ent)
1379 fval = new;
1380 }
1381 return fval;
1382 }
1383
1384 /*---------------------------------------------------------------------*/
1385
1386 /** \brief Given a generic intrinsic, select the corresponding specific of the
1387 * same name.
1388 *
1389 * Normally, the selection is performed by just accessing the GSAME field of
1390 * the generic. When an option to override the meaning of INTEGER (-noi4) is
1391 * selected, some analysis must be done to select the specific intrinsic
1392 * whose argument type matches the type implied by the option.
1393 */
1394 int
select_gsame(int gnr)1395 select_gsame(int gnr)
1396 {
1397 int spec;
1398
1399 if ((spec = GSAMEG(gnr)) == 0)
1400 return 0;
1401 if (ARGTYPG(spec) == DT_INT) {
1402 if (!flg.i4)
1403 spec = GSINTG(gnr);
1404 else if (XBIT(124, 0x10))
1405 spec = GINT8G(gnr);
1406 } else if (XBIT(124, 0x8)) {
1407 if (ARGTYPG(spec) == DT_REAL)
1408 spec = GDBLEG(gnr);
1409 else if (ARGTYPG(spec) == DT_CMPLX)
1410 spec = GDCMPLXG(gnr);
1411 }
1412 return spec;
1413 }
1414
1415 /*---------------------------------------------------------------------*/
1416
1417 static int
get_fval_array(int ent)1418 get_fval_array(int ent)
1419 {
1420 int sptr;
1421 int dtype;
1422 ADSC *ad;
1423
1424 if (FVALG(ent)) {
1425 sptr = insert_sym(FVALG(ent));
1426 } else {
1427 sptr = insert_sym(ent);
1428 }
1429 pop_sym(sptr);
1430 dtype = DTYPEG(ent);
1431 HCCSYMP(sptr, 1);
1432 DCLDP(sptr, 1);
1433 SCOPEP(sptr, stb.curr_scope);
1434 DTYPEP(sptr, dtype);
1435 ADJLENP(sptr, ADJLENG(ent));
1436 ASSUMLENP(sptr, ASSUMLENG(ent));
1437
1438 SCP(sptr, SC_DUMMY);
1439 INTENTP(sptr, INTENT_OUT);
1440 if (!POINTERG(ent)) {
1441 ad = AD_DPTR(dtype);
1442 if (AD_ADJARR(ad)) {
1443 ADJARRP(sptr, 1);
1444 ADJARRP(ent, 1);
1445 } else if (AD_DEFER(ad)) {
1446 ASSUMSHPP(sptr, 1);
1447 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
1448 SDSCS1P(sptr, 1);
1449 ASSUMSHPP(ent, 1);
1450 } else if (AD_ASSUMSZ(ad)) {
1451 ASUMSZP(sptr, 1);
1452 ASUMSZP(ent, 1);
1453 SEQP(sptr, 1);
1454 }
1455 }
1456
1457 else {
1458 STYPEP(sptr, ST_ARRAY);
1459 if (POINTERG(ent)) {
1460 POINTERP(sptr, 1);
1461 F90POINTERP(sptr, F90POINTERG(ent));
1462 if (!F90POINTERG(sptr)) {
1463 get_static_descriptor(sptr);
1464 get_all_descriptors(sptr);
1465 }
1466 }
1467 }
1468
1469 return sptr;
1470 }
1471
1472 /*---------------------------------------------------------------------*/
1473
1474 /** \brief Make a keyword string for a ST_PROC. */
1475 char *
make_kwd_str(int ext)1476 make_kwd_str(int ext)
1477 {
1478 char *kwd_str;
1479 kwd_str = make_keyword_str(PARAMCTG(ext), DPDSCG(ext));
1480 return kwd_str;
1481 }
1482
1483 /** \brief Make a keyword string from the DPDSC auxiliary structure. */
1484 char *
make_keyword_str(int paramct,int dpdsc)1485 make_keyword_str(int paramct, int dpdsc)
1486 {
1487 int cnt;
1488 int arg; /* argument sptr */
1489 int i;
1490 char *name;
1491 int optional;
1492 int len;
1493 int size;
1494 int avl;
1495 char *kwd_str;
1496 int td;
1497
1498 avl = 0;
1499 size = 100;
1500 NEW(kwd_str, char, size);
1501 for (cnt = paramct; cnt > 0; dpdsc++, cnt--) {
1502 if ((arg = *(aux.dpdsc_base + dpdsc))) {
1503 optional = OPTARGG(arg);
1504 name = SYMNAME(arg);
1505 len = strlen(name);
1506 td = CLASSG(arg) && CCSYMG(arg);
1507 if (HCCSYMG(arg) && DESCARRAYG(arg) && STYPEG(arg) == ST_DESCRIPTOR)
1508 td = 1;
1509 } else {
1510 /* alternate returns */
1511 optional = 0;
1512 name = "&";
1513 len = 1;
1514 td = 0;
1515 }
1516 i = avl;
1517 avl += (optional + len + 2); /* len chars in name, 1 for ' ', 1 for null */
1518 NEED(avl, kwd_str, char, size, size + 100);
1519 if (optional)
1520 kwd_str[i++] = '*';
1521 else if (td)
1522 kwd_str[i++] = '!';
1523 strcpy(kwd_str + i, name);
1524 if (cnt > 1)
1525 kwd_str[i + len] = ' ';
1526 avl--;
1527 }
1528
1529 return kwd_str;
1530 }
1531
1532 /*---------------------------------------------------------------------*/
1533
1534 /** \defgroup args Positional and keyword arguments
1535 *
1536 * Support for extracting positional or keyword arguments for an intrinsic.
1537 * For each intrinsic, the symbol table utility has created a string which
1538 * defines the arguments and their positions in the argument list and
1539 * keywords.
1540 *
1541 * Optional arguments are indicating by prefixing their keywords with '*'.
1542 *
1543 * @{
1544 */
1545
1546 static LOGICAL user_subr = FALSE; /**< TRUE if invoking a user subprogram */
1547 static int nz_digit_str(char *);
1548
1549 /** \brief Extract the arguments from the semantic list into `sem.argpos[]` in
1550 * positional order.
1551 * \param list list of arguments
1552 * \param cnt maximum number of arguments allowed for intrinsic
1553 * \param kwdarg string defining position and keywords of arguments
1554 */
1555 LOGICAL
get_kwd_args(ITEM * list,int cnt,char * kwdarg)1556 get_kwd_args(ITEM *list, int cnt, char *kwdarg)
1557 {
1558 return get_keyword_args(list, cnt, kwdarg, 0, 0);
1559 }
1560
1561 /** \brief Similar to get_kwd_args but can also specify a pass-object dummy
1562 * argument.
1563 * \param list list of arguments
1564 * \param cnt maximum number of arguments allowed for intrinsic
1565 * \param kwdarg string defining position and keywords of arguments
1566 * \param pod if set indicates there is a passed-object dummy argument
1567 * \param pass_pos index of the passed-object dummy argument when pod is set
1568 */
1569 static LOGICAL
get_keyword_args(ITEM * list,int cnt,char * kwdarg,int pod,int pass_pos)1570 get_keyword_args(ITEM *list, int cnt, char *kwdarg, int pod, int pass_pos)
1571 {
1572 SST *stkp;
1573 int pos;
1574 int i;
1575 char *kwd, *np;
1576 int kwd_len;
1577 char *actual_kwd; /* name of keyword used with the actual arg */
1578 int actual_kwd_len;
1579 LOGICAL kwd_present;
1580 int varpos;
1581 int varbase;
1582 int pass_pos2 = 0, pod2 = 0; /* pass object info for type bound procedure */
1583
1584 /* convention for the keyword 'variable' arguments ---
1585 * the keyword specifier is of the form
1586 * #<pos>#<base>#<kwd>
1587 * where,
1588 * <pos> = digit indicating the zero-relative positional index where
1589 * the variable arguments begin in the argument list.
1590 * <base> = digit indicating value to be subtracted from the digit
1591 * string suffix of the keyword.
1592 * <kwd> = name of the keyword which varies (i.e., the prefix).
1593 */
1594
1595 kwd_present = FALSE;
1596 /* extra arguments may be stored in argpos[]; allow for 'cnt' extra args */
1597 sem.argpos = (argpos_t *)getitem(0, sizeof(argpos_t) * cnt * 2);
1598
1599 for (i = 0; i < cnt * 2; i++) {
1600 ARG_STK(i) = NULL;
1601 ARG_AST(i) = 0;
1602 }
1603
1604 if (!pod && !pass_pos) {
1605 pod2 = pass_object_dummy;
1606 pass_pos2 = pass_position;
1607 }
1608 pass_object_dummy = pass_position = 0;
1609
1610 for (pos = 0; list != ITEM_END; pos++) {
1611 if (pod && pos == pass_pos) {
1612 /* examining the position of the passed-object dummy argument;
1613 * go to the next position, but do not move the list.
1614 */
1615 continue;
1616 }
1617 stkp = list->t.stkp;
1618 if (pod2 && pos == pass_pos2) {
1619 /* pass object for type bound procedure, so set the argument
1620 * and continue. Otherwise, we may get an error since the
1621 * pass argument does not have a keyword.
1622 */
1623 ARG_STK(pos) = stkp;
1624 ARG_AST(pos) = SST_ASTG(stkp);
1625 list = list->next;
1626 continue;
1627 }
1628 if (SST_IDG(stkp) == S_KEYWORD) {
1629 kwd_present = TRUE;
1630 actual_kwd = scn.id.name + SST_CVALG(stkp);
1631 actual_kwd_len = strlen(actual_kwd);
1632 kwd = kwdarg;
1633 for (i = 0; TRUE; i++) {
1634 varbase = 0; /* variable part not seen */
1635 if (*kwd == '*')
1636 kwd++;
1637 else if (*kwd == '#') {
1638 /* #<pos>#<base>#<kwd> */
1639 kwd++;
1640 varpos = *kwd - '0'; /* numerical value of <pos> */
1641 kwd += 2;
1642 varbase = *kwd; /* digit (char) to be subtracted */
1643 kwd += 2;
1644 } else if (strncmp(kwd, "_V_", 3) == 0 && kwd[3] != ' ' &&
1645 kwd[3] != '\0') {
1646 /* Use the original argument name for VALUE dummy arguments
1647 * that have been renamed in semant.c to distinguish them from
1648 * their local copies.
1649 */
1650 kwd += 3;
1651 }
1652 kwd_len = 0;
1653 for (np = kwd; TRUE; np++, kwd_len++)
1654 if (*np == ' ' || *np == '\0')
1655 break;
1656 if (varbase && (i = nz_digit_str(actual_kwd + kwd_len)) &&
1657 strncmp(kwd, actual_kwd, kwd_len) == 0) {
1658 /* compute actual position as:
1659 * <digit suffix> - <base> + <pos>
1660 */
1661 i = i - (varbase - '0') + varpos;
1662 if (i >= cnt)
1663 goto ill_keyword;
1664 break;
1665 }
1666 if (kwd_len == actual_kwd_len &&
1667 strncmp(kwd, actual_kwd, actual_kwd_len) == 0)
1668 break;
1669 if (*np == '\0')
1670 goto ill_keyword;
1671 kwd = np + 1; /* skip over blank */
1672 }
1673 if (ARG_STK(i))
1674 goto ill_keyword;
1675 stkp = SST_E3G(stkp);
1676 ARG_STK(i) = stkp;
1677 ARG_AST(i) = SST_ASTG(stkp);
1678 } else {
1679 if (kwd_present) {
1680 error(155, 3, gbl.lineno,
1681 "Positional arguments must not follow keyword arguments", CNULL);
1682 return TRUE;
1683 }
1684 if (ARG_STK(pos)) {
1685 char print[22];
1686 kwd = kwdarg;
1687 for (i = 0; TRUE; i++) {
1688 if (*kwd == '*' || *kwd == ' ')
1689 kwd++;
1690 if (*kwd == '#') {
1691 error(79, 3, gbl.lineno, kwd + 5, "...");
1692 return TRUE;
1693 }
1694 if (*kwd == '\0') {
1695 interr("get_keyword_args, kwdnfd", pos, 3);
1696 return TRUE;
1697 }
1698 kwd_len = 0;
1699 for (np = kwd; TRUE; np++) {
1700 if (*np == ' ' || *np == '\0')
1701 break;
1702 kwd_len++;
1703 }
1704 if (i == pos)
1705 break;
1706 kwd = np;
1707 }
1708 if (kwd_len > 21)
1709 kwd_len = 21;
1710 strncpy(print, kwd, kwd_len);
1711 print[kwd_len] = '\0';
1712 error(79, 3, gbl.lineno, print, CNULL);
1713 return TRUE;
1714 }
1715 ARG_STK(pos) = stkp;
1716 ARG_AST(pos) = SST_ASTG(stkp);
1717 }
1718 list = list->next;
1719 }
1720
1721 /* determine if required argument is not present */
1722
1723 kwd = kwdarg;
1724 for (pos = 0; pos < cnt; pos++, kwd = np) {
1725 if (*kwd == ' ')
1726 kwd++;
1727 if (*kwd == '#')
1728 break;
1729 kwd_len = 0;
1730 for (np = kwd; TRUE; np++) {
1731 if (*np == ' ' || *np == '\0')
1732 break;
1733 kwd_len++;
1734 }
1735 if (*kwd == '!') {
1736 if (ARG_STK(pos) == NULL)
1737 break; /* continue; */
1738 else
1739 error(155, 3, gbl.lineno, "Too many arguments specified for call",
1740 CNULL);
1741 }
1742 if (*kwd == '*')
1743 continue;
1744 if ((pod && pos == pass_pos) || (pod2 && pos == pass_pos2))
1745 /* don't check the position of the passed-object dummy argument */
1746 ;
1747 else if (ARG_STK(pos) == NULL) {
1748 char print[22];
1749 if (kwd_len > 21)
1750 kwd_len = 21;
1751 strncpy(print, kwd, kwd_len);
1752 print[kwd_len] = '\0';
1753 error(186, kwd_present || user_subr ? 3 : 1, gbl.lineno, print, CNULL);
1754 return TRUE;
1755 }
1756 }
1757
1758 return FALSE;
1759
1760 ill_keyword:
1761 error(79, 3, gbl.lineno, actual_kwd, CNULL);
1762 return TRUE;
1763 }
1764
1765 static int
nz_digit_str(char * s)1766 nz_digit_str(char *s)
1767 {
1768 int val;
1769
1770 val = 0; /* not a nonzero digit string */
1771 for (; *s != '\0'; ++s)
1772 switch (*s) {
1773 case '0':
1774 case '1':
1775 case '2':
1776 case '3':
1777 case '4':
1778 case '5':
1779 case '6':
1780 case '7':
1781 case '8':
1782 case '9':
1783 val = val * 10 + (*s - '0');
1784 break;
1785 default:
1786 return 0;
1787 }
1788
1789 return val;
1790 }
1791
1792 /** \brief Call get_kwd_args and evaluate each argument.
1793 * \param list list of arguments
1794 * \param cnt maximum number of arguments allowed for intrinsic
1795 * \param kwdarg string defining position and keywords of arguments
1796 */
1797 LOGICAL
evl_kwd_args(ITEM * list,int cnt,char * kwdarg)1798 evl_kwd_args(ITEM *list, int cnt, char *kwdarg)
1799 {
1800 SST *stkp;
1801 int pos;
1802 int i, sptr;
1803 char *kwd, *np;
1804 int kwd_len;
1805 char *actual_kwd; /* name of keyword used with the actual arg */
1806
1807 if (get_kwd_args(list, cnt, kwdarg))
1808 return TRUE;
1809
1810 for (i = 0; i < cnt; i++) {
1811 if ((stkp = ARG_STK(i))) {
1812 if (SST_IDG(stkp) == S_IDENT && (sptr = SST_SYMG(stkp)) &&
1813 STYPEG(sptr) == ST_PROC) {
1814 /* passing a procedure as an argument */
1815 SST_DTYPEP(stkp, DTYPEG(sptr));
1816 SST_LSYMP(stkp, sptr);
1817 SST_ASTP(stkp, mk_id(sptr));
1818 } else if (SST_IDG(stkp) == S_SCONST) {
1819 (void)mkarg(stkp, &SST_DTYPEG(stkp));
1820 } else {
1821 (void)mkexpr(stkp);
1822 }
1823 ARG_AST(i) = SST_ASTG(stkp);
1824 }
1825 }
1826
1827 return FALSE;
1828 }
1829
1830 /**
1831 * \param list list of arguments
1832 * \param cnt maximum number of arguments allowed for intrinsic
1833 *
1834 * Arguments are: array, base, indx1, ..., indxn, mask<br>
1835 * where n = rank of base, mask is optional
1836 *
1837 * Don't use get_kwd_args() since it is not designed to handle an optional
1838 * argument after a variable number of arguments. Note that cnt is the
1839 * actual number of arguments; get_kwd_args() & evl_kwd_args() are passed the
1840 * the maximum number of arguments.
1841 *
1842 * If the arguments are correct, the output (ARG_STK) will be in the order:
1843 *
1844 * 0 - array
1845 * 1 - base
1846 * 2 - mask
1847 * 3 - indx1
1848 * ...
1849 * 3+n-1 - indxn
1850 */
1851 LOGICAL
sum_scatter_args(ITEM * list,int cnt)1852 sum_scatter_args(ITEM *list, int cnt)
1853 {
1854 SST *stkp;
1855 int pos;
1856 int i;
1857 char *actual_kwd; /* name of keyword used with the actual arg */
1858 int actual_kwd_len;
1859 LOGICAL kwd_present;
1860 SST *mask;
1861 int rank;
1862
1863 kwd_present = FALSE;
1864 sem.argpos = (argpos_t *)getitem(0, sizeof(argpos_t) * cnt);
1865
1866 for (i = 0; i < cnt; i++) {
1867 ARG_STK(i) = NULL;
1868 ARG_AST(i) = 0;
1869 }
1870 /*
1871 * first, place the arguments in the positional order per the spec
1872 * except that 'mask=arg' is a special case. The positional order is
1873 * array, base, indx1, ..., indxn, mask
1874 */
1875 mask = NULL; /* set only if keyword form of mask is seen */
1876 for (pos = 0; list != ITEM_END; list = list->next, pos++) {
1877 stkp = list->t.stkp;
1878 if (SST_IDG(stkp) == S_KEYWORD) {
1879 kwd_present = TRUE;
1880 actual_kwd = scn.id.name + SST_CVALG(stkp);
1881 actual_kwd_len = strlen(actual_kwd);
1882 if (strcmp("array", actual_kwd) == 0)
1883 i = 0;
1884 else if (strcmp("base", actual_kwd) == 0)
1885 i = 1;
1886 else if (strcmp("mask", actual_kwd) == 0) {
1887 mask = SST_E3G(stkp);
1888 continue;
1889 } else if (strncmp("indx", actual_kwd, 4) == 0) {
1890 if ((i = nz_digit_str(actual_kwd + 4))) {
1891 /* compute actual position as:
1892 * <digit suffix> - <base> + <pos>
1893 */
1894 i = i + 1; /* positions 2, ..., 2+n-1 */
1895 if (i >= cnt)
1896 goto ill_keyword;
1897 }
1898 }
1899 if (ARG_STK(i))
1900 goto ill_keyword;
1901 stkp = SST_E3G(stkp);
1902 ARG_STK(i) = stkp;
1903 ARG_AST(i) = SST_ASTG(stkp);
1904 } else {
1905 if (ARG_STK(pos)) {
1906 char *str;
1907 if (pos == 0)
1908 str = "array";
1909 else if (pos == 1)
1910 str = "base";
1911 else
1912 str = "indx or mask";
1913 error(79, 3, gbl.lineno, str, CNULL);
1914 return TRUE;
1915 }
1916 ARG_STK(pos) = stkp;
1917 ARG_AST(pos) = SST_ASTG(stkp);
1918 }
1919 }
1920
1921 /* determine if required argument is not present */
1922
1923 if (ARG_STK(0) == NULL) {
1924 error(186, kwd_present ? 3 : 1, gbl.lineno, "array", CNULL);
1925 return TRUE;
1926 }
1927 if (ARG_STK(1) == NULL) {
1928 error(186, kwd_present ? 3 : 1, gbl.lineno, "base", CNULL);
1929 return TRUE;
1930 }
1931
1932 stkp = ARG_STK(1);
1933 mkexpr(stkp);
1934 rank = rank_of_ast(SST_ASTG(stkp));
1935
1936 if (mask) {
1937 if (ARG_STK(cnt - 1)) {
1938 error(79, 3, gbl.lineno, "mask", CNULL);
1939 return TRUE;
1940 }
1941 if (rank != cnt - 3) {
1942 error(186, kwd_present ? 3 : 1, gbl.lineno, "indx...", CNULL);
1943 return TRUE;
1944 }
1945 } else if (rank < cnt - 2) {
1946 mask = ARG_STK(cnt - 1);
1947 if (rank != cnt - 3) {
1948 error(186, kwd_present ? 3 : 1, gbl.lineno, "indx...", CNULL);
1949 return TRUE;
1950 }
1951 } else if (rank != cnt - 2) {
1952 error(186, kwd_present ? 3 : 1, gbl.lineno, "indx...", CNULL);
1953 return TRUE;
1954 }
1955
1956 /* reposition the indx arguments so that they appear at the end */
1957
1958 for (i = 2 + rank; i > 2; i--) {
1959 ARG_STK(i) = ARG_STK(i - 1);
1960 ARG_AST(i) = ARG_AST(i - 1);
1961 }
1962
1963 ARG_STK(2) = mask;
1964 if (mask)
1965 ARG_AST(2) = SST_ASTG(mask);
1966 else
1967 ARG_AST(2) = 0;
1968
1969 /* now, evaluate the arguments */
1970
1971 for (i = 2 + rank; i >= 0; i--) {
1972 if ((stkp = ARG_STK(i))) {
1973 (void)mkexpr(stkp);
1974 ARG_AST(i) = SST_ASTG(stkp);
1975 }
1976 }
1977
1978 return FALSE;
1979
1980 ill_keyword:
1981 error(79, 3, gbl.lineno, actual_kwd, CNULL);
1982 return TRUE;
1983 }
1984
1985 /**@}*/
1986
1987 /*---------------------------------------------------------------------*/
1988
1989 /** \brief Process information for deferred interface argument checking in
1990 * in the compat_arg_lists() function below.
1991 *
1992 * If the performChk argument is false, then we save the information
1993 * (defer the check). If performChk argument is true, then we perform
1994 * the argument checking. Note: If performChk is true, then the other
1995 * arguments are ignored.
1996 *
1997 * \param formal is the symbol table pointer of the dummy/formal argument.
1998 * \param actual is the symbol table pointer of the actual argument.
1999 * \param flags are comparison flags that enable/disable certain checks
2000 * \param lineno is the source line number for the deferred check
2001 * \param performChk is false to defer checks and true to perform the checks.
2002 */
2003 void
defer_arg_chk(SPTR formal,SPTR actual,SPTR subprog,cmp_interface_flags flags,int lineno,bool performChk)2004 defer_arg_chk(SPTR formal, SPTR actual, SPTR subprog,
2005 cmp_interface_flags flags, int lineno, bool performChk)
2006 {
2007
2008 typedef struct chkList {
2009 char *formal;
2010 SPTR actual;
2011 char *subprog;
2012 cmp_interface_flags flags;
2013 int lineno;
2014 struct chkList * next;
2015 }CHKLIST;
2016
2017 static CHKLIST *list = NULL;
2018 CHKLIST *ptr, *prev;
2019
2020 if (!performChk) {
2021 /* Add a deferred check to the list */
2022 NEW(ptr, CHKLIST, sizeof(CHKLIST));
2023 NEW(ptr->formal, char, strlen(SYMNAME(formal))+1);
2024 strcpy(ptr->formal, SYMNAME(formal));
2025 ptr->actual = actual;
2026 NEW(ptr->subprog, char, strlen(SYMNAME(subprog))+1);
2027 strcpy(ptr->subprog, SYMNAME(subprog));
2028 ptr->flags = flags;
2029 ptr->lineno = lineno;
2030 ptr->next = list;
2031 list = ptr;
2032 } else if (sem.which_pass == 1) {
2033 for(prev = ptr = list; ptr != NULL; ) {
2034 if (strcmp(SYMNAME(gbl.currsub),ptr->subprog) == 0) {
2035 /* perform argument check */
2036 formal = getsym(ptr->formal, strlen(ptr->formal));
2037 if (!compatible_characteristics(formal, ptr->actual, ptr->flags)) {
2038 char details[1000];
2039 sprintf(details, "- arguments of %s and %s do not agree",
2040 SYMNAME(ptr->actual), ptr->formal);
2041 error(74, 3, ptr->lineno, ptr->subprog, details);
2042 }
2043 if (prev == ptr) {
2044 prev = ptr->next;
2045 FREE(ptr->formal);
2046 FREE(ptr->subprog);
2047 FREE(ptr);
2048 list = ptr = prev;
2049 } else {
2050 prev->next = ptr->next;
2051 FREE(ptr->formal);
2052 FREE(ptr->subprog);
2053 FREE(ptr);
2054 ptr = prev->next;
2055 }
2056 } else {
2057 prev = ptr;
2058 ptr = ptr->next;
2059 }
2060 }
2061 }
2062
2063 }
2064
2065
2066
2067 /** \brief For arguments that are subprograms, check that their argument lists
2068 * are compatible.
2069 */
2070 static LOGICAL
compat_arg_lists(int formal,int actual)2071 compat_arg_lists(int formal, int actual)
2072 {
2073 int paramct;
2074 int fdscptr, adscptr;
2075 int i;
2076 bool func_chk;
2077 cmp_interface_flags flags;
2078
2079 /* TODO: Not checking certain cases for now. */
2080 if (STYPEG(actual) == ST_INTRIN || STYPEG(actual) == ST_GENERIC)
2081 return TRUE;
2082
2083 flags = (IGNORE_ARG_NAMES | RELAX_STYPE_CHK | RELAX_POINTER_CHK |
2084 RELAX_PURE_CHK_2);
2085 func_chk = (STYPEG(formal) == ST_PROC && STYPEG(actual) == ST_PROC &&
2086 FVALG(formal) && FVALG(actual));
2087
2088 if (func_chk && resolve_sym_aliases(SCOPEG(SCOPEG(formal))) == gbl.currsub){
2089 flags |= DEFER_IFACE_CHK;
2090 }
2091
2092 if (func_chk && !compatible_characteristics(formal, actual, flags)) {
2093 return FALSE;
2094 }
2095
2096 if (flags & DEFER_IFACE_CHK) {
2097 /* We are calling an internal subprogram. We need to defer the
2098 * check on the procedure dummy argument until we have seen the
2099 * internal subprogram.
2100 */
2101 defer_arg_chk(formal, actual, SCOPEG(formal), (flags ^ DEFER_IFACE_CHK),
2102 gbl.lineno, false);
2103 }
2104
2105 fdscptr = DPDSCG(formal);
2106 adscptr = DPDSCG(actual);
2107 if (fdscptr == 0 || adscptr == 0 || (flags & DEFER_IFACE_CHK)) {
2108 return TRUE; /* No dummy parameter descriptor; can't check. */
2109 }
2110 paramct = PARAMCTG(formal);
2111 if (PARAMCTG(actual) != paramct)
2112 return FALSE;
2113 for (i = 0; i < paramct; i++, fdscptr++, adscptr++) {
2114 int farg, aarg;
2115
2116 farg = *(aux.dpdsc_base + fdscptr);
2117 aarg = *(aux.dpdsc_base + adscptr);
2118 if (STYPEG(farg) == ST_PROC) {
2119 if (STYPEG(aarg) != ST_PROC && STYPEG(aarg) != ST_ENTRY &&
2120 STYPEG(aarg) != ST_INTRIN && STYPEG(aarg) != ST_GENERIC)
2121 return FALSE;
2122 if (!compat_arg_lists(farg, aarg))
2123 return FALSE;
2124 /* If not functions, don't try to check return type. */
2125 if (!DCLDG(farg) && !FUNCG(farg) && !DCLDG(aarg) && !FUNCG(aarg))
2126 continue;
2127 }
2128 if (!cmpat_dtype_with_size(DTYPEG(farg), DTYPEG(aarg)))
2129 return FALSE;
2130 }
2131 return TRUE;
2132 }
2133
2134 /** \brief Check arguments passed to a user subprogram which has an interface
2135 * block. Its keyword string is available and is located by kwd_str.
2136 */
2137 LOGICAL
check_arguments(int ext,int count,ITEM * list,char * kwd_str)2138 check_arguments(int ext, int count, ITEM *list, char *kwd_str)
2139 {
2140 int dpdsc;
2141 int paramct;
2142 paramct = PARAMCTG(ext);
2143 dpdsc = DPDSCG(ext);
2144 return chk_arguments(ext, count, list, kwd_str, paramct, dpdsc, 0, NULL);
2145 }
2146 /** \brief Check arguments passed to a user subprogram which has an interface
2147 * block. Its keyword string is available and is located by kwd_str.
2148 *
2149 * NOTE: if callee is non-zero, the call is via some procedure pointer, and
2150 * callee is the ast of pointer and ext will be the sptr of the pointer
2151 * variable or member. Otherwise, callee is 0 and ext is the sptr of the
2152 * subroutine/function.
2153 */
2154 LOGICAL
chk_arguments(int ext,int count,ITEM * list,char * kwd_str,int paramct,int dpdsc,int callee,int * p_pass_pos)2155 chk_arguments(int ext, int count, ITEM *list, char *kwd_str, int paramct,
2156 int dpdsc, int callee, int *p_pass_pos)
2157 {
2158 int i;
2159
2160 if (p_pass_pos)
2161 *p_pass_pos = -1; /* < 0 = > NO passed object */
2162 if (count > paramct) {
2163 error(187, 3, gbl.lineno, SYMNAME(ext), CNULL);
2164 return TRUE;
2165 }
2166 if (callee == 0 || A_TYPEG(callee) != A_MEM || !PASSG(ext)) {
2167 user_subr = TRUE;
2168 if (get_kwd_args(list, paramct, kwd_str)) {
2169 user_subr = FALSE;
2170 return TRUE;
2171 }
2172 } else {
2173 /* component procedure pointer with a passed-object dummy argument */
2174 int pass_pos;
2175 int pdum;
2176
2177 pdum = PASSG(ext);
2178 if (!tk_match_arg(DTYPEG(pdum), A_DTYPEG(A_PARENTG(callee)), TRUE)) {
2179 error(155, 3, gbl.lineno,
2180 "Type mismatch for the passed-object dummy argument",
2181 SYMNAME(pdum));
2182 return TRUE;
2183 }
2184 for (i = 0; i < paramct; i++) {
2185 if (pdum == aux.dpdsc_base[dpdsc + i]) {
2186 pass_pos = i;
2187 break;
2188 }
2189 }
2190 if (pass_pos >= paramct) {
2191 /* This should not happen since semant has already searched for
2192 * the passed-object dummy. Just call it a type mismatch error!.
2193 */
2194 error(155, 3, gbl.lineno,
2195 "Type mismatch for the passed-object dummy argument",
2196 SYMNAME(pdum));
2197 return TRUE;
2198 }
2199 user_subr = TRUE;
2200 if (get_keyword_args(list, paramct, kwd_str, 1, pass_pos)) {
2201 user_subr = FALSE;
2202 return TRUE;
2203 }
2204 *p_pass_pos = pass_pos;
2205 }
2206 user_subr = FALSE;
2207
2208 for (i = 0; i < paramct; i++, dpdsc++) {
2209 SST *sp;
2210 int dum;
2211 int actual;
2212 int arg;
2213 char buf[32];
2214 int sptr;
2215 int doif;
2216
2217 sprintf(buf, "%d", i + 1); /* prepare for error messages */
2218 if ((sp = ARG_STK(i))) {
2219 (void)chkarg(sp, &dum);
2220 XFR_ARGAST(i);
2221 }
2222 actual = ARG_AST(i);
2223 arg = aux.dpdsc_base[dpdsc];
2224
2225 if (arg) {
2226 if (!actual) {
2227 /* optional argument not present; store in the ast entry
2228 * the number of ast arguments which must be filled in with
2229 * the 'null' pointer (astb.ptr0).
2230 */
2231 ARG_AST(i) = 1;
2232 } else {
2233 int ddum, dact, elddum, eldact;
2234 int shape;
2235 LOGICAL dum_is_proc;
2236
2237 if (STYPEG(arg) == ST_ENTRY || STYPEG(arg) == ST_PROC) {
2238 dum_is_proc = TRUE;
2239 if (FVALG(arg))
2240 ddum = DTYPEG(FVALG(arg));
2241 else
2242 ddum = DTYPEG(arg);
2243 } else {
2244 dum_is_proc = FALSE;
2245 ddum = DTYPEG(arg);
2246 }
2247 elddum = DDTG(ddum);
2248 dact = A_DTYPEG(actual);
2249 eldact = DDTG(dact);
2250 shape = A_SHAPEG(actual);
2251 if (DTY(eldact) == TY_PTR && DTY(elddum) == TY_PROC) {
2252 eldact = DTY(eldact + 1);
2253 eldact = DDTG(eldact);
2254 } else if (DTY(eldact) == TY_PROC && DTY(elddum) == TY_PTR) {
2255 elddum = DTY(elddum + 1);
2256 elddum = DDTG(elddum);
2257 } else if (dum_is_proc && DTY(eldact) == TY_PTR) {
2258 eldact = DTY(eldact + 1);
2259 if (DTY(eldact) == TY_PROC && DTY(eldact + 5)) {
2260 int ss;
2261 ss = DTY(eldact + 5);
2262 if (FVALG(ss))
2263 eldact = DTYPEG(FVALG(ss));
2264 else
2265 eldact = DTYPEG(ss);
2266 }
2267 eldact = DDTG(eldact);
2268 }
2269 if (STYPEG(arg) == ST_ARRAY) {
2270 if (shape == 0) {
2271 int tmp;
2272 tmp = actual;
2273 if (A_TYPEG(tmp) == A_SUBSTR)
2274 tmp = A_LOPG(tmp);
2275 if (ASSUMSHPG(arg)) {
2276 /* if the dummy is assumed-shape,
2277 * the user is trying to pass a scalar, constant
2278 * or array element into an assumed-shape array
2279 * error */
2280 error(189, 3, gbl.lineno, buf, SYMNAME(ext));
2281 continue;
2282 }
2283 if (A_TYPEG(tmp) != A_SUBSCR) {
2284 /* if the dummy is not assumed-shape
2285 * (explicit-shape or assumed-size), the user is
2286 * trying to pass a scalar or constant
2287 * to an array; give warning unless -Mstandard */
2288 if (ignore_tkr(arg, IGNORE_R))
2289 continue;
2290 if (DTY(eldact) == TY_CHAR || DTY(eldact) == TY_NCHAR)
2291 /*
2292 * It's legal for a character scalar to be
2293 * passed to a character array. This takes
2294 * care of a scalar to an array but sill
2295 * need to check types, POINTER, etc.
2296 */
2297 ;
2298 else {
2299 if (flg.standard) {
2300 error(189, 3, gbl.lineno, buf, SYMNAME(ext));
2301 continue;
2302 }
2303 error(189, 2, gbl.lineno, buf, SYMNAME(ext));
2304 /*
2305 * continue with checking types, POINTER, etc.
2306 */
2307 }
2308 }
2309 }
2310 } else if (STYPEG(arg) == ST_PROC) {
2311 while (A_TYPEG(actual) == A_MEM) {
2312 actual = A_MEMG(actual);
2313 }
2314 if (A_TYPEG(actual) != A_ID) {
2315 error(447, 3, gbl.lineno, buf, SYMNAME(ext));
2316 continue;
2317 }
2318 sptr = A_SPTRG(actual);
2319 if (STYPEG(sptr) != ST_PROC && STYPEG(sptr) != ST_ENTRY &&
2320 STYPEG(sptr) != ST_INTRIN && STYPEG(sptr) != ST_GENERIC &&
2321 !(DTY(DTYPEG(sptr)) == TY_PTR &&
2322 DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC)) {
2323 error(447, 3, gbl.lineno, buf, SYMNAME(ext));
2324 continue;
2325 }
2326 /* FS#3742 Check that argument lists are compatible. */
2327 if (!compat_arg_lists(arg, sptr)) {
2328 char details[1000];
2329 sprintf(details, "- arguments of %s and %s do not agree",
2330 SYMNAME(sptr), SYMNAME(arg));
2331 error(74, 3, gbl.lineno, SYMNAME(ext), details);
2332 continue;
2333 }
2334 if (ddum == 0) {
2335 /* formal has no dtype; was actual explicitly typed? */
2336 if (DCLDG(sptr) && DTYPEG(sptr) &&
2337 !(DTY(DTYPEG(sptr)) == TY_PTR &&
2338 DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC)) {
2339 /* actual was given a datatype */
2340 error(448, 3, gbl.lineno, buf, SYMNAME(ext));
2341 }
2342 continue;
2343 }
2344 if (dact == 0) {
2345 /* actual has no datatype; was the formal explicitly typed? */
2346 if (DCLDG(arg)) { /* formal was declared */
2347 error(449, 3, gbl.lineno, buf, SYMNAME(ext));
2348 }
2349 continue;
2350 }
2351 if (!DCLDG(arg) && !FUNCG(arg) && !DCLDG(sptr) && !FUNCG(sptr))
2352 /* formal & actual are subroutines?? */
2353 continue;
2354 }
2355 if (DTY(ddum) == TY_ARRAY) {
2356 if (ASSUMSHPG(arg) && !ignore_tkr(arg, IGNORE_R)) {
2357 if (shape == 0) {
2358 error(189, 3, gbl.lineno, buf, SYMNAME(ext));
2359 continue;
2360 }
2361 if (ADD_NUMDIM(ddum) != SHD_NDIM(shape)) {
2362 error(446, 3, gbl.lineno, buf, SYMNAME(ext));
2363 continue;
2364 }
2365 if (!cmpat_arr_arg(ddum, shape)) {
2366 error(190, 3, gbl.lineno, buf, SYMNAME(ext));
2367 continue;
2368 }
2369 if (SHD_UPB(shape, SHD_NDIM(shape) - 1) == 0) {
2370 error(191, 3, gbl.lineno, buf, SYMNAME(ext));
2371 continue;
2372 }
2373 }
2374 } else if (is_iso_cloc(actual)) {
2375
2376 /* smooth LOC() typechecking ? */
2377 A_DTYPEP(actual, elddum);
2378 eldact = elddum;
2379 } else if (!ELEMENTALG(ext) && DTY(dact) == TY_ARRAY) {
2380 /* scalar passed to array */
2381 if (!ignore_tkr(arg, IGNORE_R))
2382 error(446, 3, gbl.lineno, buf, SYMNAME(ext));
2383 continue;
2384 }
2385 /* Check if types of actual and dummy match.
2386 * When the the procedure argument is a procedure, the
2387 * type of the dummy may not be available. When the actual
2388 * is an ST_PROC and the dummy is an ST_IDENT, don't check
2389 * the case if the ST_PROC's FVAL field is not set.
2390 */
2391 if (A_TYPEG(actual) != A_ID ||
2392 (STYPEG(A_SPTRG(actual)) != ST_PROC || FVALG(A_SPTRG(actual))) ||
2393 STYPEG(arg) != ST_IDENT) {
2394 if (DTY(elddum) != DTY(eldact)) {
2395 if (eldact == 0 && STYPEG(sym_of_ast(actual)) == ST_PROC &&
2396 IS_PROC_DUMMYG(arg)) {
2397 continue;
2398 }
2399 if (DTY(elddum) == TY_DERIVED && UNLPOLYG(DTY(elddum + 3)))
2400 continue; /* FS#18004 */
2401 /* TY_ values are not the same */
2402 if (same_type_different_kind(elddum, eldact)) {
2403 /* kind differs */
2404 if (!ignore_tkr(arg, IGNORE_K))
2405 error(450, 3, gbl.lineno, buf, SYMNAME(ext));
2406 else {
2407 if (PASSBYVALG(arg) && DT_ISNUMERIC(DTYPEG(arg))) {
2408 /*
2409 * ensure the arg's semantic stack is
2410 * evaluated and converted; this obviates
2411 * the need for checking IGNORE_TKRG(
2412 * param_dummy) in * semfunc.c:func_call2()
2413 * - June 17,2015
2414 */
2415 (void)cngtyp(ARG_STK(i), DTYPEG(arg));
2416 XFR_ARGAST(i);
2417 }
2418 }
2419 } else if (DTY(eldact) == TY_WORD) {
2420 if (A_TYPEG(actual) == A_INTR && A_OPTYPEG(actual) == I_NULL &&
2421 A_ARGCNTG(actual) == 0 && POINTERG(arg)) {
2422 /* NULL() matches any POINTER formal */
2423 ;
2424 } else if (DT_ISWORD(elddum))
2425 ;
2426 else if (DT_ISDWORD(elddum)) {
2427 ARG_AST(i) = mk_convert(ARG_AST(i), DT_DWORD);
2428 } else {
2429 /* type differs */
2430 if (!ignore_tkr(arg, IGNORE_T))
2431 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2432 }
2433 } else if (DTY(eldact) == TY_DWORD) {
2434 if (DT_ISDWORD(elddum))
2435 ;
2436 else if (DT_ISWORD(elddum)) {
2437 ARG_AST(i) = mk_convert(ARG_AST(i), DT_WORD);
2438 } else {
2439 /* type differs */
2440 if (!ignore_tkr(arg, IGNORE_T))
2441 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2442 }
2443 } else {
2444 /* type differs */
2445 if (!ignore_tkr(arg, IGNORE_T))
2446 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2447 else if (!ignore_tkr(arg, IGNORE_K) &&
2448 !different_type_same_kind(elddum, eldact))
2449 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2450 }
2451 continue;
2452 }
2453 /* check if type and kind of the data types match */
2454 if (!ignore_tkr(arg, IGNORE_T) &&
2455 !tk_match_arg(elddum, eldact, CLASSG(arg))) {
2456 if (DTY(elddum) != TY_DERIVED || !UNLPOLYG(DTY(elddum + 3))) {
2457 int mem;
2458 mem = get_generic_member(elddum, ext);
2459 if (!mem) {
2460 mem = get_generic_member(eldact, ext);
2461 }
2462 if (!mem || NOPASSG(mem)) {
2463 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2464 continue;
2465 }
2466 if (i == 0 && !PASSG(mem) &&
2467 !tk_match_arg(eldact, elddum, CLASSG(arg))) {
2468 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2469 continue;
2470 }
2471 if (PASSG(mem) &&
2472 strcmp(SYMNAME(PASSG(mem)), SYMNAME(arg)) == 0 &&
2473 !tk_match_arg(eldact, elddum, CLASSG(arg))) {
2474 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2475 continue;
2476 }
2477 }
2478 }
2479 }
2480 if (POINTERG(arg)) {
2481 if (INTENTG(arg) != INTENT_IN) {
2482 int s;
2483 int iface;
2484 s = 0;
2485 switch (A_TYPEG(actual)) {
2486 case A_ID:
2487 case A_MEM:
2488 s = memsym_of_ast(actual);
2489 break;
2490 case A_FUNC:
2491 s = A_SPTRG(A_LOPG(actual));
2492 proc_arginfo(s, NULL, NULL, &iface);
2493 s = iface;
2494 break;
2495 case A_INTR:
2496 if (A_OPTYPEG(actual) == I_NULL)
2497 s = A_SPTRG(A_LOPG(actual));
2498 break;
2499 }
2500 if (s == 0 || (!POINTERG(s) &&
2501 !(STYPEG(s) == ST_PD && PDNUMG(s) == PD_null))) {
2502 sprintf(buf, "%d (non-POINTER)", i + 1);
2503 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2504 continue;
2505 }
2506 } else if (IS_CHAR_TYPE(DTYG(DTYPEG(arg)))) {
2507 if (!IS_CHAR_TYPE(DTYG(A_DTYPEG(actual)))) {
2508 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2509 continue;
2510 }
2511 /* dummy must be adjustable length or the sizes must match */
2512 if (!ADJLENG(arg) && !eq_dtype(DTYPEG(arg), A_DTYPEG(actual))) {
2513 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2514 continue;
2515 }
2516 } else if (!eq_dtype2(DTYPEG(arg), A_DTYPEG(actual), TRUE)) {
2517 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2518 continue;
2519 } else if (CONTIGATTRG(arg) && !simply_contiguous(actual)) {
2520 error(546, 3, gbl.lineno, SYMNAME(arg), NULL);
2521 continue;
2522 }
2523 }
2524 if (ALLOCATTRG(arg)) {
2525 int s;
2526 int iface;
2527 s = 0;
2528 switch (A_TYPEG(actual)) {
2529 case A_ID:
2530 s = A_SPTRG(actual);
2531 break;
2532 case A_FUNC:
2533 s = A_SPTRG(A_LOPG(actual));
2534 proc_arginfo(s, NULL, NULL, &iface);
2535 s = iface;
2536 s = FVALG(s);
2537 break;
2538 case A_MEM:
2539 s = A_SPTRG(A_MEMG(actual));
2540 break;
2541 }
2542 if (s == 0 || !ALLOCATTRG(s)) {
2543 sprintf(buf, "%d (non-allocatable)", i + 1);
2544 error(188, 3, gbl.lineno, buf, SYMNAME(ext));
2545 continue;
2546 }
2547 NOALLOOPTP(s, 1);
2548 }
2549 }
2550 if (PASSBYVALG(arg)) {
2551 if (INTENTG(arg) == INTENT_OUT) {
2552 error(134, 3, gbl.lineno, "- INTENT(OUT) conflicts with VALUE",
2553 CNULL);
2554 continue;
2555 }
2556 if (INTENTG(arg) == INTENT_INOUT) {
2557 error(134, 3, gbl.lineno, "- INTENT(INOUT) conflicts with VALUE",
2558 CNULL);
2559 continue;
2560 }
2561 }
2562 if (actual && !A_ISLVAL(A_TYPEG(actual)) &&
2563 (INTENTG(arg) == INTENT_OUT || INTENTG(arg) == INTENT_INOUT)) {
2564 error(193, 2, gbl.lineno, buf, SYMNAME(ext));
2565 continue;
2566 }
2567 if (actual && A_ISLVAL(A_TYPEG(actual)) &&
2568 (INTENTG(arg) == INTENT_OUT || INTENTG(arg) == INTENT_INOUT)) {
2569 if (POINTERG(arg)) {
2570 /*
2571 * The formal argument is a pointer; the corresponding
2572 * actual cannot be an intent(in) argument.
2573 */
2574 sptr = find_pointer_variable(actual);
2575 if (sptr && POINTERG(sptr))
2576 (void)chk_pointer_intent(sptr, actual);
2577 if (is_protected(sym_of_ast(actual))) {
2578 err_protected(sptr, "be an actual argument when the dummy argument "
2579 "is INTENT(OUT) or INTENT(INOUT)");
2580 }
2581 } else if (A_TYPEG(actual) == A_ID &&
2582 SCG(A_SPTRG(actual)) == SC_DUMMY &&
2583 INTENTG(A_SPTRG(actual)) == INTENT_IN &&
2584 !POINTERG(A_SPTRG(actual)))
2585 error(193, 2, gbl.lineno, buf, SYMNAME(ext));
2586 }
2587 if (!ALLOCATTRG(arg) && ASSUMSHPG(arg) && actual) {
2588 /* full descriptor required for 'arg' */
2589 int aid;
2590 switch (A_TYPEG(actual)) {
2591 case A_SUBSCR:
2592 aid = A_LOPG(actual);
2593 if (aid && A_TYPEG(aid) == A_ID) {
2594 sptr = A_SPTRG(aid);
2595 goto chk_allocatable;
2596 }
2597 break;
2598 case A_ID:
2599 sptr = A_SPTRG(actual);
2600 goto chk_allocatable;
2601 case A_MEM:
2602 sptr = A_SPTRG(A_MEMG(actual));
2603 chk_allocatable:
2604 if (ALLOCATTRG(sptr)) {
2605 ALLOCDESCP(sptr, TRUE);
2606 }
2607 default:
2608 break;
2609 }
2610 }
2611 } else {
2612 if (actual == 0 || A_TYPEG(actual) != A_LABEL) {
2613 /* alternate returns */
2614 error(192, 3, gbl.lineno, buf, SYMNAME(ext));
2615 }
2616 }
2617 }
2618
2619 return FALSE;
2620 }
2621
2622 LOGICAL
ignore_tkr(int arg,int tkr)2623 ignore_tkr(int arg, int tkr)
2624 {
2625 /*
2626 * Is it ok to ignore checking the specified TKR based on the presence
2627 * and value of the IGNORE_TKR directive?
2628 *
2629 * NOTE: * If we need to ignore the effects of the IGNORE_TKR directive,
2630 * guard the following 'if' with a test of an XBIT or whatever.
2631 */
2632 if (tkr == IGNORE_C && (IGNORE_TKRG(arg) & IGNORE_C) && ASSUMSHPG(arg))
2633 return TRUE;
2634 if ((IGNORE_TKRG(arg) & tkr) &&
2635 (ignore_tkr_all(arg) ||
2636 (!ASSUMSHPG(arg) && !POINTERG(arg) && !ALLOCATTRG(arg))))
2637 return TRUE;
2638 return FALSE;
2639 }
2640
2641 LOGICAL
ignore_tkr_all(int arg)2642 ignore_tkr_all(int arg)
2643 {
2644 if (((IGNORE_TKRG(arg) & IGNORE_TKR_ALL) == IGNORE_TKR_ALL) ||
2645 ((IGNORE_TKRG(arg) & IGNORE_TKR_ALL) == IGNORE_TKR_ALL0))
2646 return TRUE;
2647 return FALSE;
2648 }
2649
2650 /** \brief Check conformance of two arrays, where the first array is described
2651 * with a dtype record, and the second is described with a shape
2652 * descriptor.
2653 *
2654 * Return true if the data types for two shapes are conformable (have the same
2655 * shape). Shape is defined to be the rank and the extents of each dimension.
2656 */
2657 static LOGICAL
cmpat_arr_arg(int d1,int shape2)2658 cmpat_arr_arg(int d1, int shape2)
2659 {
2660 int ndim;
2661 int i;
2662 int bnd;
2663 ADSC *ad1;
2664 INT lb1, lb2; /* lower bounds if constants */
2665 INT ub1, ub2; /* upper bounds if constants */
2666 INT st2; /* stride of shape2 if constant */
2667
2668 ad1 = AD_DPTR(d1);
2669 ndim = AD_NUMDIM(ad1);
2670 if (ndim != SHD_NDIM(shape2))
2671 return FALSE;
2672
2673 for (i = 0; i < ndim; i++) {
2674 if ((bnd = AD_LWAST(ad1, i))) {
2675 if ((bnd = A_ALIASG(bnd)) == 0)
2676 continue; /* nonconstant bound => skip this dimension */
2677 lb1 = get_int_cval(A_SPTRG(bnd));
2678 } else
2679 lb1 = 1; /* no lower bound => 1 */
2680
2681 if ((bnd = AD_UPAST(ad1, i))) {
2682 if ((bnd = A_ALIASG(bnd)) == 0)
2683 continue; /* nonconstant bound => skip this dimension */
2684 ub1 = get_int_cval(A_SPTRG(bnd));
2685 } else
2686 continue; /* no upper bound => skip this dimension */
2687
2688 if ((lb2 = A_ALIASG(SHD_LWB(shape2, i))) == 0)
2689 continue; /* not a constant => skip this dimension */
2690 lb2 = get_int_cval(A_SPTRG(lb2));
2691
2692 if ((ub2 = A_ALIASG(SHD_UPB(shape2, i))) == 0)
2693 continue; /* not a constant => skip this dimension */
2694 ub2 = get_int_cval(A_SPTRG(ub2));
2695
2696 if ((st2 = A_ALIASG(SHD_STRIDE(shape2, i))) == 0)
2697 continue; /* not a constant => skip this dimension */
2698 st2 = get_int_cval(A_SPTRG(st2));
2699
2700 /* lower and upper bounds and stride are constants in this dimension*/
2701
2702 if ((ub1 - lb1 + 1) != (ub2 - lb2 + st2) / st2)
2703 return FALSE;
2704 }
2705
2706 return TRUE;
2707 }
2708
2709 static int iface_arg(int, int, int);
2710
2711 int
iface_intrinsic(int sptr)2712 iface_intrinsic(int sptr)
2713 {
2714 int ii;
2715 int paramct, dtyper, argdtype;
2716 int ss;
2717 int iface, arg, dpdsc, fval;
2718 char *kwd, *np;
2719 int kwd_len;
2720 int optional;
2721
2722 ii = INTASTG(sptr);
2723 switch (ii) {
2724 case I_ABS: /* abs */
2725 paramct = 1;
2726 dtyper = DT_REAL;
2727 argdtype = DT_REAL;
2728 break;
2729 case I_ACOS: /* acos */
2730 paramct = 1;
2731 dtyper = DT_REAL;
2732 argdtype = DT_REAL;
2733 break;
2734 case I_AIMAG: /* aimag */
2735 paramct = 1;
2736 dtyper = DT_CMPLX;
2737 argdtype = DT_CMPLX;
2738 break;
2739 case I_AINT: /* aint */
2740 paramct = 2;
2741 dtyper = DT_REAL;
2742 argdtype = DT_REAL;
2743 break;
2744 case I_ALOG: /* alog */
2745 paramct = 1;
2746 dtyper = DT_REAL;
2747 argdtype = DT_REAL;
2748 break;
2749 case I_ALOG10: /* alog10 */
2750 paramct = 1;
2751 dtyper = DT_REAL;
2752 argdtype = DT_REAL;
2753 break;
2754 case I_AMOD: /* amod */
2755 paramct = 2;
2756 dtyper = DT_REAL;
2757 argdtype = DT_REAL;
2758 break;
2759 case I_ANINT: /* anint */
2760 paramct = 2;
2761 dtyper = DT_REAL;
2762 argdtype = DT_REAL;
2763 break;
2764 case I_ASIN: /* asin */
2765 paramct = 1;
2766 dtyper = DT_REAL;
2767 argdtype = DT_REAL;
2768 break;
2769 case I_ATAN: /* atan */
2770 paramct = 1;
2771 dtyper = DT_REAL;
2772 argdtype = DT_REAL;
2773 break;
2774 case I_ATAN2: /* atan2 */
2775 paramct = 2;
2776 dtyper = DT_REAL;
2777 argdtype = DT_REAL;
2778 break;
2779 case I_CABS: /* cabs */
2780 paramct = 1;
2781 dtyper = DT_CMPLX;
2782 argdtype = DT_CMPLX;
2783 break;
2784 case I_CCOS: /* ccos */
2785 paramct = 1;
2786 dtyper = DT_CMPLX;
2787 argdtype = DT_CMPLX;
2788 break;
2789 case I_CEXP: /* cexp */
2790 paramct = 1;
2791 dtyper = DT_CMPLX;
2792 argdtype = DT_CMPLX;
2793 break;
2794 case I_CLOG: /* clog */
2795 paramct = 1;
2796 dtyper = DT_CMPLX;
2797 argdtype = DT_CMPLX;
2798 break;
2799 case I_CONJG: /* conjg */
2800 paramct = 1;
2801 dtyper = DT_CMPLX;
2802 argdtype = DT_CMPLX;
2803 break;
2804 case I_COS: /* cos */
2805 paramct = 1;
2806 dtyper = DT_REAL;
2807 argdtype = DT_REAL;
2808 break;
2809 case I_COSH: /* cosh */
2810 paramct = 1;
2811 dtyper = DT_REAL;
2812 argdtype = DT_REAL;
2813 break;
2814 case I_CSIN: /* csin */
2815 paramct = 1;
2816 dtyper = DT_CMPLX;
2817 argdtype = DT_CMPLX;
2818 break;
2819 case I_CSQRT: /* csqrt */
2820 paramct = 1;
2821 dtyper = DT_CMPLX;
2822 argdtype = DT_CMPLX;
2823 break;
2824 case I_DABS: /* dabs */
2825 paramct = 1;
2826 dtyper = DT_DBLE;
2827 argdtype = DT_DBLE;
2828 break;
2829 case I_DACOS: /* dacos */
2830 paramct = 1;
2831 dtyper = DT_DBLE;
2832 argdtype = DT_DBLE;
2833 break;
2834 case I_DASIN: /* dasin */
2835 paramct = 1;
2836 dtyper = DT_DBLE;
2837 argdtype = DT_DBLE;
2838 break;
2839 case I_DATAN: /* datan */
2840 paramct = 1;
2841 dtyper = DT_DBLE;
2842 argdtype = DT_DBLE;
2843 break;
2844 case I_DATAN2: /* datan2 */
2845 paramct = 2;
2846 dtyper = DT_DBLE;
2847 argdtype = DT_DBLE;
2848 break;
2849 case I_DCOS: /* dcos */
2850 paramct = 1;
2851 dtyper = DT_DBLE;
2852 argdtype = DT_DBLE;
2853 break;
2854 case I_DCOSH: /* dcosh */
2855 paramct = 1;
2856 dtyper = DT_DBLE;
2857 argdtype = DT_DBLE;
2858 break;
2859 case I_DDIM: /* ddim */
2860 paramct = 2;
2861 dtyper = DT_DBLE;
2862 argdtype = DT_DBLE;
2863 break;
2864 case I_DEXP: /* dexp */
2865 paramct = 1;
2866 dtyper = DT_DBLE;
2867 argdtype = DT_DBLE;
2868 break;
2869 case I_DIM: /* dim */
2870 paramct = 2;
2871 dtyper = DT_REAL;
2872 argdtype = DT_REAL;
2873 break;
2874 case I_DINT: /* dint */
2875 paramct = 1;
2876 dtyper = DT_DBLE;
2877 argdtype = DT_DBLE;
2878 break;
2879 case I_DLOG: /* dlog */
2880 paramct = 1;
2881 dtyper = DT_DBLE;
2882 argdtype = DT_DBLE;
2883 break;
2884 case I_DLOG10: /* dlog10 */
2885 paramct = 1;
2886 dtyper = DT_DBLE;
2887 argdtype = DT_DBLE;
2888 break;
2889 case I_DMOD: /* dmod */
2890 paramct = 2;
2891 dtyper = DT_DBLE;
2892 argdtype = DT_DBLE;
2893 break;
2894 case I_DNINT: /* dnint */
2895 paramct = 1;
2896 dtyper = DT_DBLE;
2897 argdtype = DT_DBLE;
2898 break;
2899 case I_DPROD: /* dprod */
2900 paramct = 2;
2901 dtyper = DT_REAL;
2902 argdtype = DT_REAL;
2903 break;
2904 case I_DSIGN: /* dsign */
2905 paramct = 2;
2906 dtyper = DT_DBLE;
2907 argdtype = DT_DBLE;
2908 break;
2909 case I_DSIN: /* dsin */
2910 paramct = 1;
2911 dtyper = DT_DBLE;
2912 argdtype = DT_DBLE;
2913 break;
2914 case I_DSINH: /* dsinh */
2915 paramct = 1;
2916 dtyper = DT_DBLE;
2917 argdtype = DT_DBLE;
2918 break;
2919 case I_DSQRT: /* dsqrt */
2920 paramct = 1;
2921 dtyper = DT_DBLE;
2922 argdtype = DT_DBLE;
2923 break;
2924 case I_DTAN: /* dtan */
2925 paramct = 1;
2926 dtyper = DT_DBLE;
2927 argdtype = DT_DBLE;
2928 break;
2929 case I_DTANH: /* dtanh */
2930 paramct = 1;
2931 dtyper = DT_DBLE;
2932 argdtype = DT_DBLE;
2933 break;
2934 case I_EXP: /* exp */
2935 paramct = 1;
2936 dtyper = DT_REAL;
2937 argdtype = DT_REAL;
2938 break;
2939 case I_IABS: /* iabs */
2940 paramct = 1;
2941 dtyper = DT_INT;
2942 argdtype = DT_INT;
2943 break;
2944 case I_IDIM: /* idim */
2945 paramct = 2;
2946 dtyper = DT_INT;
2947 argdtype = DT_INT;
2948 break;
2949 case I_IDNINT: /* idnint */
2950 paramct = 1;
2951 dtyper = DT_DBLE;
2952 argdtype = DT_DBLE;
2953 break;
2954 case I_INDEX: /* index */
2955 paramct = 4;
2956 dtyper = DT_INT;
2957 argdtype = DT_ASSCHAR;
2958 break;
2959 case I_ISIGN: /* isign */
2960 paramct = 2;
2961 dtyper = DT_INT;
2962 argdtype = DT_INT;
2963 break;
2964 case I_LEN: /* len */
2965 paramct = 2;
2966 dtyper = DT_INT;
2967 argdtype = DT_ASSCHAR;
2968 break;
2969 case I_MOD: /* mod */
2970 paramct = 2;
2971 dtyper = DT_INT;
2972 argdtype = DT_INT;
2973 break;
2974 case I_NINT: /* nint */
2975 paramct = 2;
2976 dtyper = DT_INT;
2977 argdtype = DT_REAL;
2978 break;
2979 case I_SIGN: /* sign */
2980 paramct = 2;
2981 dtyper = DT_REAL;
2982 argdtype = DT_REAL;
2983 break;
2984 case I_SIN: /* sin */
2985 paramct = 1;
2986 dtyper = DT_REAL;
2987 argdtype = DT_REAL;
2988 break;
2989 case I_SINH: /* sinh */
2990 paramct = 1;
2991 dtyper = DT_REAL;
2992 argdtype = DT_REAL;
2993 break;
2994 case I_SQRT: /* sqrt */
2995 paramct = 1;
2996 dtyper = DT_REAL;
2997 argdtype = DT_REAL;
2998 break;
2999 case I_TAN: /* tan */
3000 paramct = 1;
3001 dtyper = DT_REAL;
3002 argdtype = DT_REAL;
3003 break;
3004 case I_TANH: /* tanh */
3005 paramct = 1;
3006 dtyper = DT_REAL;
3007 argdtype = DT_REAL;
3008 break;
3009 default:
3010 return 0;
3011 }
3012 ss = intast_sym[ii];
3013 /*
3014 * Build an 'abstract' interface from the intrinisic.
3015 * create a new symbol from the intrinsic with a fake name so that
3016 * it doesn't clash with a user or intrinsic symbol.
3017 */
3018 iface = getsymf("...%s", SYMNAME(ss));
3019 if (STYPEG(iface) != ST_UNKNOWN)
3020 return iface;
3021 CCSYMP(iface, 1);
3022 STYPEP(iface, ST_PROC);
3023 ABSTRACTP(iface, 1);
3024 DTYPEP(iface, dtyper);
3025 DCLDP(iface, 1);
3026 PUREP(iface, 1);
3027 if (INKINDG(ss) == IK_ELEMENTAL) {
3028 ELEMENTALP(iface, 1);
3029 }
3030 fval = iface_arg(iface, dtyper, iface);
3031 RESULTP(fval, 1);
3032 FVALP(iface, fval);
3033 FUNCP(iface, 1);
3034 PARAMCTP(iface, paramct);
3035 ++aux.dpdsc_avl; /* reserve one for fval */
3036 dpdsc = aux.dpdsc_avl;
3037 DPDSCP(iface, dpdsc);
3038 aux.dpdsc_avl += paramct;
3039 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
3040 aux.dpdsc_size + paramct + 100);
3041 aux.dpdsc_base[dpdsc - 1] = fval;
3042 kwd = KWDARGSTR(ss);
3043 for (ii = 0; TRUE; ii++, kwd = np) {
3044 if (*kwd == '\0')
3045 break;
3046 if (*kwd == ' ')
3047 kwd++;
3048 if (*kwd != '*')
3049 optional = 0;
3050 else {
3051 optional = 1;
3052 kwd++;
3053 }
3054 kwd_len = 0;
3055 for (np = kwd; TRUE; np++) {
3056 if (*np == ' ' || *np == '\0')
3057 break;
3058 kwd_len++;
3059 }
3060 arg = getsym(kwd, kwd_len);
3061 arg = iface_arg(arg, argdtype, iface);
3062 OPTARGP(arg, optional);
3063 INTENTP(arg, INTENT_IN);
3064 aux.dpdsc_base[dpdsc] = arg;
3065 dpdsc++;
3066 }
3067 #if DEBUG
3068 assert(ii == paramct, "iface_intrinsic: paramct does not match", iface, 3);
3069 #endif
3070 return iface;
3071 }
3072
3073 static int
iface_arg(int arg,int dt,int iface)3074 iface_arg(int arg, int dt, int iface)
3075 {
3076 if (STYPEG(arg) != ST_UNKNOWN)
3077 arg = insert_sym(arg);
3078 pop_sym(arg);
3079 STYPEP(arg, ST_VAR);
3080 DTYPEP(arg, dt);
3081 SCOPEP(arg, iface);
3082 SCP(arg, SC_DUMMY);
3083 DCLDP(arg, 1);
3084 NODESCP(arg, 1);
3085 IGNOREP(arg, 1);
3086
3087 return arg;
3088 }
3089