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