1 /* exprtype.c -- propagates datatype thru expressions.
2
3
4 Copyright (c) 2001 by Robert K. Moniot.
5
6 Permission is hereby granted, free of charge, to any person
7 obtaining a copy of this software and associated documentation
8 files (the "Software"), to deal in the Software without
9 restriction, including without limitation the rights to use,
10 copy, modify, merge, publish, distribute, sublicense, and/or
11 sell copies of the Software, and to permit persons to whom the
12 Software is furnished to do so, subject to the following
13 conditions:
14
15 The above copyright notice and this permission notice shall be
16 included in all copies or substantial portions of the
17 Software.
18
19 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
20 KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
21 WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
22 PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
23 COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
24 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
25 OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
26 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
27
28 Acknowledgement: the above permission notice is what is known
29 as the "MIT License."
30 */
31
32 /* I. */
33
34 /* $Id: exprtype.c,v 1.15 2005/02/07 00:38:01 moniot Exp $
35
36 Routines to propagate datatype through expressions.
37
38 binexpr_type() Yields result type of binary expression.
39 unexpr_type() Yields result type of unary expression.
40 assignment_stmt_type() Checks assignment statement type.
41 func_ref_expr(id,args,result) Forms token for a function invocation.
42 primary_id_expr() Forms token for primary which is an identifier.
43 stmt_fun_arg_cmp(t1,t2) Checks agreement between stmt func args.
44 int int_power(x,n) Computes x**n for value propagation.
45 init_typesizes(wdsize) Sets standard type sizes
46 */
47
48 #include <stdio.h>
49 #include <string.h>
50 #include <ctype.h>
51 #include "ftnchek.h"
52 #define EXPRTYPE
53 #include "symtab.h"
54 #include "symutils.h"
55 #include "tokdefs.h"
56
57
58
59 PROTO(PRIVATE char* sized_typename,( int type, long size ));
60 PROTO(PRIVATE void report_mismatch,( const Token *term1, const Token *op, const Token *term2 ));
61 PROTO(PRIVATE void report_type,( const Token *t ));
62 PROTO(PRIVATE int int_power,( int x, int n ));
63 PROTO(PRIVATE int eval_intrins,( IntrinsInfo *defn, Token *args ));
64
65
66 /* shorthand for datatypes. must match those in symtab.h */
67 /* N.B. Also, the fact that type_DEFAULT=0 is assumed in size
68 propagation code. */
69 #define E 0 /* Error for invalid type combos */
70 #define I 1
71 #define R 2
72 #define D 3
73 #define C 4
74 #define Z 5
75 #define L 6
76 #define S 7
77 #define H 8
78 #define NumT (H+1) /* number of types in tables below */
79
80 #define W 10 /* Warning for nonstandard type combos: W>NumT */
81
82 /* for + - / * ** ANSI book pp. 6-5,6-6 */
83 /* Mixed double+complex = double complex with
84 warning, double + double complex is OK */
85 PRIVATE unsigned char arith_expr_type[NumT][NumT]={
86 /*E I R D C Z L S H */
87 { E, E, E, E, E, E, E, E, E }, /* E */
88 { E, I, R, D, C, Z, E, E, E }, /* I */
89 { E, R, R, D, C, Z, E, E, E }, /* R */
90 { E, D, D, D,W+Z, Z, E, E, E }, /* D */
91 { E, C, C,W+Z, C, Z, E, E, E }, /* C */
92 { E, Z, Z, Z, Z, Z, E, E, E }, /* Z */
93 { E, E, E, E, E, E, E, E, E }, /* L */
94 { E, E, E, E, E, E, E, E, E }, /* S */
95 { E, E, E, E, E, E, E, E, E } /* H */
96 };
97
98 /* for relops. Corresponds to arith type table
99 except that nonstandard comparisons of like
100 types have warning, not error. */
101 PRIVATE unsigned char rel_expr_type[NumT][NumT]={
102 /*E I R D C Z L S H */
103 { E, E, E, E, E, E, E, E, E }, /* E */
104 { E, L, L, L, L, L, E, E,W+L }, /* I */
105 { E, L, L, L, L, L, E, E, E }, /* R */
106 { E, L, L, L,W+L, L, E, E, E }, /* D */
107 { E, L, L,W+L, L, L, E, E, E }, /* C */
108 { E, L, L, L, L, L, E, E, E }, /* Z */
109 { E, E, E, E, E, E,W+L, E,W+L }, /* L */
110 { E, E, E, E, E, E, E, L, E }, /* S */
111 { E,W+L, E, E, E, E,W+L, E,W+L } /* H */
112 };
113
114 /* Result of assignment: lvalue = expr. Here rows
115 correspond to type of lvalue, columns to type
116 of expr */
117 PRIVATE unsigned char assignment_type[NumT][NumT]={
118 /*E I R D C Z L S H */
119 { E, E, E, E, E, E, E, E, E }, /* E */
120 { E, I, I, I, I, I, E, E,W+I }, /* I */
121 { E, R, R, R, R, R, E, E,W+R }, /* R */
122 { E, D, D, D, D, D, E, E,W+D }, /* D */
123 { E, C, C, C, C, C, E, E,W+C }, /* C */
124 { E, Z, Z, Z, Z, Z, E, E,W+Z }, /* Z */
125 { E, E, E, E, E, E, L, E,W+L }, /* L */
126 { E, E, E, E, E, E, E, S, E }, /* S */
127 { E, E, E, E, E, E, E, E, E } /* H not possible for lvalue */
128 };
129
130
131 #define INTRINS_ARGS (opclass == ',') /* Flag to modify behavior of binexpr_type */
132
133 /* Routine used in printing diagnostics: returns string "type" for
134 unsized objects, "type*size" for explicitly sized things. Due
135 to use of local static variable, cannot be invoked twice in the
136 same expression. */
137 PRIVATE char*
138 #if HAVE_STDC
sized_typename(int type,long int size)139 sized_typename(int type, long int size)
140 #else /* K&R style */
141 sized_typename(type,size)
142 int type; long size;
143 #endif /* HAVE_STDC */
144 {
145 static char strbuf[]="type*000000"; /* template */
146 static char *char_unk="char*(?)";
147 static char *char_adj="char*(*)";
148 if(size == size_DEFAULT) {
149 return type_name[type]; /* no explicit size */
150 }
151 else {
152 if(type != S || size > 0) {
153 (void)sprintf(strbuf,"%4s*%ld", /* type*size */
154 type_name[type],
155 size%1000000);
156 }
157 else { /* handle special character size codes */
158 if(size == size_ADJUSTABLE)
159 return char_adj;
160 else /*size_UNKNOWN*/
161 return char_unk;
162 }
163 }
164 return strbuf;
165 }
166
167
168 void
init_typesizes(VOID)169 init_typesizes(VOID)
170 /* Only executes once. Thus cannot change wordsize
171 after processing starts. */
172 {
173 static int trapdoor=FALSE, ptr_trapdoor=FALSE;
174 if(trapdoor) {
175 if(given_wordsize != local_wordsize) {
176 (void)fprintf(stderr,
177 "\nSorry-Cannot change wordsize after processing starts");
178 }
179 given_wordsize = local_wordsize;
180 }
181 else {
182 trapdoor = TRUE;
183 local_wordsize = given_wordsize;
184 if(given_wordsize != 0) {
185 if(given_wordsize != BpW) {
186 type_size[I] = type_size[R] = type_size[L] = (BYTE)given_wordsize;
187 type_size[D] = type_size[C] = (BYTE)(2*given_wordsize);
188 type_size[Z] = (BYTE)(4*given_wordsize);
189 }
190 }
191 }
192
193 /* Cray pointer size is set separately */
194 if(ptr_trapdoor) {
195 if(given_ptrsize != local_ptrsize) {
196 (void)fprintf(stderr,
197 "\nSorry-Cannot change pointer size after processing starts");
198 }
199 given_ptrsize = local_ptrsize;
200 }
201 else {
202 ptr_trapdoor = TRUE;
203 local_ptrsize = given_ptrsize;
204 }
205 }
206
207
208 /* this routine propagates type in binary expressions */
209
210 void
211 #if HAVE_STDC
binexpr_type(Token * term1,Token * op,Token * term2,Token * result)212 binexpr_type(Token *term1, Token *op, Token *term2, Token *result)
213 #else /* K&R style */
214 binexpr_type(term1,op,term2,result)
215 Token *term1, *op, *term2, *result;
216 #endif /* HAVE_STDC */
217 {
218 int opclass = op->tclass,
219 type1 = datatype_of(term1->TOK_type),
220 type2 = datatype_of(term2->TOK_type),
221 result_type;
222 long
223 size1 = term1->size,
224 size2 = term2->size,
225 result_size;
226 int I_logop_I=FALSE; /* for f90_mixed_type warning */
227
228 if( ! is_computational_type(type1) ) {
229 if( misc_warn ) {
230 syntax_error(term1->line_num,term1->col_num,
231 "numeric or character quantity expected:");
232 report_type(term1);
233 }
234 result_type = E;
235 }
236 else if( ! is_computational_type(type2) ) {
237 if( misc_warn ) {
238 syntax_error(term2->line_num,term2->col_num,
239 "numeric or character quantity expected:");
240 report_type(term2);
241 }
242 result_type = E;
243 }
244 else {
245 switch(opclass) {
246 /* arithmetic operators: use lookup table */
247 case '+':
248 case '-':
249 case '*':
250 case '/':
251 case tok_power:
252 result_type = (unsigned)arith_expr_type[type1][type2];
253 break;
254
255 /* relational operators: use lookup table */
256 case tok_relop:
257 result_type = (unsigned)rel_expr_type[type1][type2];
258 break;
259
260 /* logical operators: operands should be
261 logical, but allow integers with a
262 warning. */
263 case tok_AND:
264 case tok_OR:
265 case tok_EQV:
266 case tok_NEQV:
267 if(type1 == L && type2 == L)
268 result_type = L;
269 else if(type1 == I && type2 == I) {
270 result_type = W+I;
271 I_logop_I = TRUE;
272 }
273 else
274 result_type = E;
275 break;
276
277 /* // operator: operands must be strings */
278 case tok_concat:
279 if(type1 == S && type2 == S)
280 result_type = S;
281 else
282 result_type = E;
283 break;
284
285 /* Intrinsic function argument list: no promotion
286 across type categories. Accept matching type
287 categories: size match will be checked later. */
288 case ',': /* INTRINS_ARGS */
289 if( type_category[type1] != type_category[type2] )
290 result_type = E;
291 else if(type1 == S)
292 result_type = S;
293 else
294 result_type = (unsigned)arith_expr_type[type1][type2];
295 break;
296
297 default:
298 oops_message(OOPS_NONFATAL,
299 op->line_num,op->col_num,
300 "operator unknown: type not propagated");
301 result_type = type1;
302 break;
303 }
304
305 if( (type1 != E && type2 != E) ) {
306 if( result_type == E) {
307 if(INTRINS_ARGS) {
308 syntax_error(op->line_num,op->col_num,
309 "type mismatch between intrinsic function arguments:");
310 report_mismatch(term1,op,term2);
311 }
312 else if( misc_warn ) {
313 syntax_error(op->line_num,op->col_num,
314 "operands cannot be combined in expression:");
315 report_mismatch(term1,op,term2);
316 }
317 }
318 else if(result_type >= W) { /* W result */
319 /* F90 warning suppressed for numeric exprs */
320 if(f77_mixed_expr ||
321 (f90_mixed_expr && ((type1>=L || type2>=L) || I_logop_I)) ) {
322 nonstandard(op->line_num,op->col_num,f90_mixed_expr,0);
323 msg_tail(": incompatible type combination in expression:");
324 report_mismatch(term1,op,term2);
325 }
326 result_type -= W;
327 }
328 /* Obscure standard rule 6.2.2. We have to look
329 for IN_ASSIGN flag in any of 3 places, since
330 it gets prematurely turned off in
331 fun_or_substr_handle production if one of
332 operands is a substring expression. */
333 else if( f77_mixed_expr &&
334 opclass == tok_concat &&
335 !is_true(IN_ASSIGN,
336 (term1->TOK_flags|op->TOK_flags|term2->TOK_flags)) &&
337 ((size1==size_ADJUSTABLE && !is_true(CONST_EXPR,term1->TOK_flags))
338 || (size2==size_ADJUSTABLE && !is_true(CONST_EXPR,term2->TOK_flags))) ) {
339 nonstandard(op->line_num,op->col_num,0,0);
340 msg_tail(": adjustable size cannot be concatenated here");
341 }
342 }
343 }
344
345 /* Figure out the size of result */
346 result_size = size_DEFAULT;
347 if(result_type != E ) { /* Error type gets DEFAULT size */
348
349 if(opclass == tok_concat) { /* string//string yields sum of lengths */
350 if(size1 == size_UNKNOWN || size2 == size_UNKNOWN)
351 result_size = size_UNKNOWN;
352 else
353 if(size1 == size_ADJUSTABLE || size2 == size_ADJUSTABLE)
354 result_size = size_ADJUSTABLE;
355 else {
356 result_size = size1 + size2;
357 if(port_long_string && result_size > 255)
358 nonportable(op->line_num,op->col_num,
359 "character expression length exceeds 255");
360 }
361
362 }
363 /* DEFAULT op DEFAULT always yields DEFAULT. So need
364 to handle only explicitly sized expressions,
365 except intrinsic arglists, where no promotion
366 of plain real to dble or plain complex to dcpx,
367 and check for promotions of real types.
368 */
369 else if(INTRINS_ARGS?
370 (type1 != type2 ||
371 (type1 == type2 && is_numeric_type(type1) &&
372 (size1 != size_DEFAULT || size2 != size_DEFAULT))) :
373 ((size1 != size_DEFAULT || size2 != size_DEFAULT) ||
374 (trunc_promotion &&
375 is_float_type(type1) && is_float_type(type2))))
376 {
377 /* Local variables for convenience.
378 N.B. Use tc1/2,ls1/2 for tests,
379 t1/2,s1/2 for assigning result.
380 */
381 int t1,t2; /* sorted types: t1 <= t2. */
382 long s1,s2; /* sizes of t1 and t2. */
383 int tc1,tc2; /* type categories: D->R and Z->C */
384 long ls1,ls2; /* local sizes = declared size else type_size */
385 int defsize1,defsize2; /* flags for default size */
386
387 /* Sort so that t1 <= t2 */
388 if(type1 <= type2) {
389 t1 = type1; s1 = size1;
390 t2 = type2; s2 = size2;
391 }
392 else {
393 t1 = type2; s1 = size2;
394 t2 = type1; s2 = size1;
395 }
396 /* Assign type categories and local sizes */
397 tc1 = type_category[t1];
398 tc2 = type_category[t2];
399
400 defsize1 = (s1 == size_DEFAULT);
401 defsize2 = (s2 == size_DEFAULT);
402 ls1 = (defsize1? type_size[t1]: s1);
403 ls2 = (defsize2? type_size[t2]: s2);
404
405 #ifdef DEBUG_EXPRTYPE
406 if(debug_latest)
407 (void)fprintf(list_fd,"\nt1=%s s1=%d ls1=%d t2=%s s2=%d ls2=%d",
408 type_name[t1],s1,ls1, type_name[t2], s2, ls2);
409 #endif
410 if(tc1 == tc2) {/* same type category */
411 /* Intrins args: size promotion illegal */
412 if(INTRINS_ARGS && ls1 != ls2) {
413 syntax_error(op->line_num,op->col_num,
414 "precision mismatch in intrinsic argument list:");
415 report_mismatch(term1,op,term2);
416 }
417 /* Give -port warning if e.g. plain I+I*2
418 (variables only) */
419 else if(port_mixed_size || local_wordsize==0) {
420 if(defsize1 != defsize2
421 && !is_true(CONST_EXPR,term1->TOK_flags)
422 && !is_true(CONST_EXPR,term2->TOK_flags))
423 {
424 nonportable(op->line_num,op->col_num,
425 INTRINS_ARGS?"intrinsic argument list":"expr");
426 msg_tail("mixes default and explicit");
427 msg_tail((is_numeric_type(t1)&&is_numeric_type(t2))?
428 "precision":"size");
429 msg_tail("operands:");
430 report_mismatch(term1,op,term2);
431 }
432 }
433
434 /* If same type category, use the larger of the two sizes if
435 both declared. If only one size declared, use the
436 larger of the declared size and the default size.
437 If result is equal in size to default, use size_DEFAULT.
438 */
439 if(ls1 > ls2) {
440 result_size = s1;
441 }
442 else if(ls2 > ls1) {
443 result_size = s2;
444 }
445 else /*ls1 == ls2*/{
446 if(!defsize1 && !defsize2)
447 result_size = s1; /* otherwise DEFAULT */
448 }
449 }/* end(tc1==tc2) */
450 else /* tc1!=tc2 */ {
451 /* Differing type categories: only two cases. */
452
453 /* Case 1: I + R|D|C|Z
454 Result: size of dominant type */
455 if(tc1 == I) {
456 result_size = s2;
457 }
458 /* Case 2: R|D + C|Z
459 Result: larger of C|Z and 2*size of R|D */
460 else {
461 if(ls2 >= 2*ls1)
462 result_size = s2;
463 else
464 result_size = 2*s1; /* 2*size_DEFAULT = 0 is still DEFAULT */
465 }
466 }/* end tc1 != tc2 */
467 /* change D or Z to default size or else
468 to explicitly sized R or C
469 */
470 if(result_type == D || result_type == Z) {
471 if(result_size != size_DEFAULT
472 && result_size != type_size[result_type])
473 result_type = (result_type==D)?R:C;
474 else
475 result_size = size_DEFAULT;
476 }
477
478 /* Give -trunc warning if a real or
479 complex type is promoted to double. */
480 if(trunc_promotion && !INTRINS_ARGS && is_float_type(t1) ) {
481 /* First clause checks R+R size agreement */
482 if( (type_category[result_type] == R && ls1 != ls2)
483 /* Second clause checks R+C and C+C */
484 || (type_category[result_type] == C &&
485 (type_category[t1] == R? ls2 != 2*ls1 : ls2 != ls1)) ){
486 warning(op->line_num,op->col_num,
487 "promotion may not give desired precision:");
488 report_mismatch(term1,op,term2);
489 }
490
491 /* For comparisons we have R==R, C==C, or R==C. */
492 if( opclass == tok_relop &&
493 (type_category[t1] == type_category[t2]? ls2 != ls1:ls2 != 2*ls1) ) {
494 warning(op->line_num,op->col_num,
495 "comparison mixes terms of different precision:");
496 report_mismatch(term1,op,term2);
497 }
498 }
499
500 }/*end if(non-DEFAULT sizes)*/
501
502 /* Result of compare gets DEFAULT size. However, we want to
503 go thru the above code for relops in case of type/size
504 mismatches that should be reported. Here for relops we
505 replace any result_size that got set above by DEFAULT size.
506 */
507 if( opclass == tok_relop) {
508 result_size = size_DEFAULT;
509 }
510 }/*end if(result_type != E)*/
511
512 #ifdef DEBUG_EXPRTYPE
513 if(debug_latest) {
514 (void)fprintf(list_fd,"\nsize of %s %c",sized_typename(type1,size1),
515 ispunct(opclass)?opclass:'~');
516 (void)fprintf(list_fd," %s = ",sized_typename(type2,size2));
517 (void)fprintf(list_fd,"%s",sized_typename(result_type,result_size));
518 }
519 #endif
520
521 result->TOK_type = type_byte(class_VAR, result_type);
522 result->TOK_flags = 0; /* clear all flags */
523 result->size = result_size;
524
525
526 /* Keep track of constant expressions */
527 if( is_true(CONST_EXPR,term1->TOK_flags)
528 && is_true(CONST_EXPR,term2->TOK_flags)
529 && !(opclass==tok_power && type2!=I) ) { /* exclude **REAL */
530 make_true(CONST_EXPR,result->TOK_flags);
531 }
532
533 /* Parameter expressions are like constant exprs
534 except we bend the rules to allow intrinsic functions
535 and **REAL */
536 if( is_true(PARAMETER_EXPR,term1->TOK_flags)
537 && is_true(PARAMETER_EXPR,term2->TOK_flags) ) {
538 make_true(PARAMETER_EXPR,result->TOK_flags);
539 }
540
541 /* Keep track of dimension bound expressions */
542 if( is_true(DIM_BOUND_EXPR,term1->TOK_flags)
543 && is_true(DIM_BOUND_EXPR,term2->TOK_flags) ) {
544 make_true(DIM_BOUND_EXPR,result->TOK_flags);
545 }
546
547
548 if( is_true(EVALUATED_EXPR,term1->TOK_flags)
549 && is_true(EVALUATED_EXPR,term2->TOK_flags) ) {
550 make_true(EVALUATED_EXPR,result->TOK_flags);
551 }
552 #ifdef DEBUG_EXPRTYPE
553 if(debug_latest)
554 (void)fprintf(list_fd,"\nconst param eval: (%d %d %d) %s (%d %d %d) = (%d %d %d)",
555 is_true(CONST_EXPR,term1->TOK_flags),
556 is_true(PARAMETER_EXPR,term1->TOK_flags),
557 is_true(EVALUATED_EXPR,term1->TOK_flags),
558
559 operator->src_text,
560
561 is_true(CONST_EXPR,term2->TOK_flags),
562 is_true(PARAMETER_EXPR,term2->TOK_flags),
563 is_true(EVALUATED_EXPR,term2->TOK_flags),
564
565 is_true(CONST_EXPR,result->TOK_flags),
566 is_true(PARAMETER_EXPR,result->TOK_flags),
567 is_true(EVALUATED_EXPR,result->TOK_flags));
568 #endif
569
570 if(! INTRINS_ARGS) { /* Remaining steps only applicable to exprs */
571
572 /* Remember if integer division was used */
573 if(result_type == type_INTEGER &&
574 (opclass == '/' ||
575 (is_true(INT_QUOTIENT_EXPR,term1->TOK_flags) ||
576 is_true(INT_QUOTIENT_EXPR,term2->TOK_flags))) ) {
577 make_true(INT_QUOTIENT_EXPR,result->TOK_flags);
578 }
579 /* Issue warning if integer expr involving division is
580 later converted to any real type, or if it is used
581 as an exponent. */
582 if( is_true(INT_QUOTIENT_EXPR,term1->TOK_flags)
583 || is_true(INT_QUOTIENT_EXPR,term2->TOK_flags) ) {
584
585 int r=result_type;
586 if(r == type_LOGICAL) /* relational tests are equivalent */
587 r = arith_expr_type[type1][type2]; /* to subtraction */
588
589 if(opclass == tok_power && is_true(INT_QUOTIENT_EXPR,term2->TOK_flags) ) {
590 if(trunc_int_div_exponent) {
591 warning(op->line_num,op->col_num,
592 "integer quotient expr");
593 msg_expr_tree(term2);
594 msg_tail("used in exponent");
595 }
596 if( ! is_true(INT_QUOTIENT_EXPR,term1->TOK_flags) )
597 make_false(INT_QUOTIENT_EXPR,result->TOK_flags);
598 }
599 else if( r == type_REAL || r == type_DP || r == type_COMPLEX) {
600 if(trunc_int_div_real) {
601 warning(op->line_num,op->col_num,
602 "integer quotient expr");
603 msg_expr_tree(is_true(INT_QUOTIENT_EXPR,term1->TOK_flags)?
604 term1:term2);
605 msg_tail(" converted to real");
606 }
607 }
608 }
609
610 /* If either term is an identifier, set use flag */
611 if(is_true(ID_EXPR,term1->TOK_flags))
612 use_variable(term1);
613 if(is_true(ID_EXPR,term2->TOK_flags))
614 use_variable(term2);
615
616 /* Propagate the value of integer constant expressions */
617 if(is_true(EVALUATED_EXPR,result->TOK_flags)) {
618 if(result_type == type_INTEGER) { /* Only ints propagated */
619 int a = int_expr_value(term1),
620 b = int_expr_value(term2),
621 c;
622 switch(opclass) {
623 case '+': c = a+b; break;
624 case '-': c = a-b; break;
625 case '*': c = a*b; break;
626 case '/': if(b == 0) {
627 if(misc_warn) {
628 syntax_error(term2->line_num,term2->col_num,
629 "division by zero attempted");
630 }
631 c = 0;
632 }
633 else {
634 c = a/b;
635 }
636 break;
637 case tok_power: c = int_power(a,b); break;
638 case tok_AND: c = a&b; break;
639 case tok_OR: c = a|b; break;
640 case tok_EQV: c = ~(a^b); break;
641 case tok_NEQV: c = a^b; break;
642 default:
643 oops_message(OOPS_NONFATAL,
644 op->line_num,op->col_num,
645 "invalid int expr operator");
646 c = 0; break;
647 }
648
649 make_true(EVALUATED_EXPR,result->TOK_flags);
650 result->value.integer = c; /* Result goes into token value */
651
652 /* Integer division (including i**neg)
653 that yields 0 is suspicious. */
654 if(trunc_int_div_zero)
655 if(c==0 && (opclass=='/' || opclass==tok_power)) {
656 warning(op->line_num,op->col_num,
657 "integer const expr yields result of 0");
658 }
659 }
660 }
661 /* Also nonconstant**neg is 0 unless
662 nonconstant=1 */
663 else if(trunc_int_neg_power)
664 if(result_type == type_INTEGER && opclass == tok_power
665 && is_true(EVALUATED_EXPR,term2->TOK_flags)
666 && int_expr_value(term2) < 0) {
667 warning(op->line_num,op->col_num,
668 "integer to negative power usually yields 0");
669 }
670 }/* end if !INTRINS_ARGS */
671 }/*binexpr_type*/
672
673
674 /* this routine propagates type in unary expressions */
675
676 void
677 #if HAVE_STDC
unexpr_type(Token * op,Token * term1,Token * result)678 unexpr_type(Token *op, Token *term1, Token *result)
679 #else /* K&R style */
680 unexpr_type(op,term1,result)
681 Token *term1, *op, *result;
682 #endif /* HAVE_STDC */
683 {
684 int opclass = op->tclass,
685 type1 = datatype_of(term1->TOK_type),
686 result_type;
687
688 if( ! is_computational_type(type1) ) {
689 if( misc_warn ) {
690 syntax_error(term1->line_num,term1->col_num,
691 "numeric quantity expected:");
692 report_type(term1);
693 }
694 result_type = E;
695 }
696 else {
697 switch(opclass) {
698 /* arith operators: use diagonal of lookup table */
699 case '+':
700 case '-':
701 result_type = arith_expr_type[type1][type1];
702 break;
703
704 /* NOT: operand should be
705 logical, but allow integers with a
706 warning. */
707 case tok_NOT:
708 if(type1 == L)
709 result_type = L;
710 else if(type1 == I)
711 result_type = W+I;
712 else
713 result_type = E;
714 break;
715
716 default:
717 oops_message(OOPS_NONFATAL,
718 op->line_num,op->col_num,
719 "unary operator type not propagated");
720 result_type = type1;
721 break;
722 }
723
724 if( type1 != E ) {
725 if( result_type == E) {
726 if( misc_warn ) {
727 syntax_error(op->line_num,op->col_num,
728 "expression incompatible with operator:");
729 msg_tail(op->src_text);
730 msg_tail("used with");
731 report_type(term1);
732 }
733 }
734 else if(result_type >= W) {
735 if(f77_mixed_expr || f90_mixed_expr) {
736 nonstandard(op->line_num,op->col_num,f90_mixed_expr,0);
737 msg_tail(": incompatible type used with operator:");
738 msg_tail(op->src_text);
739 msg_tail("used with");
740 report_type(term1);
741 }
742 result_type -= W;
743 }
744 }
745 }
746
747 result->TOK_type = type_byte(class_VAR, result_type);
748 result->TOK_flags = 0; /* clear all flags */
749 result->size = term1->size; /* result is same size as operand */
750
751 /* Keep track of constant expressions */
752 copy_flag(CONST_EXPR,result->TOK_flags,term1->TOK_flags);
753 copy_flag(PARAMETER_EXPR,result->TOK_flags,term1->TOK_flags);
754 copy_flag(DIM_BOUND_EXPR,result->TOK_flags,term1->TOK_flags);
755
756 /* Remember if integer division was used */
757 if(result_type == type_INTEGER)
758 copy_flag(INT_QUOTIENT_EXPR,result->TOK_flags,term1->TOK_flags);
759
760 if(is_true(ID_EXPR,term1->TOK_flags))
761 use_variable(term1);
762
763 /* Propagate the value of integer constant expressions */
764 if(is_true(EVALUATED_EXPR,term1->TOK_flags)) {
765 if(result_type == type_INTEGER) { /* Only ints propagated */
766 int a = int_expr_value(term1),
767 c;
768 switch(opclass) {
769 case '+': c = a; break;
770 case '-': c = -a; break;
771 case tok_NOT: c = ~a; break;
772 default: oops_message(OOPS_NONFATAL,
773 op->line_num,op->col_num,
774 "invalid int expr operator");
775 c = 0; break;
776 }
777 make_true(EVALUATED_EXPR,result->TOK_flags);
778 result->value.integer = c; /* Result goes into token value */
779 }
780 }
781 }
782
783 /* this routine checks type and size match in assignment statements
784 and in parameter assignments */
785
786 void
787 #if HAVE_STDC
assignment_stmt_type(Token * term1,Token * equals,Token * term2)788 assignment_stmt_type(Token *term1, Token *equals, Token *term2)
789 #else /* K&R style */
790 assignment_stmt_type(term1,equals,term2)
791 Token *term1, *equals, *term2;
792 #endif /* HAVE_STDC */
793 {
794 int type1 = datatype_of(term1->TOK_type),
795 type2 = datatype_of(term2->TOK_type),
796 result_type;
797
798 if( ! is_computational_type(type1) ) {
799 if( misc_warn ) {
800 syntax_error(term1->line_num,term1->col_num,
801 "numeric or character quantity expected:");
802 report_type(term1);
803 }
804 result_type = E;
805 }
806 else if( ! is_computational_type(type2) ) {
807 if( misc_warn ) {
808 syntax_error(term2->line_num,term2->col_num,
809 "numeric or character quantity expected:");
810 report_type(term2);
811 }
812 result_type = E;
813 }
814 else {
815 result_type = (unsigned)assignment_type[type1][type2];
816
817
818 if( (type1 != E && type2 != E) ) {
819 if( result_type == E) {
820 if( misc_warn ) {
821 syntax_error(equals->line_num,equals->col_num,
822 "type mismatch:");
823 report_type(term2);
824 msg_tail("assigned to");
825 report_type(term1);
826 }
827 }
828 else {
829 if(result_type >= W) { /* W result */
830 if(f77_mixed_expr || f90_mixed_expr) {
831 nonstandard(equals->line_num,equals->col_num,f90_mixed_expr,0);
832 msg_tail(": incompatible type combination:");
833 report_type(term2);
834 msg_tail("assigned to");
835 report_type(term1);
836 }
837 result_type -= W;
838 }
839
840 /* Watch for truncation to lower precision type */
841 if(trunc_precision ||
842 port_mixed_size || local_wordsize==0) {
843 long size1 = term1->size;
844 long size2 = term2->size;
845 int type_trunc=FALSE, /* flags for kind of truncation */
846 size_trunc=FALSE,
847 mixed_size=FALSE,
848 promotion=FALSE,
849 trunc_warn,mixed_warn;
850
851 if(size1 == size_DEFAULT && size2 == size_DEFAULT) {
852 type_trunc = ( is_numeric_type(type1) &&
853 is_numeric_type(type2) &&
854 (type1 < type2 ||
855 /* C = D truncates precision of D */
856 (type1 == C && type2 == D)) );
857
858 /* Watch for promotions also */
859 if(type_category[type2] == R) {
860 if(type_category[type1] == R) /* R|D = R|D */
861 promotion = (type1 > type2);
862 else if(type_category[type1] == C) /* C|Z = R|D */
863 promotion =
864 ((int)type_size[type1] > 2*(int)type_size[type2]);
865 }
866 else if(type_category[type2] == C) /* any = C|Z */
867 promotion = (type1 > type2);
868 }
869 else if(type1 == S) { /* character strings */
870 if(size1>0 && size2>0) /* ignore ADJUSTABLE and UNKNOWN */
871 size_trunc = size1 < size2;
872 } else {
873 int tc1,tc2;/* type categories: D->R, Z->C, H->I */
874 int ls1,ls2;/* local sizes */
875
876 /* Assign type categories and local sizes */
877 tc1 = type_category[type1];
878 tc2 = type_category[type2];
879 ls1 = size1; if(ls1 == size_DEFAULT) ls1 = type_size[type1];
880 ls2 = size2; if(ls2 == size_DEFAULT) ls2 = type_size[type2];
881
882 /* type truncation: any numeric type category
883 to a lower category. */
884 type_trunc = ( /***is_numeric_type(type1) &&
885 is_numeric_type(type2) &&***/
886 tc1 < tc2 );
887
888 /* size truncation: assigned to smaller
889 local size. For C = R correct test is
890 Csize < 2*Rsize */
891 if(tc1 == C && tc2 == R) {
892 size_trunc = (ls1 < ls2*2);
893 promotion = (ls1 > ls2*2);
894 }
895 else {
896 /* Suppress size truncation warning if rhs
897 is a literal constant that is sure to fit.
898 For logicals this is always the case; for
899 integers we use a suitable threshold.
900 */
901 if( (size_trunc = (ls1 < ls2)) &&
902 is_true(LIT_CONST,term2->TOK_flags) ){
903 switch(tc2) {
904 case L:
905 size_trunc = FALSE;
906 break;
907 case I:
908 if( term2->value.integer <= SMALL_INT_VALUE )
909 size_trunc = FALSE;
910 break;
911 }
912 }
913 promotion = ((tc2 == R || tc2 == C) && (ls1 > ls2));
914 }
915 /* mixed size: default size assigned to
916 declared size of like type category
917 or vice-versa. -port only, and superseded
918 by truncation warning if any. */
919 mixed_size = (tc1 == tc2) &&
920 (size1==size_DEFAULT ||
921 (size2==size_DEFAULT &&
922 !is_true(CONST_EXPR,term2->TOK_flags)));
923
924 }
925
926 /* Under -trunc, report type truncation or size
927 truncation. Say "possibly" if -nowordsize.
928 Also report promotions under -trunc.
929 If no truncation warning given and under -port,
930 report mixed assignment */
931 #ifdef DEBUG_EXPRTYPE
932 #define TorF(x) ((x)?"":"no")
933 if(debug_latest) {
934 (void)fprintf(list_fd,"\nassign %s =",sized_typename(type1,size1));
935 (void)fprintf(list_fd," %s : ",sized_typename(type2,size2));
936 (void)fprintf(list_fd,"%s type %s size %s mixed",
937 TorF(type_trunc),
938 TorF(size_trunc),
939 TorF(mixed_size));
940 }
941 #endif
942 trunc_warn = (trunc_promotion && promotion) ||
943 (trunc_type_demotion && type_trunc) ||
944 (trunc_size_demotion && size_trunc);
945 mixed_warn = ((port_mixed_size || local_wordsize==0) &&
946 mixed_size);
947 if( trunc_warn ) {
948 warning(equals->line_num,equals->col_num,"");
949 report_type(term2);
950 if(trunc_warn && !type_trunc && mixed_size
951 && local_wordsize == 0)
952 msg_tail("possibly");
953 if(promotion)
954 msg_tail("promoted to");
955 else
956 msg_tail("truncated to");
957 report_type(term1);
958 if(promotion)
959 msg_tail(": may not give desired precision");
960 }
961 else if(mixed_warn) {
962 nonportable(equals->line_num,equals->col_num,
963 "mixed default and explicit");
964 msg_tail((is_numeric_type(type1)&&is_numeric_type(type2))?
965 "precision":"size");
966 msg_tail("items:");
967 report_type(term2);
968 msg_tail("assigned to");
969 report_type(term1);
970 }
971 }
972 }/*end else (result_type != E)*/
973 }/*end if (type1,type2 != E)*/
974 }/*end else (is_computational_type(type2))*/
975
976
977 /* Issue warning if integer expr involving division is
978 later converted to any real type. */
979 if(trunc_int_div_real)
980 if( is_true(INT_QUOTIENT_EXPR,term2->TOK_flags) ) {
981
982 int r=result_type;
983
984 if( r == type_REAL || r == type_DP || r == type_COMPLEX) {
985 warning(equals->line_num,equals->col_num,
986 "integer quotient expr");
987 msg_expr_tree(term2);
988 msg_tail(" converted to real");
989 }
990 }
991
992
993 if(is_true(ID_EXPR,term2->TOK_flags))
994 use_variable(term2);
995
996 use_lvalue(term1);
997 }
998
999 void
check_initializer_type(Token * assignee_list,Token * equals,Token * expr_list)1000 check_initializer_type(Token *assignee_list, Token *equals, Token *expr_list)
1001 {
1002 Token *t;
1003 if( expr_list->next_token == (Token*)NULL ) {
1004 t = expr_list; /* simple token, not a list */
1005 }
1006 else {
1007 /* token lists are built in reverse, so
1008 restore to order in source statement */
1009 t = expr_list->next_token = reverse_tokenlist(expr_list->next_token);
1010 }
1011
1012 /* Go thru list, checking match.
1013 At this time, assignee can only be a single
1014 variable
1015 */
1016 while( t!=NULL ) {
1017 assignment_stmt_type(assignee_list,t,t);
1018 t = t->next_token;
1019 }
1020 }
1021
1022 /* Make an expression-token for a function invocation */
1023
1024 void
1025 #if HAVE_STDC
func_ref_expr(Token * id,Token * args,Token * result)1026 func_ref_expr(Token *id, Token *args, Token *result)
1027 #else /* K&R style */
1028 func_ref_expr(id,args,result)
1029 Token *id,*args,*result;
1030 #endif /* HAVE_STDC */
1031 {
1032 Lsymtab *symt;
1033 IntrinsInfo *defn;
1034 int rettype, retsize;
1035
1036 symt = hashtab[id->value.integer].loc_symtab;
1037
1038 if( symt->intrinsic ) {
1039 defn = symt->info.intrins_info;
1040 /* Intrinsic functions: type stored in info field */
1041 rettype = defn->result_type;
1042 retsize = size_DEFAULT;
1043 if( defn->intrins_flags & I_QUAD ) { /* Quad intrinsic */
1044 /* These are either R*16 or X*32 */
1045 retsize = ((rettype==type_QUAD)? size_QUAD: size_CQUAD);
1046 }
1047 /* Generic Intrinsic functions: use propagated arg type */
1048 if(rettype == type_GENERIC) {
1049 if(args->next_token == NULL) {
1050 rettype = type_UNDECL;
1051 retsize = size_DEFAULT;
1052 }
1053 else {
1054 #ifdef OLDSTUFF
1055 rettype = args->next_token->TOK_type;
1056 retsize = args->next_token->size;
1057 #else
1058 rettype = args->TOK_type;
1059 retsize = args->size;
1060 #endif
1061 }
1062 /* special case: REAL(integer|[d]real) -> real */
1063 if((defn->intrins_flags&I_SP_R) &&
1064 (rettype != type_COMPLEX) && (rettype != type_DCOMPLEX)) {
1065 rettype = type_REAL;
1066 retsize = size_DEFAULT;
1067 }
1068
1069 /* special cases: */
1070 /* ABS([d]complex) -> [d]real */
1071 /* IMAG([d]complex) -> [d]real */
1072 /* REAL([d]complex) -> [d]real */
1073 if(rettype == type_COMPLEX && (defn->intrins_flags&I_C_TO_R)) {
1074 rettype = type_REAL;
1075 retsize = retsize/2;
1076 }
1077 if(rettype == type_DCOMPLEX &&(defn->intrins_flags&I_C_TO_R)) {
1078 rettype = type_DP;
1079 retsize = size_DEFAULT;
1080 }
1081 }
1082 else { /* non-generic */
1083
1084 /* special case: CHAR(code): size=1 */
1085 if(defn->intrins_flags&I_CHAR) {
1086 retsize = 1;
1087 }
1088 }
1089 }
1090 else { /* non-intrinsic */
1091 rettype = get_type(symt);
1092 retsize = get_size(symt,rettype);
1093 }
1094 /* referencing function makes it no longer a class_SUBPROGRAM
1095 but an expression. */
1096 #ifndef TOK_type
1097 result->tclass = id->tclass;
1098 #endif
1099 result->tsubclass = 0;
1100 result->TOK_type = type_byte(class_VAR,rettype);
1101 #ifndef TOK_flags
1102 result->TOK_flags = 0; /* clear all flags */
1103 #endif
1104 result->size = retsize;
1105 result->next_token = (Token *)NULL;
1106
1107 #ifdef DEBUG_EXPRTYPE
1108 if(debug_latest) {
1109 (void)fprintf(list_fd,"\n%sFunction %s() = %s",
1110 symt->intrinsic?"Intrinsic ":"",
1111 symt->name,sized_typename(rettype,retsize));
1112 }
1113 #endif
1114
1115 /* If intrinsic and all arguments are PARAMETER_EXPRs,
1116 then result is one too. */
1117 if( symt->intrinsic ) {
1118 /* Evaluate intrinsic if result is
1119 integer, the args are const (except for
1120 LEN), and a handler is defined.
1121 */
1122 if(rettype == type_INTEGER &&
1123 (defn->intrins_flags&I_EVALUATED) )
1124 {
1125 result->value.integer = eval_intrins(defn,args);
1126 /* Evaluation routines can affect the flags */
1127 copy_flag(EVALUATED_EXPR,result->TOK_flags,args->TOK_flags);
1128 }
1129 copy_flag(PARAMETER_EXPR,result->TOK_flags,args->TOK_flags);
1130 #ifdef DEBUG_EXPRTYPE
1131 if(debug_latest) {
1132 (void)fprintf(list_fd,"\n%s(...) ",defn->name);
1133 if(is_true(EVALUATED_EXPR,args->TOK_flags))
1134 (void)fprintf(list_fd,"=%d",result->value.integer);
1135 else
1136 (void)fprintf(list_fd,"not evaluated");
1137 (void)fprintf(list_fd,": const param eval=(%d %d %d)",
1138 is_true(CONST_EXPR,result->TOK_flags),
1139 is_true(PARAMETER_EXPR,result->TOK_flags),
1140 is_true(EVALUATED_EXPR,result->TOK_flags));
1141 }
1142 #endif
1143 }
1144 }/*func_ref_expr*/
1145
1146
1147
1148 /* Make an expression-token for primary consisting of
1149 a symbolic name */
1150
1151 void
1152 #if HAVE_STDC
primary_id_expr(Token * id,Token * primary)1153 primary_id_expr(Token *id, Token *primary)
1154 #else /* K&R style */
1155 primary_id_expr(id,primary)
1156 Token *id,*primary;
1157 #endif /* HAVE_STDC */
1158 {
1159 Lsymtab *symt;
1160 int id_type;
1161 symt = hashtab[id->value.integer].loc_symtab;
1162 id_type=get_type(symt);
1163 #ifndef TOK_type
1164 primary->tclass = id->tclass;
1165 #endif
1166 primary->tsubclass = 0;
1167 primary->TOK_type = type_byte(storage_class_of(symt->type),id_type);
1168 #ifndef TOK_flags
1169 primary->TOK_flags = 0;
1170 #endif
1171 primary->size =get_size(symt,id_type);
1172 primary->left_token = (Token *) NULL;
1173
1174 make_true(ID_EXPR,primary->TOK_flags);
1175
1176 if( storage_class_of(symt->type) == class_VAR) {
1177 if(symt->parameter) {
1178 make_true(CONST_EXPR,primary->TOK_flags);
1179 make_true(PARAMETER_EXPR,primary->TOK_flags);
1180 make_true(EVALUATED_EXPR,primary->TOK_flags);
1181 }
1182 else {
1183 make_true(LVALUE_EXPR,primary->TOK_flags);
1184 }
1185 if(symt->active_do_var) {
1186 make_true(DO_VARIABLE,primary->TOK_flags);
1187 }
1188 if(symt->array_var)
1189 make_true(ARRAY_ID_EXPR,primary->TOK_flags);
1190 if(symt->set_flag || symt->common_var || symt->parameter
1191 || symt->argument)
1192 make_true(SET_FLAG,primary->TOK_flags);
1193 if(symt->assigned_flag)
1194 make_true(ASSIGNED_FLAG,primary->TOK_flags);
1195 if(symt->used_before_set)
1196 make_true(USED_BEFORE_SET,primary->TOK_flags);
1197 }
1198 else if(storage_class_of(symt->type) == class_STMT_FUNCTION) {
1199 make_true(STMT_FUNCTION_EXPR,primary->TOK_flags);
1200 }
1201
1202 #ifdef DEBUG_PARSER
1203 if(debug_parser){
1204 (void)fprintf(list_fd,"\nprimary %s: TOK_type=0x%x TOK_flags=0x%x",
1205 symt->name,primary->TOK_type,primary->TOK_flags);
1206 }
1207 #endif
1208 }/*primary_id_expr*/
1209
1210 int
1211 #if HAVE_STDC
intrins_arg_cmp(IntrinsInfo * defn,Token * t)1212 intrins_arg_cmp(IntrinsInfo *defn, Token *t)
1213 /* Definition */
1214 /* Argument */
1215 #else /* K&R style */
1216 intrins_arg_cmp(defn,t)
1217 IntrinsInfo *defn; /* Definition */
1218 Token *t; /* Argument */
1219 #endif /* HAVE_STDC */
1220 {
1221 int defn_types=defn->arg_type;
1222 int a_type = datatype_of(t->TOK_type);
1223 int type_OK;
1224 /* Check for argument type mismatch.
1225 */
1226 type_OK = ( (1<<a_type) & defn_types );
1227 if(! type_OK) {
1228 int ct;/* compatible type */
1229 /* Accept compatible types if
1230 sizes agree, e.g. DSQRT(REAL*8).
1231 The macros check the two cases and
1232 set ct to the compatible type.
1233 */
1234 #define EXCEPTION1 (a_type==type_REAL && ((1<<(ct=type_DP))&defn_types))
1235 #define EXCEPTION2 (a_type==type_COMPLEX&&((1<<(ct=type_DCOMPLEX))&defn_types))
1236
1237 if(!( (EXCEPTION1||EXCEPTION2) && t->size==type_size[ct] )){
1238 syntax_error(t->line_num,t->col_num,
1239 "illegal argument data type for intrinsic function");
1240 msg_tail(defn->name);
1241 msg_tail(":");
1242 report_type(t);
1243 }
1244 else {
1245 if(port_mixed_size || local_wordsize==0) {
1246 nonportable(t->line_num,t->col_num,
1247 "argument precision may not be correct for intrinsic function");
1248 msg_tail(defn->name);
1249 msg_tail(":");
1250 report_type(t);
1251 }
1252 type_OK = TRUE; /* Acceptable after all */
1253 }
1254 }/* end if(! type_OK) */
1255 /* Quad intrinsics need a special check
1256 to verify that real or cplx arg size is right.
1257 */
1258 else if(defn->intrins_flags & I_QARG) {
1259 if(t->size != ((a_type==type_REAL)? size_QUAD: size_CQUAD)) {
1260 syntax_error(t->line_num,t->col_num,
1261 "illegal argument data type for intrinsic function");
1262 msg_tail(defn->name);
1263 msg_tail(":");
1264 report_type(t);
1265 }
1266 }
1267
1268 return type_OK;
1269 }/*intrins_arg_cmp*/
1270
1271
1272 /* Check agreement between statement function
1273 dummy (t1) and actual (t2) args. At this
1274 time, checks only class, type and size,
1275 not arrayness. */
1276 void
1277 #if HAVE_STDC
stmt_fun_arg_cmp(const Lsymtab * symt,const Token * d_arg,const Token * a_arg)1278 stmt_fun_arg_cmp(const Lsymtab *symt, const Token *d_arg, const Token *a_arg)
1279 #else /* K&R style */
1280 stmt_fun_arg_cmp(symt,d_arg,a_arg)
1281 Lsymtab *symt;
1282 Token *d_arg,*a_arg;
1283 #endif /* HAVE_STDC */
1284 {
1285 int d_class = class_VAR,
1286 a_class = storage_class_of(a_arg->TOK_type),
1287 d_type = datatype_of(d_arg->TOK_type),
1288 a_type = datatype_of(a_arg->TOK_type),
1289 d_size = d_arg->size,
1290 a_size = a_arg->size,
1291 d_defsize = (d_size == size_DEFAULT),
1292 a_defsize = (a_size == size_DEFAULT);
1293 int d_cmptype= (d_type==type_HOLLERITH && a_type!=type_STRING)?
1294 a_type:type_category[d_type];
1295 int a_cmptype= (a_type==type_HOLLERITH && d_type!=type_STRING)?
1296 d_type:type_category[a_type];
1297
1298 if(!(port_mixed_size || local_wordsize==0)) {
1299 if(d_defsize)
1300 d_size = type_size[d_type];
1301 if(a_defsize)
1302 a_size = type_size[a_type];
1303 }
1304
1305 if(d_size < 0 || a_size < 0) { /* char size_ADJUSTABLE or UNKNOWN */
1306 d_size = a_size = size_DEFAULT; /* suppress warnings on size */
1307 d_defsize = a_defsize = TRUE; /* these are not used at present */
1308 }
1309
1310 if(d_class != a_class || d_cmptype != a_cmptype ||
1311 (d_type == type_STRING? d_size > a_size: d_size != a_size) ) {
1312 syntax_error(a_arg->line_num,a_arg->col_num,
1313 "argument mismatch in stmt function");
1314 msg_tail(symt->name); /* Give the stmt func name */
1315 msg_tail(": dummy");
1316 report_type(d_arg); /* Dummy arg type */
1317 msg_tail("vs actual");
1318 report_type(a_arg);
1319 }
1320 }/*stmt_fun_arg_cmp*/
1321
1322
1323 /* Routine to document the types of
1324 two terms and their operator */
1325 PRIVATE void
1326 #if HAVE_STDC
report_mismatch(const Token * term1,const Token * op,const Token * term2)1327 report_mismatch(const Token *term1, const Token *op, const Token *term2)
1328 #else /* K&R style */
1329 report_mismatch(term1,op,term2)
1330 Token *term1,*op,*term2;
1331 #endif /* HAVE_STDC */
1332 {
1333 report_type(term1);
1334 msg_tail(op->src_text);
1335 report_type(term2);
1336 }
1337 /* Routine to document the type
1338 of a token, with its name if it
1339 has one. */
1340 PRIVATE void
1341 #if HAVE_STDC
report_type(const Token * t)1342 report_type(const Token *t)
1343 #else /* K&R style */
1344 report_type(t)
1345 Token *t;
1346 #endif /* HAVE_STDC */
1347 {
1348 msg_tail(sized_typename((int)datatype_of(t->TOK_type),t->size));
1349 if(is_true(ID_EXPR,t->TOK_flags))
1350 msg_tail(hashtab[t->value.integer].name);
1351 else if(is_true(LIT_CONST,t->TOK_flags)) {
1352 msg_tail("const");
1353 msg_expr_tree(t);
1354 }
1355 else {
1356 msg_tail("expr");
1357 msg_expr_tree(t);
1358 }
1359 }
1360
1361
1362 int
1363 #if HAVE_STDC
substring_size(Token * id,Token * limits)1364 substring_size(Token *id, Token *limits)
1365 #else /* K&R style */
1366 substring_size(id,limits)
1367 Token *id,*limits;
1368 #endif /* HAVE_STDC */
1369 {
1370 int id_type,id_len;
1371 int startindex,endindex,substr_len;
1372 #ifdef DEBUG_EXPRTREES
1373 Lsymtab *symt = hashtab[id->value.integer].loc_symtab;
1374 #endif
1375 /*** id_type=get_type(symt); **/
1376 id_type = datatype_of(id->TOK_type);
1377
1378 substr_len=size_UNKNOWN;
1379
1380 if(id_type != type_STRING) {
1381 syntax_error(id->line_num,id->col_num,
1382 "string variable expected");
1383 }
1384 else {
1385 id_len = id->size;
1386 #ifdef DEBUG_EXPRTREES
1387 if(debug_latest) {
1388 fprintf(list_fd,"\nSubstring %s :: ",symt->name);
1389 print_expr_list(limits);
1390 }
1391 #endif
1392 /* fortran.y stores (startindex:endindex) in
1393 TOK_start, Tok_end */
1394 startindex = limits->TOK_start;
1395 endindex = limits->TOK_end;
1396 if(startindex != size_UNKNOWN && endindex != size_UNKNOWN) {
1397 /* Check limits unless endindex=0 */
1398 if( startindex > endindex && endindex > 0 ) {
1399 syntax_error(limits->line_num,limits->col_num,
1400 "invalid substring limits");
1401 }
1402 else {
1403 if(endindex == 0) /* 0 means it was (startindex: ) */
1404 endindex=id_len;
1405 substr_len = endindex-startindex+1;
1406 if(id_len > 0 && substr_len > id_len)
1407 syntax_error(limits->line_num,limits->col_num,
1408 "substring size exceeds string size");
1409 }
1410 }
1411 }
1412 return substr_len;
1413 }
1414
1415 /* Integer power: uses recursion x**n = (x**(n/2))**2 */
1416 PRIVATE int
1417 #if HAVE_STDC
int_power(int x,int n)1418 int_power(int x, int n)
1419 #else /* K&R style */
1420 int_power(x,n)
1421 int x,n;
1422 #endif /* HAVE_STDC */
1423 {
1424 int temp;
1425 /* Order of tests puts commonest cases first */
1426 if(n > 1) {
1427 temp = int_power(x,n>>1);
1428 temp *= temp;
1429 if(n&1) return temp*x; /* Odd n */
1430 else return temp; /* Even n */
1431 }
1432 else if(n == 1) return x;
1433 else if(n < 0) return 1/int_power(x,-n); /* Usually 0 */
1434 else return 1;
1435 }
1436
1437 /* Intrinsic function handlers */
1438
1439 PROTO(PRIVATE int ii_abs,( Token *args ));
1440 PROTO(PRIVATE int ii_dim,( Token *args ));
1441 PROTO(PRIVATE int ii_ichar,( Token *args ));
1442 PROTO(PRIVATE int ii_index,( Token *args ));
1443 PROTO(PRIVATE int ii_len,( Token *args ));
1444 PROTO(PRIVATE int ii_max,( Token *args ));
1445 PROTO(PRIVATE int ii_min,( Token *args ));
1446 PROTO(PRIVATE int ii_mod,( Token *args ));
1447 PROTO(PRIVATE int ii_sign,( Token *args ));
1448
1449
1450 /* Array of pointers to functions for evaluating integer-valued intrinsic
1451 functions. The order matches definitions of I_ABS thru I_INDEX in
1452 symtab.h */
1453
1454 PROTO(PRIVATE int (*ii_fun[]),( Token *args ))
1455 ={
1456 NULL,
1457 ii_abs,
1458 ii_sign,
1459 ii_dim,
1460 ii_mod,
1461 ii_max,
1462 ii_min,
1463 ii_ichar,
1464 ii_len,
1465 ii_index,
1466 };
1467
1468 PRIVATE int
1469 #if HAVE_STDC
eval_intrins(IntrinsInfo * defn,Token * args)1470 eval_intrins(IntrinsInfo *defn, Token *args)
1471 #else /* K&R style */
1472 eval_intrins(defn,args)
1473 IntrinsInfo *defn;
1474 Token *args;
1475 #endif /* HAVE_STDC */
1476 {
1477 intrins_flags_t fun_num;
1478 fun_num = (defn->intrins_flags & I_EVALUATED);
1479
1480 /* Args must be evaluated, except for LEN */
1481 if( (is_true(EVALUATED_EXPR,args->TOK_flags) || fun_num==I_LEN) &&
1482 fun_num > 0 && fun_num < (sizeof(ii_fun)/sizeof(ii_fun[0])) ) {
1483 return (*ii_fun[fun_num])(args);
1484 }
1485 else {
1486 #ifdef DEBUG_EXPRTYPE
1487 if(debug_latest)
1488 (void)fprintf(list_fd,"\nIntrinsic %s not handled",defn->name);
1489 make_false(EVALUATED_EXPR,args->TOK_flags);
1490 #endif
1491 return 0;
1492 }
1493 }
1494
1495
1496 PRIVATE int
1497 #if HAVE_STDC
ii_abs(Token * args)1498 ii_abs(Token *args)
1499 #else /* K&R style */
1500 ii_abs(args)
1501 Token *args;
1502 #endif /* HAVE_STDC */
1503 {
1504 Token *t;
1505 int val, result=0;
1506 t = args->next_token;
1507 if(t->TOK_type != type_INTEGER) {/* wrong arg type: message given elsewhere */
1508 make_false(EVALUATED_EXPR,args->TOK_flags);
1509 }
1510 else {
1511 val = int_expr_value(t);
1512 result = (val >= 0? val: -val);
1513 }
1514 return result;
1515 }
1516
1517 PRIVATE int
1518 #if HAVE_STDC
ii_sign(Token * args)1519 ii_sign(Token *args) /* SIGN(value,sign) */
1520 #else /* K&R style */
1521 ii_sign(args) /* SIGN(value,sign) */
1522 Token *args;
1523 #endif /* HAVE_STDC */
1524 {
1525 Token *t1,*t2;
1526 int val1,val2, result=0;
1527 t1 = args->next_token;
1528 t2 = t1->next_token;
1529 if(t2 == NULL || t1->TOK_type != type_INTEGER
1530 || t2->TOK_type != type_INTEGER) {/* wrong arg type: message given elswr */
1531 make_false(EVALUATED_EXPR,args->TOK_flags);
1532 }
1533 else {
1534 val1 = int_expr_value(t1);
1535 if(val1 < 0) val1 = -val1;
1536 val2 = int_expr_value(t2);
1537 result = (val2 >= 0? val1: -val1);
1538 }
1539 return result;
1540 }
1541
1542 PRIVATE int
1543 #if HAVE_STDC
ii_dim(Token * args)1544 ii_dim(Token *args) /* DIM(int,int) */
1545 #else /* K&R style */
1546 ii_dim(args) /* DIM(int,int) */
1547 Token *args;
1548 #endif /* HAVE_STDC */
1549 {
1550 Token *t1,*t2;
1551 int val, result=0;
1552 t1 = args->next_token;
1553 t2 = t1->next_token;
1554 if(t2 == NULL || t1->TOK_type != type_INTEGER
1555 || t2->TOK_type != type_INTEGER) {/* wrong arg type: message given elswr */
1556 make_false(EVALUATED_EXPR,args->TOK_flags);
1557 }
1558 else {
1559 val = int_expr_value(t1)-int_expr_value(t2);
1560 result = (val >= 0? val: 0);
1561 }
1562 return result;
1563 }
1564
1565 PRIVATE int
1566 #if HAVE_STDC
ii_mod(Token * args)1567 ii_mod(Token *args) /* MOD(int,int) */
1568 #else /* K&R style */
1569 ii_mod(args) /* MOD(int,int) */
1570 Token *args;
1571 #endif /* HAVE_STDC */
1572 {
1573 Token *t1,*t2;
1574 int val1,val2,quotient, result=0;
1575 t1 = args->next_token;
1576 t2 = t1->next_token;
1577 if(t2 == NULL || t1->TOK_type != type_INTEGER
1578 || t2->TOK_type != type_INTEGER) {/* wrong arg type: message given elswr */
1579 make_false(EVALUATED_EXPR,args->TOK_flags);
1580 }
1581 else {
1582 val1 = int_expr_value(t1);
1583 val2 = int_expr_value(t2);
1584 if((val1 < 0) == (val2 < 0)) {
1585 quotient = val1/val2; /* Both positive or both negative*/
1586 }
1587 else {
1588 quotient = -(-val1/val2); /* Unlike signs */
1589 }
1590 result = val1 - quotient*val2;
1591 }
1592 return result;
1593 }
1594
1595
1596 PRIVATE int
1597 #if HAVE_STDC
ii_max(Token * args)1598 ii_max(Token *args) /* MAX(int,int,...) */
1599 #else /* K&R style */
1600 ii_max(args) /* MAX(int,int,...) */
1601 Token *args;
1602 #endif /* HAVE_STDC */
1603 {
1604 Token *t=args;
1605 int val,result=0,n=0;
1606 #ifdef DEBUG_EXPRTYPE
1607 if(debug_latest)
1608 (void)fprintf(list_fd,"\nEvaluating MAX(");
1609 #endif
1610 while( (t=t->next_token) != NULL) {
1611
1612 if(t->TOK_type != type_INTEGER) {/* wrong arg type: message given elswr */
1613 make_false(EVALUATED_EXPR,args->TOK_flags);
1614 break;
1615 }
1616 else {
1617 val = int_expr_value(t);
1618 if(n++ == 0 || val > result)
1619 result = val;
1620 #ifdef DEBUG_EXPRTYPE
1621 if(debug_latest)
1622 (void)fprintf(list_fd,"%d ",val);
1623 #endif
1624 }
1625 }
1626 #ifdef DEBUG_EXPRTYPE
1627 if(debug_latest)
1628 (void)fprintf(list_fd,") = %d",result);
1629 #endif
1630 return result;
1631 }
1632
1633 PRIVATE int
1634 #if HAVE_STDC
ii_min(Token * args)1635 ii_min(Token *args) /* MIN(int,int,...) */
1636 #else /* K&R style */
1637 ii_min(args) /* MIN(int,int,...) */
1638 Token *args;
1639 #endif /* HAVE_STDC */
1640 {
1641 Token *t=args;
1642 int val,result=0,n=0;
1643 while( (t=t->next_token) != NULL) {
1644 if(t->TOK_type != type_INTEGER) {/* wrong arg type: message given elswr */
1645 make_false(EVALUATED_EXPR,args->TOK_flags);
1646 break;
1647 }
1648 else {
1649 val = int_expr_value(t);
1650 if(n++ == 0 || val < result)
1651 result = val;
1652 }
1653 }
1654 return result;
1655 }
1656
1657 PRIVATE int
1658 #if HAVE_STDC
ii_ichar(Token * args)1659 ii_ichar(Token *args) /* ICHAR(string) */
1660 #else /* K&R style */
1661 ii_ichar(args) /* ICHAR(string) */
1662 Token *args;
1663 #endif /* HAVE_STDC */
1664 {
1665 Token *t=args->next_token;
1666
1667 if(t->TOK_type != type_STRING || !is_true(LIT_CONST,t->TOK_flags)) {
1668 make_false(EVALUATED_EXPR,args->TOK_flags);
1669 }
1670 else {
1671 return t->value.string[0]; /* Processor collating sequence is used */
1672 }
1673 return 0;
1674 }
1675
1676 PRIVATE int
1677 #if HAVE_STDC
ii_len(Token * args)1678 ii_len(Token *args) /* LEN(string) */
1679 #else /* K&R style */
1680 ii_len(args) /* LEN(string) */
1681 Token *args;
1682 #endif /* HAVE_STDC */
1683 {
1684 Token *t=args->next_token;
1685 int val,result=0;
1686
1687 /* Set the PARAMETER_EXPR flag since LEN of string does
1688 not require contents to be known */
1689 if( t->TOK_type == type_STRING && (val = t->size) > 0 ) {
1690 make_true(PARAMETER_EXPR,args->TOK_flags);
1691 make_true(EVALUATED_EXPR,args->TOK_flags);
1692 result = val;
1693 }
1694 else { /* nonstring or adjustable or unknown */
1695 make_false(PARAMETER_EXPR,args->TOK_flags);
1696 make_false(EVALUATED_EXPR,args->TOK_flags);
1697 }
1698
1699 return result;
1700 }
1701
1702 PRIVATE int
1703 #if HAVE_STDC
ii_index(Token * args)1704 ii_index(Token *args) /* INDEX(str1,str2) */
1705 #else /* K&R style */
1706 ii_index(args) /* INDEX(str1,str2) */
1707 Token *args;
1708 #endif /* HAVE_STDC */
1709 {
1710 Token *t1,*t2;
1711 t1=args->next_token;
1712 t2=t1->next_token;
1713
1714 if(t2 == NULL || t1->TOK_type != type_STRING
1715 || t2->TOK_type != type_STRING
1716 || !is_true(LIT_CONST,t1->TOK_flags) || !is_true(LIT_CONST,t2->TOK_flags)) {
1717 make_false(EVALUATED_EXPR,args->TOK_flags);
1718 }
1719 else {
1720 int i;
1721 char *s1=t1->value.string;
1722 char *s2=t2->value.string;
1723 int n1=strlen(s1), n2=strlen(s2);
1724
1725 for(i=1; n1 > 0 && n1 >= n2; i++,s1++,n1--) {
1726 if(strncmp(s1,s2,n2) == 0)
1727 return i;
1728 }
1729 }
1730 return 0;
1731 }
1732
1733
1734
1735
1736 /* Undefine special macros */
1737 #undef E
1738 #undef I
1739 #undef R
1740 #undef D
1741 #undef C
1742 #undef L
1743 #undef S
1744 #undef H
1745 #undef W
1746