home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 4b.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  66.9 KB  |  2,256 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "4.h"
  10. #include "dbxprots.h"
  11. #include "setprots.h"
  12. #include "arithprots.h"
  13. #include "nodesprots.h"
  14. #include "errmsgprots.h"
  15. #include "evalprots.h"
  16. #include "miscprots.h"
  17. #include "smiscprots.h"
  18. #include "chapprots.h"
  19.  
  20. static int exist_compatible_type(Set, Symbol);
  21. static int compatible_op(Symbol, Node, Symbol);
  22. static Tuple valid_op_types(Symbol, Node);
  23. static int in_unary_ops(Symbol);
  24. static int op_suffix(Symbol);
  25. static Symbol op_suffix_gen(Symbol, int);
  26. static int in_numeric_types(Symbol);
  27. static int eq_universal_types(Symbol, Symbol);
  28. static int in_mult_types(Symbol, Symbol);
  29. static int in_mixed_mult_types(Symbol, Symbol);
  30. static int in_mod_types(Symbol, Symbol);
  31. static int in_adding_types(Symbol, Symbol);
  32. static int in_expon_types(Symbol, Symbol);
  33. static Symbol valid_arg_list(Symbol, Node);
  34. static Const check_constant_overflow(Const);
  35. static void literal_expression(Node);
  36. static Tuple order_arg_list(Node, Tuple);
  37. static void bind_arg(Node, Symbol, int, int);
  38. static int in_comparison_ops(Symbol);
  39. static Set find_compatible_type(Set, Set);
  40. static Tuple valid_concatenation_type(Set, Set);
  41.  
  42. /* we need the following constants in order to make some tests :
  43.  * does a constant belong to its type interval ?
  44.  */
  45.  
  46. extern int    ADA_MIN_INTEGER;
  47. extern int    ADA_MAX_INTEGER;
  48. extern int    *ADA_MAX_INTEGER_MP;
  49. extern int    *ADA_MIN_INTEGER_MP;
  50. extern long    ADA_MIN_FIXED, ADA_MAX_FIXED;
  51. extern int    *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  52.  
  53. void result_types(Node expn)                              /*;result_types*/
  54. {
  55.     /* This procedure performs the first pass of type resolution on over-
  56.      * loadable  constructs :  operators,  subprograms and literals.
  57.      */
  58.  
  59.     Fortup    ft1;
  60.     Forset    fs1, fs2;
  61.     Node    op_node;
  62.     Node prefix_node;
  63.     Node    arg_list_node;
  64.     Tuple    tmp;
  65.     Set types;
  66.     Set ops;
  67.     Symbol    opn;
  68.     Set opns;
  69.     Set valid;
  70.     Symbol    sct;
  71.     Symbol    t;
  72.     Set usable, set1;
  73.     Symbol typ;
  74.     int    exists, nat;
  75.     Symbol    package;
  76.     Node    arg;
  77.  
  78.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC :  result_types");
  79.  
  80.     /* Check for previous type error.*/
  81.  
  82.     if (noop_error ) {
  83.         N_PTYPES(expn) = set_new(0);
  84.         return;
  85.     }
  86.  
  87.     op_node = N_AST1(expn);
  88.     arg_list_node = N_AST2(expn);
  89.     ops = set_new(0);
  90.     types = set_new(0);
  91.     /* The C code differs from SETL code in that set loop only needed for simple
  92.      * names        ds 8-jan-85
  93.      * this is not longer the case!! gs apr 1 85
  94.      */
  95.     set1 = N_NAMES(op_node);
  96.     FORSET(opn =(Symbol), set1, fs1);
  97.         nat = NATURE(opn);
  98.         if (nat == na_un_op || nat == na_op) {
  99.             tmp = valid_op_types(opn, expn);
  100.             opns = (Set) tmp[1];
  101.             valid = (Set) tmp[2];
  102.             if (set_size(valid) == 0)
  103.                 opns = set_new(0);
  104.             /* A predefined operator is usable if its resulting types appears
  105.              * in a lexically open scope, or a used package.
  106.              */
  107.             usable = set_new(0);
  108.             if (N_KIND(op_node) == as_selector 
  109.               && SCOPE_OF(opn) == symbol_standard0) {
  110.                 /* use of P.'op' for a predefined operator.  Name resolution
  111.                    * has already verified that the operator is defined in scope
  112.                    * P, or that the scope declares an implicit operator. (see
  113.                    * find_selected_comp and has_implicit_operator).
  114.                  */
  115.                 prefix_node = N_AST1(op_node);
  116.                 package = N_UNQ(prefix_node);
  117.                 /* after which it can be treated as a simple name.*/
  118.                 N_KIND(op_node) = as_simple_name;
  119.                 FORSET(t=(Symbol), valid, fs2);
  120.                     usable = set_with(usable, (char *) t);
  121.                 ENDFORSET(fs2);
  122.             }
  123.             else {        /* normal infix usage of operator */
  124.                 FORSET(t=(Symbol), valid, fs2);
  125.                     sct = SCOPE_OF(t);
  126.                     if (tup_mem((char *)sct, open_scopes)
  127.                       || tup_mem((char *)sct, used_mods))
  128.                         usable = set_with(usable, (char *) t);
  129.                 ENDFORSET(fs2);
  130.             }
  131.             /* usable := {t in valid | (sct := SCOPE_OF(t)) in open_scopes
  132.              *     or sct in used_mods};
  133.              */
  134.             if (set_size(usable) == 0 && set_size(valid) == 1 
  135.               && set_size(N_NAMES(op_node)) == 1) {
  136.                 pass1_error("operator is not directly visible",
  137.                   "6.6, 8.3, 8.4", op_node);
  138.                 return;
  139.             }
  140.             else {
  141.                 ops = set_union(ops, opns );
  142.                 types = set_union(types, usable);
  143.             }
  144.         }
  145.         else if (nat == na_procedure || nat == na_procedure_spec
  146.           || nat == na_function || nat == na_function_spec
  147.           || nat == na_entry || nat == na_entry_family    ) {
  148.             typ = valid_arg_list(opn, arg_list_node);
  149.             if (typ != (Symbol)0 ) {
  150.                 types = set_with(types, (char *) typ);
  151.                 ops = set_with(ops, (char *) opn);
  152.             }
  153.         }
  154.         else if (nat == na_literal)  {
  155.             /* A literal may overload a function. The literal is valid only
  156.              * if the argument list is empty.
  157.              */
  158.             if (tup_size(N_LIST(arg_list_node)) == 0) {
  159.                 types = set_with(types, (char *) TYPE_OF(opn));
  160.                 ops = set_with(ops , (char *) opn);
  161.             }
  162.         }
  163.     ENDFORSET(fs1);
  164.  
  165.     exists = FALSE;
  166.     FORTUP(arg=(Node), N_LIST(arg_list_node), ft1);
  167.         if (set_mem((char *)symbol_universal_fixed, N_PTYPES(arg))) {
  168.             exists = TRUE;
  169.             break;
  170.         }
  171.     ENDFORTUP(ft1);
  172.     if (set_size(types) == 0 && exists ) {
  173. #ifdef ERRNUM
  174.         errmsgn(267, 268, op_node);
  175. #else
  176.         errmsg("Missing explicit conversion from universal fixed value",
  177.           "3.5.9, 4.5.5", op_node);
  178. #endif
  179.         noop_error = TRUE;
  180.     }
  181. #ifdef DEBUG
  182.     if (cdebug2 > 0) {
  183.         TO_ERRFILE("resulting types ");
  184.         /* use zpsymset     from sdbx.c to list set for debugging 
  185.          * This is temporary measure until new errmsg package installed
  186.          */
  187.         zppsetsym(types);
  188.     }
  189. #endif
  190.     N_NAMES(op_node) = ops;
  191.     N_OVERLOADED(op_node) = TRUE;
  192.     N_PTYPES(expn) = types;
  193. }
  194.  
  195. void disambiguate(Node expn, Symbol context_typ)          /*;disambiguate*/
  196. {
  197.     /* TBSL: check translation of this procedure CAREFULLY!! (ds 22 may)*/
  198.  
  199.     /* Called from    resolve2, when more than one operator  or  function is
  200.      * compatible  with the context type.  Apart from true    ambiguity, this
  201.      * can also happen if both a predefined and a user-defined operator are
  202.      * visible. This is because all predefined operators in the language have
  203.      * generic signatures (e.g. universal_integer rather than INTEGER) and as
  204.      *  result, a user-defined operator does not hide the corresponding
  205.      * operator(they do not have the same signature). The solution is to
  206.      * choose in favor of the user-defined op. if it is defined in the same
  207.      * package as the type, or in an open scope, and in favor of the
  208.      * defined one otherwise. For comparison  operators which yields the pre-
  209.      * defined  type BOOLEAN, the  above reasoning applies to the type of its
  210.      * formals and not to the boolean context.
  211.      *
  212.      * On the other hand, a predefined operator of (generic) type o_t may be
  213.      * compatible with arguments of type a_t and with the context c_t, while
  214.      * a_t is in fact not compatible with c_t.  To catch that case, we check
  215.      * valid_op_types again to verify that the result is compatible with the
  216.      * context.
  217.      *
  218.      * A final wrinkle : if the context is universal, as in a number declara-
  219.      * tion, then the predefined operator is used even if a user-defined one
  220.      * is in scope.
  221.      */
  222.  
  223.     Node    op_node;
  224.     Node    args_node;
  225.     Set valid_ops, ovalid_ops;
  226.     Symbol    nam;
  227.     Symbol    opn;
  228.     Forset    fs1;
  229.     int exists;
  230.     Symbol    sc, scc;
  231.     Tuple tup;
  232.     /*TBSL: there are a number of statements of the form
  233.      *    valid_ops = {x in valid_ops | c(x) }
  234.      * In C we translate this as
  235.      *    ovalid_ops = valid_ops;
  236.      *    valid_ops = set_new(0);
  237.      *    FORSET(x=, ovalid_ops, fs1);
  238.      *        if(c(x)) set_with(valid_ops, x)
  239.      *    ENDFORSET
  240.      * Perhaps later we can do this be removing elements from valid_ops.
  241.      * Also we will eventually want to free dead sets.
  242.      */
  243.  
  244.     op_node = N_AST1(expn);
  245.     args_node = N_AST2(expn);
  246.     valid_ops = N_NAMES(op_node);
  247.     if (cdebug2 > 2) {
  248.         TO_ERRFILE("AT PROC: disambiguate");
  249.         FORSET(nam =(Symbol) , valid_ops, fs1);
  250.             TO_ERRFILE("OVERLOADS ");
  251.         ENDFORSET(fs1); 
  252.     }
  253.     ovalid_ops = valid_ops;
  254.     valid_ops = set_new(0);
  255.     FORSET(opn=(Symbol), ovalid_ops, fs1);
  256.         if ( (NATURE(opn) != na_op)
  257.           || compatible_op(opn, args_node, context_typ))
  258.             valid_ops = set_with(valid_ops, (char *) opn);
  259.     ENDFORSET(fs1);
  260.     /* return statements have been inserted earlier to simplify the logic
  261.      * of the translation to c (ds 22 may 84) 
  262.      */
  263.     if (in_univ_types(context_typ)) {
  264.         ovalid_ops = valid_ops;
  265.         valid_ops = set_new(0);
  266.         FORSET(opn=(Symbol), ovalid_ops, fs1);
  267.         if (TYPE_OF(opn) == context_typ)
  268.             valid_ops = set_with(valid_ops, (char *) opn);
  269.         ENDFORSET(fs1);
  270.         N_NAMES(op_node) = valid_ops;
  271.         return;
  272.     }
  273.  
  274.     exists = FALSE;
  275.     FORSET(nam=(Symbol), valid_ops, fs1);
  276.         sc = SCOPE_OF(nam);
  277.         tup = SIGNATURE(nam);
  278.         if (tup!=(Tuple)0)        /* avoid dereference of null pointer */
  279.             scc = (Symbol) tup[1];
  280.         else
  281.             scc = (Symbol)0;
  282.         if  (NATURE(nam) != na_op && (sc == SCOPE_OF(context_typ)
  283.           || in_open_scopes(sc)
  284.           /* maybe a compar op. Check against scope of type of first formal.*/
  285.           || (TYPE_OF(nam) == symbol_boolean
  286.           && ( scc!=(Symbol)0 && sc == SCOPE_OF(TYPE_OF(scc)))) ) ) {
  287.             exists = TRUE;
  288.             break;
  289.         }
  290.     ENDFORSET(fs1);
  291.     if (exists) {
  292.         /* user-defined operator(s) hide derived operator.*/
  293.         ovalid_ops = valid_ops;
  294.         valid_ops = set_new(0);
  295.         FORSET(nam=(Symbol), ovalid_ops, fs1);
  296.             if (NATURE(nam) != na_op)
  297.             valid_ops = set_with(valid_ops, (char *) nam);
  298.         ENDFORSET(fs1);
  299.         N_NAMES(op_node) = valid_ops;
  300.         return;
  301.     }
  302.  
  303.     exists = FALSE;
  304.     FORSET(nam=(Symbol), valid_ops, fs1);
  305.         if (NATURE(nam) == na_op) {
  306.             exists = TRUE;
  307.             break;
  308.         }
  309.     ENDFORSET(fs1);
  310.     if (exists) {
  311.         /* It will have precedence over imported user-defined functions.*/
  312.         ovalid_ops = valid_ops;
  313.         valid_ops = set_new(0);
  314.         FORSET(nam=(Symbol), ovalid_ops, fs1);
  315.             if (NATURE(nam) == na_op)
  316.                 valid_ops = set_with(valid_ops, (char *) nam);
  317.         ENDFORSET(fs1);
  318.  
  319.         if (is_fixed_type(root_type(context_typ))) {
  320.             /* remove mixed floating operators, that yield universal*/
  321.             /* real, but are not compatible with a fixed type context*/
  322.             ovalid_ops = valid_ops;
  323.             valid_ops = set_new(0);
  324.             FORSET(nam=(Symbol), ovalid_ops, fs1);
  325.             if (TYPE_OF(nam) != symbol_universal_real)
  326.                 valid_ops = set_with(valid_ops, (char *) nam);
  327.             ENDFORSET(fs1);
  328.         }
  329.     }
  330.     N_NAMES(op_node) = valid_ops;
  331. }
  332.  
  333. static int exist_compatible_type(Set set1, Symbol context_type)
  334.                                                     /*exist_compatible_type*/
  335. {
  336.     /* retun true if it exists one type of set1 that id compatible 
  337.      * with context_type
  338.      */
  339.  
  340.     Forset fs1;
  341.     Symbol t;
  342.  
  343.     FORSET(t=(Symbol), set1, fs1);
  344.         if (compatible_types(t, context_type))
  345.             return TRUE;
  346.     ENDFORSET(fs1);
  347.     return FALSE;
  348. }
  349.  
  350. static int compatible_op(Symbol opn, Node args_node, Symbol context_typ)
  351.                                                             /*;compatible_op*/
  352. {
  353.     Tuple    arg_list;
  354.     Set types1, types2;
  355.     Symbol    t;
  356.     Forset    fs1;
  357.  
  358.     if (cdebug2 > 2) TO_ERRFILE("AT PROC compatible_op");
  359.     /* In most cases, binary operators are homogenenous: the type of their
  360.      * arguments is also  the type of the result. We get the types    of the
  361.      * arguments to perform this test:
  362.      */
  363.     arg_list = N_LIST(args_node);
  364.     if (tup_size(arg_list) == 0)
  365.         types1 = set_new(0);
  366.     else
  367.         types1 = N_PTYPES(((Node)arg_list[1]));
  368.  
  369.     if (tup_size(arg_list) == 2 ) types2 = N_PTYPES(((Node) arg_list[2]));
  370.  
  371.     /* For comparison operators, the types of the operands are known to be
  372.      * compatible and unrelated to the boolean result. 
  373.      */
  374.  
  375.     if (in_comparison_ops(opn)) return TRUE;
  376.     if (opn == symbol_mulifl || opn == symbol_mulifx) {
  377.         FORSET(t=(Symbol), types2, fs1);
  378.             /* For these ops, the second argument yields the result type.*/
  379.             if (compatible_types(t, context_typ))
  380.                 return TRUE;
  381.         ENDFORSET(fs1);
  382.         return FALSE;
  383.     }
  384.     if (opn == symbol_cat_ac )
  385.         return ((exist_compatible_type (types1, context_typ)
  386.           && exist_compatible_type (types2, component_type(context_typ))));
  387.     if (opn == symbol_cat_ca)
  388.         return ((exist_compatible_type (types2, context_typ)
  389.           && exist_compatible_type (types1, component_type(context_typ))));
  390.     if (opn == symbol_cat_cc)
  391.         return ((exist_compatible_type (types2, component_type(context_typ))
  392.           && exist_compatible_type (types1, component_type(context_typ))));
  393.     return (exist_compatible_type (types1, context_typ));
  394. }
  395.  
  396. void remove_conversions(Node expn)  /*;remove_conversions*/
  397. {
  398.     /* If after the previous procedure an expression is still ambiguous, this
  399.      * may be due to an implicit conversion of a universal quantity. This can
  400.      * only     happen in the    presence of user-defined operators.  We therefore
  401.      * attempt to  resolve the expression  again, after removing user-defined
  402.      * operators from the  tree, whose  arguments are universal quantities.
  403.      * A full disambiguation would require that we try to remove these selec-
  404.      * tively. Here we simply  remove all  of them, and give up if the result
  405.      * is still ambiguous.
  406.      */
  407.  
  408.     Node    args_node, arg, op_node, a_list_node, ts, a_expn;
  409.     Set arg_types, arg_op, tset;
  410.     Symbol    n, t;
  411.     int        exists, nk;
  412.     Fortup    ft1;
  413.     Forset    fs1;
  414.  
  415.     if (cdebug2 > 2) TO_ERRFILE("AT PROC: remove_conversions");
  416.  
  417.     nk = N_KIND(expn);
  418.     if (nk == as_call || nk == as_op || nk == as_un_op) {
  419.         args_node = N_AST2(expn);
  420.         FORTUP(arg =(Node), N_LIST(args_node), ft1);
  421.             arg_types = N_PTYPES(arg);
  422.             if (set_size( arg_types) < 2 );    /*$ unambiguous.*/
  423.             else if (N_KIND(arg) != as_aggregate ) {
  424.                 op_node = N_AST1(arg);
  425.                 a_list_node = N_AST2(arg);
  426.                 arg_op = N_NAMES(op_node);
  427.                 if (!N_OVERLOADED(op_node) );
  428.                 /* Incomplete: could be an indexing on an overloaded call!*/
  429.  
  430.                 else if (
  431.                   !in_op_designators(original_name((Symbol)set_arb(arg_op))))
  432.                     /* May be overloaded because some of its arguments are.*/
  433.                     remove_conversions(arg);
  434.                 else {
  435.                     exists = FALSE;
  436.                     FORTUP(ts=(Node), N_LIST(a_list_node), ft1);
  437.                         if (set_mem((char *) symbol_universal_integer,
  438.                           N_PTYPES(ts)) || set_mem(
  439.                           (char *)symbol_universal_real, N_PTYPES(ts))) {
  440.                             exists = TRUE;
  441.                             break;
  442.                         }
  443.                     ENDFORTUP(ft1);
  444.                     if (exists) {
  445.                         /* Some arg is universal. Resolve as predefined op */
  446.                         tset = set_new(0);
  447.                         FORSET(n=(Symbol), arg_op, fs1);
  448.                             if (NATURE(n) == na_op)
  449.                                 tset = set_with(tset, (char *) n);
  450.                         ENDFORSET(fs1);
  451.                         N_NAMES(op_node) = tset;
  452.                         result_types(arg);
  453.                     }
  454.                 }
  455.             }
  456.         ENDFORTUP(ft1);
  457.  
  458.         /* Use the pruned argument list to resolve again the expression.*/
  459.         result_types(expn);
  460.     }
  461.     else if (nk == as_all) {
  462.         a_expn = N_AST1(expn);
  463.         remove_conversions(a_expn);
  464.         tset = set_new(0);
  465.         FORSET(t=(Symbol), N_PTYPES(a_expn), fs1);
  466.             if (is_access(t))
  467.                 tset = set_with(tset, (char *) designated_type(t));
  468.         ENDFORSET(fs1);
  469.         N_PTYPES(expn) = tset;
  470.     }
  471.     else {            /* may be continued: indexing, selection. */
  472.         ;
  473.     }
  474. }
  475.  
  476. static Tuple valid_op_types(Symbol opn, Node expn)         /*;valid_op_types*/
  477. {
  478.     /* This procedure is invoked during the bottom-up pass of type
  479.      * resolution. It determines the possible result types of predefined
  480.      * operators, using the possible types of their arguments.
  481.      * All arithmetic operators have special rules that apply within literal
  482.      * expressions. They are all treated in routine valid_arith_ops.
  483.      * For other operators, the following rule applies:
  484.      * Binary operators yield the intersection of the types of their two
  485.      * arguments, provided that they are boolean (For boolean operators),
  486.      * discrete (for ordering operators) , etc.
  487.      * The concatenation operator provides an exception : it will
  488.      * concatenate and array with an object of the component type, either
  489.      * on the left or right.
  490.      * The node can be a call ( "+"(a,b) for example) or a qualified name,
  491.      * in which case the only way to distinguish between unary and binary 
  492.      * ops. is to look at the  length of the argument list.
  493.      */
  494.  
  495.     /* const unary_ops  = ['+', '-', 'abs', 'not']; */
  496.     Node    op_node, arg_list_node, arg1, arg2;
  497.     Set possible_types, opossible_types, typ1, typ2;
  498.     Symbol    t2, t, typ;
  499.     Set        types;
  500.     Tuple    arg_list, tup;
  501.     Forset    fs1, fs2;
  502.     int        exists;
  503.  
  504.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_op_types");
  505.  
  506.     op_node = N_AST1(expn);
  507.     arg_list_node = N_AST2(expn);
  508.  
  509.     if (N_KIND(expn) == as_un_op
  510.       || (tup_size(N_LIST(arg_list_node)) == 1 && in_unary_ops(opn ) ) )
  511.         arg_list = order_arg_list(arg_list_node, unary_sig);
  512.     else
  513.         arg_list = order_arg_list(arg_list_node, binary_sig);
  514.     if (arg_list == (Tuple)0) {
  515.         tup = tup_new(2);
  516.         tup[1] = (char *) set_new(0);
  517.         tup[2] = (char *) set_new(0);
  518.         return tup;
  519.     }
  520.  
  521.     if (TYPE_OF(opn) == symbol_numeric)
  522.         return valid_arith_types(opn, arg_list);
  523.  
  524.     if (tup_size(arg_list) == 1) {
  525.         arg1 = (Node) arg_list[1];
  526.         possible_types =set_new(0);
  527.         FORSET(t=(Symbol), N_PTYPES(arg1), fs1);
  528.             possible_types = set_with(possible_types, (char *) base_type(t));
  529.         ENDFORSET(fs1);
  530.     }
  531.     else {
  532.         /*Binary operator.*/
  533.         arg1 = (Node) arg_list[1];
  534.         arg2 = (Node) arg_list[2];
  535.         typ1 = N_PTYPES(arg1);
  536.         typ2 = N_PTYPES(arg2);
  537.  
  538.         if (opn == symbol_cat)
  539.             /* Both arguments must have the same one-dimensional array type,
  540.              * or one or both may have the component type of such an array type
  541.              */
  542.             return (valid_concatenation_type ( typ1, typ2));
  543.  
  544.         else{
  545.             /* All other binary operators are homogeneous : the arguments
  546.              * must have compatible types,
  547.              */
  548.             possible_types = set_new(0);
  549.             FORSET(t=(Symbol), typ1, fs1);
  550.                 exists = FALSE;
  551.                 FORSET(t2=(Symbol), typ2, fs2);
  552.                     if (compatible_types(t, t2) && t != symbol_universal_fixed){
  553.                         exists = TRUE;
  554.                         break;
  555.                     }
  556.                 ENDFORSET(fs2);
  557.                 if (exists)
  558.                     possible_types = set_with(possible_types,
  559.                       (char *) base_type(t));
  560.             ENDFORSET(fs1);
  561.         }
  562.     }
  563.     /* Remove array types with incomplete private components.*/
  564.     opossible_types = possible_types;
  565.     possible_types = set_new(0);
  566.     FORSET(t=(Symbol), opossible_types, fs1);
  567.         /* the aim of this test is to remove array types with incomplete
  568.          * private components. We think taht the use of the function
  569.          * "is_fully_private" is indadequate in this case. The new test checks
  570.          * id the array is incomplete and private
  571.          */
  572.         /* if(!is_array(t) || ! is_fully_private(t) ) {*/
  573.         if (!is_array(t)
  574.           || (! ((((int) misc_type_attributes (t)) & TA_INCOMPLETE)
  575.           && (((int) misc_type_attributes (t))
  576.           & (TA_PRIVATE | TA_LIMITED_PRIVATE)))))
  577.             possible_types = set_with(possible_types, (char *) t);
  578.     ENDFORSET(fs1);
  579.  
  580.     typ = TYPE_OF(opn);
  581.     if (typ == symbol_boolean) {
  582.         /* equality and membership operators.*/
  583.  
  584.         if (opn == symbol_eq || opn == symbol_ne) {
  585.             exists = FALSE;
  586.             FORSET(t=(Symbol), possible_types, fs1);
  587.                 if (! is_limited_type(t)) {
  588.                     types = set_new1((char *) symbol_boolean);
  589.                     exists = TRUE;
  590.                     break;
  591.                 }
  592.             ENDFORSET(fs1);
  593.             if (! exists) types = set_new(0);
  594.         }
  595.         else {
  596.             if (set_size(possible_types) > 0)
  597.                 types = set_new1((char *) symbol_boolean);
  598.             else
  599.                 types = set_new(0);
  600.         }
  601.     }
  602.     else if(typ == symbol_boolean_type) {
  603.         /* Boolean and short circuit operators.*/
  604.  
  605.         if (opn == symbol_andthen || opn == symbol_orelse) {
  606.             types = set_new(0);
  607.             FORSET(t=(Symbol), possible_types, fs1);
  608.                 if (root_type(t) == symbol_boolean)
  609.                     types = set_with(types, (char *) t);
  610.             ENDFORSET(fs1);
  611.         }
  612.         else {
  613.             types = set_new(0);
  614.             FORSET(t=(Symbol), possible_types, fs1);
  615.                 if(root_type(t) == symbol_boolean || is_array(t)
  616.                   && no_dimensions(t) == 1
  617.                   && root_type((Symbol)(component_type(t))) == symbol_boolean)
  618.                     types = set_with(types, (char *) t);
  619.             ENDFORSET(fs1);
  620.         }
  621.     }
  622.     else if (typ == symbol_order_type) { /* Comparison operators.*/
  623.         exists = FALSE;
  624.         FORSET(t=(Symbol), possible_types, fs1);
  625.             if (is_scalar_type(t) || is_array(t) && no_dimensions(t) == 1
  626.               && is_discrete_type((Symbol)component_type(t))) {
  627.                 types = set_new1((char *) symbol_boolean);
  628.                 exists = TRUE;
  629.                 break;
  630.             }
  631.         ENDFORSET(fs1);
  632.         if (!exists) types = set_new(0);
  633.     }
  634.     else if (typ == symbol_any)           /* Syntax error*/
  635.         types = set_new1((char *) symbol_any);
  636.  
  637.     else {
  638.         /* The SETL simply prints the TYPE_OF field, i.e. the unique name
  639.          * of some entry in the symbol table. In C, this is not enough!
  640.          */
  641.         char *msg = emalloct(100, "valid-op-types-msg");
  642.  
  643.         sprintf(msg, "at loc: %d, nature: %s, value: %s",
  644.           typ, nature_str(NATURE(typ)), ORIG_NAME(typ) );
  645. #ifdef ERRNUM
  646.         str_errmsgn(269, msg, 10, arg1);
  647. #else
  648.         errmsg_str("system error: strange op type %", msg, "none", arg1);
  649. #endif
  650.         efreet(msg, "valid-op-types-msg");
  651.     }
  652.     tup = tup_new(2);
  653.     tup[1] = (char *) set_new1((char *) opn);
  654.     tup[2] = (char *) types;
  655.     return tup;
  656. }
  657.  
  658. static int in_unary_ops(Symbol opn)                        /*;in_unary_ops*/
  659. {
  660.     /* const unary_ops  = ['+', '-', 'abs', 'not'];
  661.      * corresponds to opn in unary_ops
  662.      */
  663.     return (opn == symbol_add || opn == symbol_sub || opn == symbol_abs
  664.         || opn == symbol_not);
  665. }
  666. /* OP_SUFFIX codes used to represent SETL sfx character string values */
  667.  
  668. #define OP_SUFFIX_NONE    0
  669. #define OP_SUFFIX_I        1
  670. #define OP_SUFFIX_FL    2
  671. #define OP_SUFFIX_FX    3
  672. #define OP_SUFFIX_FLI    4
  673. #define OP_SUFFIX_FXI    5
  674. #define OP_SUFFIX_IFL    6
  675. #define OP_SUFFIX_IFX    7
  676. #define OP_SUFFIX_U        8
  677. #define OP_SUFFIX_UI    9
  678. #define OP_SUFFIX_UFL    10
  679. #define OP_SUFFIX_UFX    11
  680.  
  681. Tuple valid_arith_types(Symbol opn, Tuple arg_list)    /*;valid_arith_types*/
  682. {
  683.     /* Bottom-up pass over arithmetic expressions. return the pair:
  684.      * [possible operators, possible result types] .
  685.      */
  686. #ifdef TBSN
  687.  
  688.     macro i;  
  689.     "INTEGER"           endm;
  690.     macro fl;  
  691.     "FLOAT"           endm;
  692.     macro fx;  
  693.     "$FIXED"           endm;
  694.     macro ui; 
  695.     "universal_integer" endm;
  696.     macro ur; 
  697.     "universal_real"    endm;
  698.     macro ufx; 
  699.     "universal_fixed"   endm;
  700.  
  701.     const numeric_types = {
  702.         i, fl, fx, ui, ur}, 
  703.             universal_types = {
  704.             ui, ur}, 
  705.  
  706.                 adding_types = { 
  707.                 [i , i ], [fl, fl], [fx, fx], [ui, i],
  708.                     [ui, ui], [ur, ur], [ur, fx], [ur, fl]}, 
  709.  
  710.                     mult_types      = { 
  711.                     [i , i ], [fl, fl], [fx, fx], [ui, i ],
  712.                         [ui, ui], [ur, ur], [ur, fl]}, 
  713.  
  714.                         mixed_mult_types = { 
  715.                         [fx, i], [fx, ui], [ur, ui], [ur, i]}, 
  716.  
  717.                             mod_types      = { 
  718.                             [i, i], [ui, i], [i, ui], [ui, ui]}, 
  719.  
  720.                                 expon_types    = { 
  721.                                 [i , i ], [fl, i ], [ur, i ], [ui, i ],
  722.                                     [i , ui], [fl, ui], [ur, ui], [ui, ui]  }, 
  723.  
  724.  
  725.                                     op_suffix      = { 
  726.     [i, "i"], [ui, "i"], [fl, "fl"], [ur, "fl"],
  727.         [fx, "fx"] , [ufx, "fx"]
  728.                                 };
  729. #endif
  730.  
  731.     Set possible_types, types, ops, typ1, typ2;
  732.     Symbol    t;
  733.     Symbol    t1, t2, r_type, bt1, bt2;
  734.     int        sfx;
  735.     Forset    fs1, fs2;
  736.     Tuple    tup;
  737.  
  738.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_arith_types");
  739.     if  (tup_size(arg_list) == 1) {        /* Unary ops return the type*/
  740.         /* of their argument.*/
  741.         possible_types = (Set) (N_PTYPES((Node)(arg_list[1])) );
  742.  
  743.         types = set_new(0);
  744.         FORSET(t=(Symbol), possible_types, fs1);
  745.             if (in_numeric_types(root_type(t)))
  746.                 types = set_with(types, (char *) base_type(t));
  747.         ENDFORSET(fs1);
  748.  
  749.         /*Construct the unary version of the operator name.*/
  750.         if (opn == symbol_add) opn = symbol_addu;
  751.         else if (opn == symbol_sub) opn = symbol_subu;
  752.         /*ops = ??{ opn + op_suffix(root_type(t)): t in types};*/
  753.         ops = set_new(0);
  754.         FORSET(t=(Symbol), types, fs1);
  755.             ops = set_with(ops,
  756.               (char *)op_suffix_gen(opn, op_suffix(root_type(t))));
  757.         ENDFORSET(fs1);
  758.         tup = tup_new(2);
  759.         tup[1] = (char *) ops;
  760.         tup[2] = (char *) types;
  761.         return tup;
  762.     }
  763.     else {
  764.         typ1 = N_PTYPES((Node)(arg_list[1]));
  765.         typ2 = N_PTYPES((Node)(arg_list[2]));
  766.  
  767.         ops = set_new(0);
  768.         types =set_new(0);
  769.  
  770.         FORSET(t1=(Symbol), typ1, fs1);
  771.             FORSET(t2=(Symbol), typ2, fs2);
  772.                 sfx =OP_SUFFIX_NONE;/* Suffix to designate type of op.*/
  773.                 r_type = (Symbol)0;        /*will indicate type found.*/
  774.                 bt1 = root_type(t1);
  775.                 bt2 = root_type(t2);
  776.  
  777.                 if (opn == symbol_add || opn == symbol_sub) {
  778.                     if (in_adding_types(bt1, bt2)
  779.                       || in_adding_types(bt2, bt1) )
  780.                         r_type = intersect_types(t1, t2);
  781.                 }
  782.                 else if (opn == symbol_mul || opn == symbol_div) {
  783.                     if (in_mult_types(bt1, bt2) || in_mult_types(bt2, bt1) ) {
  784.                         if (is_fixed_type(bt1)||is_fixed_type(bt2))
  785.                             r_type = symbol_universal_fixed;
  786.                         else
  787.                             r_type = intersect_types(t1, t2);
  788.                     }
  789.                     else {
  790.                         /* Mixed mode operation on fixed types, or
  791.                          * literal expression.
  792.                          */
  793.                         if (in_mixed_mult_types(bt1, bt2) ) {
  794.                             if (eq_universal_types(bt1, bt2 )) {
  795.                                 /* Literal expr.*/
  796.                                 r_type = symbol_universal_real;
  797.                                 sfx = OP_SUFFIX_FLI;    /* Compile-time op.*/
  798.                             }
  799.                             else if (base_type(t2) == symbol_integer) {
  800.                                 /* Mixed mode operation with a fixed type.
  801.                                  * If the first argument is universal, the
  802.                                  * result is $FIXED, i.e any fixed type.
  803.                                  */
  804.                                 if (t1 == symbol_universal_real )
  805.                                     r_type = symbol_dfixed;
  806.                                 else r_type = t1;
  807.                                 sfx = OP_SUFFIX_FXI;    /* Run-time operation.*/
  808.                             }
  809.                             else if (bt2 == symbol_universal_integer) {
  810.                                 /* specific type on left*/
  811.                                 r_type = t1;
  812.                                 sfx = OP_SUFFIX_FXI;
  813.                             }
  814.                         }
  815.                         else if (in_mixed_mult_types(bt2, bt1)
  816.                           && opn == symbol_mul/* '*'*/) {
  817.                             /* Mixed modes are not commutative for division.*/
  818.                             if (eq_universal_types(bt1, bt2) ) {
  819.                                 r_type = symbol_universal_real;
  820.                                 sfx = OP_SUFFIX_IFL;
  821.                             }
  822.                             else if (base_type(t1) == symbol_integer) {
  823.                                 /* $FIXED, or the specific fixed type t2.*/
  824.                                 if (t2 == symbol_universal_real)
  825.                                     r_type = symbol_dfixed;
  826.                                 else r_type = t2;
  827.                                 sfx = OP_SUFFIX_IFX;
  828.                             }
  829.                             else if (bt1 == symbol_universal_integer) {
  830.                                 /* specific type on right*/
  831.                                 r_type = t2;
  832.                                 sfx = OP_SUFFIX_IFX;
  833.                             }
  834.                         }
  835.                     }
  836.                 }
  837.                 else if (opn == symbol_mod || opn == symbol_rem) {
  838.                     if (in_mod_types(bt1, bt2) )
  839.                         r_type = intersect_types(t1, t2);
  840.                 }
  841.                 else if(opn == symbol_exp) {
  842.                     /* The result of an exponentiation has the type of the
  843.                      * first argument.
  844.                      */
  845.                     if (in_expon_types(bt1, bt2)) r_type = t1;
  846.                 }
  847.  
  848.                 if (r_type != (Symbol)0) {    /* Pair of matching types found.*/
  849.                     /* The result type of an arithmetic operation does not carry
  850.                      * the constraint (if any) of the arguments. Therefore, drop
  851.                      * the constraint on the result if it appears as a subtype.
  852.                       */
  853.                     types = set_with(types, (char *)  base_type(r_type));
  854.  
  855.                     /* Append to the operator name a suffix that specifies the
  856.                      * type of its arguments and the type returned.
  857.                       */
  858.                     if (sfx == OP_SUFFIX_NONE)
  859.                         sfx = op_suffix(root_type(r_type));
  860.                     ops = set_with(ops, (char *) op_suffix_gen(opn , sfx) );
  861.                 }
  862.             ENDFORSET(fs2);
  863.         ENDFORSET(fs1);
  864.     }
  865.     tup = tup_new(2);
  866.     tup[1] = (char *)ops;
  867.     tup[2] = (char *)types;
  868.     return tup;
  869. }
  870.  
  871. static int op_suffix(Symbol ocode)                              /*;op_suffix*/
  872. {
  873.     /*    Return C analog of op_suffix in SETL version.
  874.      * op_suffix      = { [i, 'i'], [ui, 'i'], [fl, 'fl'], [ur, 'fl'],
  875.      *         [fx, 'fx'] , [ufx, 'fx']};
  876.      */
  877.     if (ocode == symbol_integer) return OP_SUFFIX_I;
  878.     if (ocode == symbol_universal_integer) return OP_SUFFIX_I;
  879.     if (ocode == symbol_float) return OP_SUFFIX_FL;
  880.     if (ocode == symbol_universal_real)    return OP_SUFFIX_FL;
  881.     if (is_fixed_type(ocode)) return OP_SUFFIX_FX;
  882.     if (ocode == symbol_universal_fixed) return OP_SUFFIX_FX;
  883.     return OP_SUFFIX_NONE;
  884. }
  885.  
  886. static Symbol op_suffix_gen(Symbol op, int sfx)                 /*;op_suffix_gen*/
  887. {
  888.     /* Generate symbol correspond to op with suffix code sfx */
  889.     if (sfx == OP_SUFFIX_NONE) return op;
  890.     if (op == symbol_abs) {
  891.         if (sfx == OP_SUFFIX_FL) return symbol_absfl;
  892.         if (sfx == OP_SUFFIX_FX) return symbol_absfx;
  893.         if (sfx == OP_SUFFIX_I) return symbol_absi;
  894.     }
  895.     else if (op == symbol_add) { /* + */
  896.         if (sfx == OP_SUFFIX_FL)        return symbol_addfl;    /* +fl */
  897.         if (sfx == OP_SUFFIX_FX)        return symbol_addfx;    /* +fx */
  898.         if (sfx == OP_SUFFIX_I)        return symbol_addi;    /* +i  */
  899.         if (sfx == OP_SUFFIX_U)        return symbol_addu;    /* +u  */
  900.         if (sfx == OP_SUFFIX_UFL)        return symbol_addufl;    /* +ufl */
  901.         if (sfx == OP_SUFFIX_UFX)        return symbol_addufx;    /* +ufx */
  902.         if (sfx == OP_SUFFIX_UI)        return symbol_addui;    /* +ui */
  903.     }
  904.     else if (op == symbol_addu) { /* +u */
  905.         if (sfx == OP_SUFFIX_FL)        return symbol_addufl;    /* +ufl */
  906.         if (sfx == OP_SUFFIX_FX)        return symbol_addufx;    /* +ufx */
  907.         if (sfx == OP_SUFFIX_I)        return symbol_addui;    /* +ui */
  908.     }
  909.     else if (op == symbol_div) {    /* / */
  910.         if (sfx == OP_SUFFIX_FL)        return symbol_divfl;    /* /fl */
  911.         if (sfx == OP_SUFFIX_FLI)        return symbol_divfli;    /* /fli */
  912.         if (sfx == OP_SUFFIX_FX)        return symbol_divfx;    /* /fx */
  913.         if (sfx == OP_SUFFIX_FXI)        return symbol_divfxi;    /* /fxi */
  914.         if (sfx == OP_SUFFIX_I)        return symbol_divi;    /* /i */
  915.     }
  916.     else if (op == symbol_exp) {
  917.         if (sfx == OP_SUFFIX_I)        return symbol_expi;    /* **i */
  918.         if (sfx == OP_SUFFIX_FL)        return symbol_expfl;    /* **fl */
  919.     }
  920.     else if (op == symbol_mod) {    /* mod */
  921.         if (sfx == OP_SUFFIX_I)        return symbol_modi;    /* modi */
  922.     }
  923.     else if (op == symbol_mul) {    /* * */
  924.         if (sfx == OP_SUFFIX_I)        return symbol_muli;    /* *i  */
  925.         if (sfx == OP_SUFFIX_FL)        return symbol_mulfl;    /* *fl */
  926.         if (sfx == OP_SUFFIX_FLI)        return symbol_mulfli;    /* *fli */
  927.         if (sfx == OP_SUFFIX_FX)        return symbol_mulfx;    /* *fx */
  928.         if (sfx == OP_SUFFIX_FXI)        return symbol_mulfxi;    /* *fxi */
  929.         if (sfx == OP_SUFFIX_IFL)        return symbol_mulifl;    /* *ifl */
  930.         if (sfx == OP_SUFFIX_IFX)        return symbol_mulifx;    /* *ifx */
  931.     }
  932.     else if (op == symbol_rem) {
  933.         if (sfx == OP_SUFFIX_I)        return symbol_remi;    /* remi */
  934.     }
  935.     else if (op == symbol_sub) {        /* - */
  936.         if (sfx == OP_SUFFIX_FL)        return symbol_subfl;    /* -fl */
  937.         if (sfx == OP_SUFFIX_FX)        return symbol_subfx;    /* -fx */
  938.         if (sfx == OP_SUFFIX_I)        return symbol_subi;    /* -i  */
  939.         if (sfx == OP_SUFFIX_U)        return symbol_subu;    /* -u  */
  940.         if (sfx == OP_SUFFIX_UFL)        return symbol_subufl;    /* -ufl */
  941.         if (sfx == OP_SUFFIX_UFX)        return symbol_subufx;    /* -ufx */
  942.         if (sfx == OP_SUFFIX_UI)        return symbol_subui;    /* -ui */
  943.     }
  944.     else if (op == symbol_subu) { /* -u */
  945.         if (sfx == OP_SUFFIX_I)        return symbol_subui;    /* -ui */
  946.         if (sfx == OP_SUFFIX_FL)        return symbol_subufl;    /* -ufl */
  947.         if (sfx == OP_SUFFIX_FX)        return symbol_subufx;    /* -ufx */
  948.     }
  949. #ifdef TBSL
  950.     -- need to handle subui and addui more completely, check
  951.         -- other unary operators
  952. #endif
  953. #ifdef DEBUG
  954.     printf("unable to match operator\n");
  955.     zpsym(op);
  956. #endif
  957.     chaos("op_suffix_gen(4)");
  958.     return (Symbol)0;
  959. }
  960.  
  961. #undef OP_SUFFIX_NONE 
  962. #undef OP_SUFFIX_I    
  963. #undef OP_SUFFIX_FL    
  964. #undef OP_SUFFIX_FX    
  965. #undef OP_SUFFIX_FLI    
  966. #undef OP_SUFFIX_FXI    
  967. #undef OP_SUFFIX_IFL    
  968. #undef OP_SUFFIX_IFX    
  969. #undef OP_SUFFIX_U    
  970. #undef OP_SUFFIX_UI    
  971. #undef    OP_SUFFIX_UFL    
  972. #undef OP_SUFFIX_UFX    
  973.  
  974. Symbol intersect_types(Symbol t1, Symbol t2) /*;intersect_types*/
  975. {
  976.     /* Find the more specific of two numeric types, if they are compatible.
  977.      * In particular, if  only one of them is  universal, return the other.
  978.      * Called to validate arithmetic arguments and bounds of subtypes.
  979.      */
  980.  
  981.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  intersect_types");
  982.  
  983. #ifdef TBSN    
  984.     Const universal_types =
  985.         { 'universal_integer', 'universal_real', '$FIXED' };
  986. #endif
  987.     if (compatible_types(t1, t2)) {
  988.         if (t1 == symbol_universal_integer || t1 == symbol_universal_real
  989.           || t1 == symbol_dfixed)
  990.             return (t2);
  991.         else if (t2 == symbol_universal_integer || t2 == symbol_universal_real
  992.           || t2 == symbol_dfixed)
  993.             return (t1);
  994.         else return(t1);
  995.     }
  996.     else return (Symbol)0;
  997. }
  998.  
  999. static int in_numeric_types(Symbol t)                  /*;in_numeric_types*/
  1000. {
  1001.     return t == symbol_integer
  1002.       || t == symbol_float
  1003.       || is_fixed_type(t)
  1004.       || t == symbol_universal_integer
  1005.       || t == symbol_universal_real;
  1006. }
  1007.  
  1008. static int eq_universal_types(Symbol t1, Symbol t2) /*;eq_universal_types*/
  1009. {
  1010.     return (t1 == symbol_universal_integer && t2 == symbol_universal_real)
  1011.       || (t2 == symbol_universal_integer && t1 == symbol_universal_real);
  1012. }
  1013.  
  1014. static int in_adding_types(Symbol t1, Symbol t2)         /*;in_adding_types*/
  1015. {
  1016.     /* [symbol_integer , symbol_integer ], 
  1017.      * [symbol_float, symbol_float], 
  1018.      * [symbol_dfixed, symbol_dfixed], 
  1019.      * [symbol_universal_real, symbol_universal_real], 
  1020.      * [symbol_universal_integer, symbol_integer],
  1021.      * [symbol_universal_integer, symbol_universal_integer], 
  1022.      * [symbol_universal_real, symbol_dfixed], 
  1023.      * [symbol_universal_real, symbol_float] ,
  1024.      */
  1025.     if (t1 == t2) {
  1026.         if (t1 == symbol_integer || t1 == symbol_float || is_fixed_type(t1)
  1027.           || t1 == symbol_universal_real) return TRUE;
  1028.     }
  1029.     if (t1 == symbol_universal_integer)
  1030.         return (t2 == symbol_integer|| t2 == symbol_universal_integer);
  1031.     if (t1 == symbol_universal_real)
  1032.         return (is_fixed_type(t2) || t2 == symbol_float);
  1033.     return FALSE;
  1034. }
  1035.  
  1036. static int in_mult_types(Symbol t1, Symbol t2)              /*;in_mult_types*/
  1037. {
  1038.     /* { [symbol_integer , symbol_integer ], 
  1039.      * [symbol_float, symbol_float], 
  1040.      * [symbol_dfixed, symbol_dfixed], 
  1041.      * [symbol_universal_integer, symbol_universal_integer], 
  1042.  
  1043.      * [symbol_universal_integer, symbol_integer ],
  1044.      * [symbol_universal_real, symbol_universal_real], 
  1045.      * [symbol_universal_real, symbol_float], 
  1046.      * }
  1047.       */
  1048.     if (t1 == t2)
  1049.         return (t1 == symbol_integer || t1 == symbol_float || is_fixed_type(t1)
  1050.           || t1 == symbol_universal_integer || t1 == symbol_universal_real);
  1051.     if (t1 == symbol_universal_integer && t2 == symbol_integer)
  1052.         return TRUE;
  1053.     if (t1 == symbol_universal_real)
  1054.         return (t2 == symbol_float);
  1055.     return FALSE;
  1056. }
  1057.  
  1058. static int in_mixed_mult_types(Symbol t1, Symbol t2)  /*;in_mixed_mult_types*/
  1059. {
  1060.     /* [symbol_dfixed, symbol_integer],
  1061.      * [symbol_dfixed, symbol_universal_integer], 
  1062.      * [symbol_universal_real, symbol_universal_integer], 
  1063.      * [symbol_universal_real, symbol_integer]
  1064.      */
  1065.     if (is_fixed_type(t1))
  1066.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1067.     if (t1 == symbol_universal_real)
  1068.         return (t2 == symbol_universal_integer || t2 == symbol_integer);
  1069.     return FALSE;
  1070. }
  1071.  
  1072. static int in_mod_types(Symbol t1, Symbol t2)              /*;in_mod_types*/
  1073. {
  1074.     /* [symbol_integer, symbol_integer], 
  1075.      * [symbol_integer, symbol_universal_integer], 
  1076.      * [symbol_universal_integer, symbol_integer], 
  1077.      * [symbol_universal_integer, symbol_universal_integer]
  1078.      */
  1079.  
  1080.     if (t1 == symbol_integer)
  1081.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1082.     if (t1 == symbol_universal_integer)
  1083.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1084.     return FALSE;
  1085. }
  1086.  
  1087. static int in_expon_types(Symbol t1, Symbol t2)             /*;in_expon_types*/
  1088. {
  1089.     /* [symbol_integer , symbol_universal_integer], 
  1090.      * [symbol_integer , symbol_integer ], 
  1091.      * [symbol_float, symbol_integer ], 
  1092.      * [symbol_float, symbol_universal_integer], 
  1093.      * [symbol_universal_integer, symbol_universal_integer] 
  1094.      * [symbol_universal_integer, symbol_integer ],
  1095.      * [symbol_universal_real, symbol_integer ],
  1096.      * [symbol_universal_real, symbol_universal_integer],
  1097.       */
  1098.     if (t1 == symbol_integer)
  1099.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1100.     if (t1 == symbol_float)
  1101.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1102.     if (t1 == symbol_universal_integer)
  1103.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1104.     if (t1 == symbol_universal_real)
  1105.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1106.     return FALSE;
  1107. }
  1108.  
  1109. static Symbol valid_arg_list(Symbol proc_name, Node arg_list_node)
  1110.                                                             /*;valid_arg_list*/
  1111. {
  1112.     Tuple    formals, arg_list;
  1113.     Node    actual;
  1114.     Set        a_types;
  1115.     Symbol    t;
  1116.     Forset    fs1;
  1117.     Fortup    ft1;
  1118.     int        exists, i;
  1119.     Symbol    f;
  1120.  
  1121.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_arg_list");
  1122.     /* This procedure is called during the bottom-up phase of overloading
  1123.      * resolution. It checks whether an argument list is compatible with
  1124.      * the formals of a subprogram, and yields the return type of the
  1125.      * subprogram if the answer is affirmative.
  1126.       * The arguments have already been processed by the first pass.
  1127.      */
  1128.  
  1129.     formals = SIGNATURE(proc_name);
  1130.     arg_list = order_arg_list(arg_list_node, formals); /*Normalize arguments*/
  1131.  
  1132.     if (cdebug2 > 0)  TO_ERRFILE("valid arg list :  formals ");
  1133.  
  1134.     if (arg_list == (Tuple)0) return (Symbol)0;       /* no match, or error*/
  1135.  
  1136.     /* Traverse signature and actuals, and verify that types match.*/
  1137.  
  1138.     FORTUPI(f=(Symbol), formals, i, ft1);
  1139.         actual = (Node) arg_list[i];
  1140.         if (actual == OPT_NODE) continue;    /* Default value exists.*/
  1141.         else a_types = N_PTYPES(actual);
  1142.  
  1143.         exists = FALSE;
  1144.         FORSET(t=(Symbol), a_types, fs1);
  1145.             if (compatible_types(TYPE_OF(f), t)) {
  1146.                 exists = TRUE;
  1147.                 break;
  1148.             }
  1149.         ENDFORSET(fs1);
  1150.         if (exists) 
  1151.             continue;
  1152.         else
  1153.             return (Symbol)0;
  1154.     ENDFORTUP(ft1);
  1155.  
  1156.     /* All arguments have a match.*/
  1157.     return (TYPE_OF(proc_name));
  1158. }
  1159.  
  1160. void complete_op_expr(Node expn, Symbol ctx_type) /*;complete_op_expr*/
  1161. {
  1162.     /* Complete the top-down pass of an expression with a predefined
  1163.      * operator.
  1164.      * For predefined operators, the signature of the operator does not
  1165.      * fix the type of the arguments, because it only specifies a class
  1166.      * of types. The precise type to be used is either imposed by context
  1167.      * (this is the argument ctx_type) or is found by requiring consistency
  1168.      * between the possible types of the arguments themselves.
  1169.      */
  1170. #ifdef TBSN
  1171.     const comparison_ops = {
  1172.     '<', '<=', '>', '>=', '=', '/='
  1173.     };
  1174. #endif
  1175.  
  1176.     Node    o, args;
  1177.     Symbol    op_name;
  1178.     Tuple    arg_list;
  1179.     Node    arg1, arg2;
  1180.     Set        t_left, t_right, ok_types, univ;
  1181.     Symbol    ctx_root, t2, t1, isym, typ;
  1182.     Forset    fs1, fs2;
  1183.  
  1184.  
  1185.     o = N_AST1(expn);
  1186.     args = N_AST2(expn);
  1187.     op_name      = N_UNQ(o);
  1188.     arg_list  = N_LIST(args);
  1189.  
  1190.     if (cdebug2 > 0) TO_ERRFILE("complete_op_expr:");
  1191.  
  1192.     if (tup_size(arg_list) == 1)
  1193.         arg_list = order_arg_list(args, unary_sig);
  1194.     else
  1195.         arg_list = order_arg_list(args, binary_sig);
  1196.  
  1197.     if (arg_list == (Tuple)0) return;
  1198.     N_LIST(args) = arg_list;      /* Normalize if named parameters. */
  1199.  
  1200.     if (tup_size( arg_list) == 2) {        /*Binary operators.*/
  1201.         arg1 = (Node) arg_list[1];
  1202.         arg2 = (Node) arg_list[2];
  1203.         t_left = N_PTYPES(arg1);
  1204.         t_right = N_PTYPES(arg2);
  1205.  
  1206.         typ = TYPE_OF(op_name);
  1207.         if (typ == symbol_universal_integer || typ == symbol_universal_real
  1208.           || typ == symbol_universal_fixed
  1209.           || (typ!=(Symbol)0 && is_fixed_type(typ)))  {
  1210.             ctx_root = root_type(ctx_type);
  1211.  
  1212.             if (ctx_type == symbol_universal_fixed) {
  1213.                 /* Must have appeared in a conversion. Each argument must be of
  1214.                  * some fixed type. 
  1215.                  */
  1216.                 t1 = ctx_type;        /* by default */
  1217.                 FORSET(t1=(Symbol), t_left, fs1);
  1218.                     if (compatible_types(t1, symbol_dfixed)) break;
  1219.                 ENDFORSET(fs1);
  1220.  
  1221.                 t2 = ctx_type;
  1222.                 FORSET(t2=(Symbol), t_right, fs2);
  1223.                     if (compatible_types(t2, symbol_dfixed)) break;
  1224.                 ENDFORSET(fs1);
  1225.                 /* TBSL: not catching ambiguity in these loops.*/
  1226.                 resolve2(arg1, t1);
  1227.                 resolve2(arg2, t2);
  1228.             }
  1229.             else if (op_name == symbol_mulfxi || op_name == symbol_mulifx
  1230.               || op_name == symbol_divfxi || op_name == symbol_expi
  1231.               || op_name == symbol_expfl) {
  1232.                 /* For mixed mode fixed operations and  exponentiation,
  1233.                  * the  type  from  context  is imposed    on  the     first
  1234.                  * argument. The second one must be INTEGER.
  1235.                  */
  1236.                 if (op_name == symbol_mulifx) { /*permute arguments.*/
  1237.                     Tuple tup= tup_new(2);
  1238.                     tup[1] = (char *) arg2;
  1239.                     tup[2] = (char *) arg1;
  1240.                     N_LIST(args) = tup;
  1241.                     arg1 = (Node) tup[1];
  1242.                     arg2 = (Node) tup[2];
  1243.                     op_name = symbol_mulfxi;
  1244.                     N_UNQ(o) = symbol_mulfxi;
  1245.                 }
  1246.  
  1247.                 if (ctx_type == symbol_dfixed) {
  1248.                     /* mixed mode expression in a context that does not
  1249.                     * have an explicit fixed type: comparison or conversion.
  1250.                     */
  1251.                     errmsg("invalid context for mixed-mode operation",
  1252.                       "4.5.5, 4.10", expn);
  1253.                 }
  1254.                 if (op_name == symbol_expfl && is_fixed_type(ctx_root)) {
  1255.                     /* universal expression in fixed context: no ** .*/
  1256. #ifdef ERRNUM
  1257.                     errmsgn(270, 271, expn);
  1258. #else
  1259.                     errmsg(
  1260.                       "Missing explicit conversion from universal_real value ",
  1261.                          "4.5.6", expn);
  1262. #endif
  1263.                 }
  1264.                 resolve2(arg1, ctx_type);
  1265.                 resolve2(arg2, symbol_integer);
  1266.                 /*
  1267.                  * The second argument is not universal, yet the whole
  1268.                  * may be constant-foldable. Fold arg2, and if static
  1269.                  * make universal again.
  1270.                  */
  1271.                 eval_static(arg2);
  1272.                 if (N_KIND(arg2) == as_ivalue )
  1273.                     N_TYPE(arg2) = symbol_universal_integer;
  1274. #ifdef TBSL
  1275.                 /* TBSL (In C, will need explicit conversion)*/
  1276. #endif
  1277.             }
  1278.             else if (op_name == symbol_mulfli
  1279.               || op_name == symbol_mulifl
  1280.               || op_name == symbol_divfli) {
  1281.                 /* These mixed mode operations appear in number declara-
  1282.                  * tions, in which case they are universal, or in a fixed
  1283.                  * type context.
  1284.                  */
  1285.                 if (op_name == symbol_mulifl) { /* permute arguments.*/
  1286.                     Tuple tup = tup_new(2);
  1287.                     tup[1] = (char *) arg2;
  1288.                     tup[2] = (char *) arg1;
  1289.                     N_LIST(args) = tup;
  1290.                     arg1 = (Node) tup[1];
  1291.                     arg2 = (Node) tup[2];
  1292.                     op_name = symbol_mulfli;
  1293.                     N_UNQ(o) = symbol_mulfli;
  1294.                 }
  1295.                 if (ctx_root == symbol_universal_real)
  1296.                     t2 = symbol_universal_integer;
  1297.                 else if (is_fixed_type(ctx_root))
  1298.                     /* universal expression in fixed context.*/
  1299.                     t2 = symbol_integer;
  1300.                 else {
  1301. #ifdef ERRNUM
  1302.                     errmsgn(272, 273, expn);
  1303. #else
  1304.                     errmsg("Invalid context for mixed mode operation",
  1305.                       "4.5.5, 4.10", expn);
  1306. #endif
  1307.                     N_KIND(expn) = as_opt;
  1308.                     return;
  1309.                 }
  1310.                 resolve2(arg1, ctx_type);
  1311.                 resolve2(arg2, t2);
  1312.             }
  1313.             else {
  1314.                 /* For other  arithmetic operators, propagate  context
  1315.                   * type to arguments. 
  1316.                   */
  1317.                 resolve2(arg1, ctx_type);
  1318.                 resolve2(arg2, ctx_type);
  1319.             }
  1320.             /* If the context is universal, evaluate the corresponding
  1321.              * literal expression.
  1322.              */
  1323.             if (in_univ_types(ctx_type ) || (is_fixed_type(ctx_root)
  1324.               && N_KIND(arg1) == as_ivalue && N_KIND(arg2) == as_ivalue))
  1325.                 literal_expression(expn);
  1326.             if ((op_name == symbol_mulfl || op_name == symbol_divfl)
  1327.               && (is_fixed_type(ctx_root)) && (!is_fixed_type(ctx_type))) {
  1328.                 /* These floating point operation may appear in some fixed
  1329.                  * type context if their constituents are literals. this is
  1330.                  * an error because the operation yields a universal_fixed
  1331.                  * quantity that must be explicitly converted If a conversion
  1332.                  * is present, the context type itself is symbol_dfixed.
  1333.                  */
  1334. #ifdef ERRNUM
  1335.                 l_errmsgn(274, 275, 276, expn);
  1336. #else
  1337.                 errmsg_l("Missing explicit conversion from ",
  1338.                   "universal_fixed value ", "4.5.5", expn);
  1339. #endif
  1340.             }
  1341.         }
  1342.         else if (typ == symbol_order_type ||  typ == symbol_discrete_type
  1343.           ||  typ == symbol_boolean) {
  1344.             /* Equality, set or comparison  operators. Verify that  there  is
  1345.              * only one possible type choice for both arguments. If both arg.
  1346.              * are universal, we must choose a universal interpretation for
  1347.              * each. Otherwise, the non-universal type is applied to both.
  1348.              */
  1349. #ifdef TBSN
  1350.             /* it happens to be wrong.*/
  1351.             /* In the case of an array compared to an aggregate, the array is
  1352.                  * already constrained as it is an object.
  1353.                  */
  1354.             need_constr_type = FALSE;
  1355.             exists = FALSE;
  1356.             if (N_KIND(arg1) == as_simple_name )  {
  1357.                 arg1_name = N_UNQ(arg1);
  1358.                 exists = TRUE;
  1359.             }
  1360. #endif
  1361.             ok_types = set_new(0);
  1362.             FORSET(t1=(Symbol), t_left, fs1);
  1363.                 FORSET(t2=(Symbol), t_right, fs2);
  1364.                     isym = intersect_types(t1, t2);
  1365.                     if (isym!=(Symbol)0)  {
  1366. #ifdef TBSN
  1367.                         if (N_KIND(arg1) == as_selector) {
  1368.                             obj = N_AST1(arg1);
  1369.                             s_node = N_AST2(arg1);
  1370.                             selector = N_VAL(s_node);
  1371.                             types1 = N_PTYPES(obj);
  1372.                             FORSET( o_t =(Symbol), types1, fs1);
  1373.                                 if (is_access(o_t) )
  1374.                                     t = (Symbol) designated_type(o_t);
  1375.                                 else 
  1376.                                     t = o_t;
  1377.                                 if (is_record(t))
  1378.                                     decls = (Declaredmap)
  1379.                                       declared_components(base_type(t));
  1380.                                 else if (is_task_type(t))
  1381.                                     decls = DECLARED(t);
  1382.                                 arg1_name = dcl_get(decls, selector);
  1383.                                 if(arg1_name != (Symbol)0
  1384.                                   && compatible_types(TYPE_OF(arg1_name),isym)){
  1385.                                     exists = TRUE;
  1386.                                     break;
  1387.                                 }
  1388.                             ENDFORSET(fs1); 
  1389.                         }
  1390.                         if (exists && NATURE(arg1_name) == na_obj 
  1391.                             && NATURE(base_type(TYPE_OF(arg1_name))) == na_array)
  1392.                             need_constr_type = TRUE;
  1393.                         if (need_constr_type)
  1394.                             ok_types = set_with(ok_types, (char *) isym);
  1395.                         else
  1396.                             ok_types =
  1397.                               set_with(ok_types, (char *) base_type(isym));
  1398. #endif
  1399.                         ok_types = set_with(ok_types, (char *) base_type(isym));
  1400.                     }
  1401.                 ENDFORSET(fs2);
  1402.             ENDFORSET(fs1);
  1403.  
  1404.             if (set_size( ok_types) ==  1)
  1405.                 t1 = t2 = (Symbol) set_arb(ok_types);
  1406.             else {
  1407.                 univ = set_new(0);
  1408.                 FORSET(t1=(Symbol), ok_types, fs1);
  1409.                     if (in_univ_types(t1))
  1410.                         univ = set_with(univ, (char *) t1);
  1411.                 ENDFORSET(fs1);
  1412.                 if (set_size(univ) == 1)
  1413.                     t1 = t2 = (Symbol) set_arb(univ);
  1414.                 else {
  1415.                     type_error(set_new1((char *)op_name),
  1416.                       (Symbol)0, set_size(ok_types), expn);
  1417.                     return;
  1418.                 }
  1419.             }
  1420.             if (is_limited_type(t1)
  1421.               && (op_name !=symbol_in && op_name!=symbol_notin)) {
  1422. #ifdef ERRNUM
  1423.                 id_errmsgn(277, op_name, 278, o);
  1424. #else
  1425.                 errmsg_id("% not available on a limited type", op_name,
  1426.                   "7.4.2", o);
  1427. #endif
  1428.                 return;
  1429.             }
  1430.             /* Now resolve each operand independently.*/
  1431.  
  1432.             resolve2(arg1, t1);
  1433.             /* The membership tests are not static but their arguments 
  1434.               * may be universal. Convert them to non-universal form for 
  1435.               * run-time evaluation. Also special case type mark as second arg.
  1436.               */
  1437.             if (op_name == symbol_in || op_name == symbol_notin) {
  1438.                 if (t2 == symbol_universal_integer)
  1439.                     specialize(arg1, symbol_integer);
  1440.                 else if (t2 == symbol_universal_real)
  1441.                     specialize(arg1, symbol_float);
  1442.                 if (N_KIND(arg2) != as_simple_name)
  1443.                     resolve2(arg2, t2);
  1444.                 else
  1445.                 /* type mark. Its type is of course its own name. */
  1446.                 N_TYPE(arg2) = N_UNQ(arg2);
  1447.             }
  1448.             else             /* resolve second argument */
  1449.                 resolve2(arg2, t2);
  1450.             /* Comparison operators on  literal expressions are evaluated
  1451.              * separately,  because their arguments are in universal form.
  1452.              */
  1453.             if (in_comparison_ops(op_name ) && t1 == t2
  1454.               && in_univ_types(t1))
  1455.                 literal_expression(expn);
  1456.         }
  1457.         else if (typ == symbol_array_type) { /* Concatenation operator.*/
  1458.             if (op_name == symbol_cat) {
  1459.                 resolve2 (arg1, ctx_type);
  1460.                 resolve2 (arg2, ctx_type);
  1461.             }
  1462.             else {
  1463.                 if (op_name == symbol_cat_ac) {
  1464.                     resolve2 (arg1, ctx_type);
  1465.                     resolve2 (arg2, component_type (ctx_type));
  1466.                     eval_static(arg2);
  1467.                 }
  1468.                 else {
  1469.                     if (op_name == symbol_cat_ca) {
  1470.                         resolve2 (arg1, component_type (ctx_type));
  1471.                         resolve2 (arg2, ctx_type);
  1472.                         eval_static(arg1);
  1473.                     }
  1474.                     else {
  1475.                         if (op_name == symbol_cat_cc) {
  1476.                             resolve2 (arg1, component_type (ctx_type));
  1477.                             eval_static(arg1);
  1478.                             resolve2 (arg2, component_type (ctx_type));
  1479.                             eval_static(arg2);
  1480.                         }
  1481.                     }
  1482.                 }
  1483.             }
  1484.         }
  1485.         else {
  1486.             /* Other binary operators.*/
  1487.             resolve2(arg1, ctx_type);
  1488.             resolve2(arg2, ctx_type);
  1489.         }
  1490.     }
  1491.     else {
  1492.         /*Unary operator. Type of argument is that imposed by context.*/
  1493.         arg1 = (Node)arg_list[1];
  1494.         resolve2(arg1, ctx_type);
  1495.         /* if the argument to unary minus is universal real, the default
  1496.          * operator is floating negation. If the context is fixed, adjust
  1497.          * accordingly.
  1498.          */
  1499.         if (op_name == symbol_subufl && is_fixed_type(ctx_type))
  1500.             N_UNQ(N_AST1(expn)) = symbol_subufx;
  1501.         if (in_univ_types(ctx_type))
  1502.             literal_expression(expn);
  1503.     }
  1504. }
  1505.  
  1506. void specialize(Node u_expr, Symbol ctx_type)  /*;specialize*/
  1507. {
  1508.     /* Convert a universal numeric into a specific one, if the context impo-
  1509.      * ses a non-universal numeric type.
  1510.      */
  1511.  
  1512.     int k;
  1513.     Const    v;
  1514.     Rational    ra;
  1515.  
  1516.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  specialize");
  1517.  
  1518.     /*$$$$ Test should be more general.*/
  1519.     k = N_KIND(u_expr);
  1520.     if (k!=as_ivalue && k!=as_int_literal && k!=as_real_literal) return;
  1521.  
  1522.     if (!in_univ_types(ctx_type )) {
  1523.         v = (Const) N_VAL(u_expr);
  1524.  
  1525.         if (is_universal_integer(v)) {
  1526.             N_VAL(u_expr) =
  1527.               (char *) int_const(int_toi(v->const_value.const_uint));
  1528.             if (arith_overflow)
  1529.                 /* overflow has occurs during conversion to integer */
  1530.                 create_raise(u_expr, symbol_constraint_error); 
  1531.             else      /* From universal to SETL integer*/
  1532.                 N_TYPE(u_expr) = symbol_integer; 
  1533.         }
  1534.         else if (is_universal_real(v)) {
  1535.             if ( !is_fixed_type(root_type(ctx_type))) {
  1536.                 /* N_VAL(u_expr)  =
  1537.                  *   (char *) real_const(rat_tor(v->const_value.const_rat,
  1538.                  *   ADA_REAL_DIGITS));
  1539.                  */
  1540.                 ra  = RATV (v);
  1541.  
  1542.                 /* the conversion from a rational to a real value will be
  1543.                  * correct is the rational value belongs to the real interval
  1544.                  */
  1545.  
  1546.                 if (rat_lss (ra, rat_frr (ADA_MIN_REAL)) || 
  1547.                     rat_gtr (ra, rat_frr (ADA_MAX_REAL))) {
  1548.                     /* overflow occurs during conversion */
  1549.                     /*N_VAL (u_expr) = const_new (CONST_OM); */
  1550.                     create_raise(u_expr, symbol_constraint_error);
  1551.                 }
  1552.                 else {
  1553.                     N_VAL(u_expr) =
  1554.                       (char *) real_const(rat_tor(v->const_value.const_rat,
  1555.                       ADA_REAL_DIGITS));
  1556.                     N_TYPE(u_expr) = symbol_float; 
  1557.                 }
  1558.             }
  1559.             else
  1560.                 /* label universal constant with the specific fixed type */
  1561.                 N_TYPE(u_expr) = ctx_type;
  1562.         }
  1563.         /*$$$ Do something about overflow in conversion.*/
  1564.     }
  1565. }
  1566.  
  1567. static Const check_constant_overflow(Const x)        /*;check_constant_overflow*/
  1568. {
  1569.     if is_const_om (x) 
  1570.         return x;
  1571.     else if (is_const_int (x)) {
  1572.         if ((INTV (x) < ADA_MIN_INTEGER) || (INTV(x) > ADA_MAX_INTEGER))
  1573.             return const_new (CONST_OM);
  1574.         else
  1575.             return x;
  1576.     }
  1577.     /* else if (is_const_uint (x)) {
  1578.      *     if (int_lss(UINTV (x), ADA_MIN_INTEGER_MP) || int_gtr(UINTV(x),
  1579.      *    ADA_MAX_INTEGER_MP))
  1580.      *         return const_new (CONST_OM);
  1581.      *  else return x;
  1582.      * }
  1583.      * else if (is_const_rat (x)) {
  1584.      *     if (rat_gtr (RATV (x), ADA_MAX_FLOAT) )
  1585.      *         return const_new (CONST_OM);
  1586.      *     else return x; 
  1587.      */
  1588.     else if (is_const_fixed (x)) {
  1589.         if ((FIXEDV (x) < ADA_MIN_FIXED) || (FIXEDV(x) > ADA_MAX_FIXED))
  1590.             return const_new (CONST_OM);
  1591.         else
  1592.             return x;
  1593.     }
  1594.     else if (is_const_real (x)) {
  1595.         if ((REALV (x) < ADA_MIN_REAL) || (REALV(x) > ADA_MAX_REAL))
  1596.             return const_new (CONST_OM);
  1597.         else
  1598.             return x;
  1599.     }
  1600.     else 
  1601.         return x;
  1602. }
  1603.  
  1604. /*TBSL: check argument types, esp. in calls, for type_error */
  1605. static void literal_expression(Node expn)              /*;literal_expression*/
  1606. {
  1607.     /* TBSL: need to always return uint case converting input
  1608.      * cases of CONST_INT to long form - review this  ds 11 sep 84
  1609.      */
  1610.     /* Use the arbitrary precision arithmetic package to evaluate an arith-
  1611.      * metic expression whose arguments are literal. This routine is called
  1612.      * in contexts that require a universal value, i.e. constant definitions.
  1613.      * If the constituents are not universal, the expression is returned as
  1614.      * is.
  1615.      * Several attributes deliver a universal value, but are nevertheless
  1616.      * evaluated at run-time. If these attributes are companion operands of
  1617.      * literals, then these literals must be converted to non-universal form,
  1618.      * real or integer depending on the attribute. Note that this conversion is
  1619.      * never to a fixed point type, even for attributes of fixed points.
  1620.      */
  1621.  
  1622.     Node    op_node, args_node, e1, e2;
  1623.     Tuple arg_list;
  1624.     Const op1, op2;
  1625.     int is_int;
  1626.     Symbol    sym;
  1627.     Const    ivalue;
  1628.  
  1629.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  literal_expression");
  1630.  
  1631.     op_node = N_AST1(expn);
  1632.     args_node = N_AST2(expn);
  1633.     arg_list = N_LIST(args_node);
  1634.  
  1635.     if (tup_size( arg_list) == 2 ) {    /* binary operation.*/
  1636.         e1 = (Node) arg_list[1];
  1637.         e2 = (Node) arg_list[2];
  1638.  
  1639.         if (N_KIND(e1) == as_ivalue) {
  1640.             op1 = (Const) N_VAL(e1);
  1641.             /* extract possible values */
  1642.             if (N_KIND(e2) == as_ivalue) {
  1643.                 op2 = (Const) N_VAL(e2);
  1644.                 /* In the case of mixed mode operations on fixed types, the
  1645.                  * second argument is already folded to INTEGER. If a static
  1646.                  * evaluation is possible, make it into a universal object again
  1647.                  */
  1648.                 if (is_const_int(op2)
  1649.                   && (is_const_rat(op1) || N_UNQ(op_node) == symbol_expi))
  1650.                     op2 = uint_const(int_fri(INTV(op2)));
  1651.             }
  1652.             else {
  1653.                 /* op2 is attribute expr. If first operand is integer, check
  1654.                  * its bounds . If it is a mixed operation, convert the first
  1655.                  * operand to the most precise floating type available.
  1656.                  */
  1657.                 if(is_const_int(op1) || is_const_uint(op1))
  1658.                     specialize(e1, symbol_integer);
  1659.                 else
  1660.                     specialize(e1, symbol_float);
  1661.                 return;
  1662.             }
  1663.         }
  1664.         else {            /* op1 is attribute expr.*/
  1665.             if (N_KIND(e2) == as_ivalue) {
  1666.                 op2 = (Const) N_VAL(e2);
  1667.                 if(is_const_int(op2) || is_const_uint(op2))
  1668.                     specialize(e2, symbol_integer);
  1669.                 else
  1670.                     specialize(e2, symbol_float);
  1671.                 return;
  1672.             }
  1673.             else {            /* They both are.*/
  1674.                 return;
  1675.             }
  1676.         }
  1677.     }
  1678.     else {
  1679.         e1 = (Node) arg_list[1];
  1680.         if (N_KIND(e1) != as_ivalue) {
  1681.             return;
  1682.         }
  1683.         else {
  1684.             op1 = (Const) N_VAL(e1);
  1685.         }
  1686.     }
  1687.  
  1688.     is_int = is_universal_integer(op1);
  1689.     if ((! is_int && !(is_const_rat(op1)))
  1690.       || (tup_size(arg_list) == 2 && !(is_const_uint(op2))
  1691.       && !(is_const_rat(op2)))) {
  1692.         return;
  1693.     }
  1694.  
  1695.     sym =N_UNQ(op_node);
  1696.  
  1697.     if (sym == symbol_addi) {
  1698.         const_check(op1, CONST_UINT);
  1699.         const_check(op2, CONST_UINT);
  1700.         ivalue = uint_const(int_add(UINTV(op1), UINTV(op2)));
  1701.     }
  1702.     else if (sym == symbol_addfl || sym == symbol_addfx) {
  1703.         const_check(op1, CONST_RAT);
  1704.         const_check(op2, CONST_RAT);
  1705.         ivalue = rat_const(rat_add(RATV(op1), RATV(op2)));
  1706.     }
  1707.     else if (sym == symbol_subi) {
  1708.        const_check(op1, CONST_UINT);
  1709.        const_check(op2, CONST_UINT);
  1710.        ivalue = uint_const(int_sub(UINTV(op1), UINTV(op2)));
  1711.     }
  1712.     else if (sym == symbol_subfl|| sym == symbol_subfx) {
  1713.         const_check(op1, CONST_RAT);
  1714.         const_check(op2, CONST_RAT);
  1715.         ivalue = rat_const(rat_sub(RATV(op1), RATV(op2)));
  1716.     }
  1717.     else if (sym == symbol_muli) {
  1718.         const_check(op1, CONST_UINT);
  1719.         const_check(op2, CONST_UINT);
  1720.         ivalue = uint_const(int_mul(UINTV(op1), UINTV(op2)));
  1721.     }
  1722.     else if (sym == symbol_mulfl || sym == symbol_mulfx) {
  1723.         const_check(op1, CONST_RAT);
  1724.         const_check(op2, CONST_RAT);
  1725.         ivalue =  rat_const(rat_mul(RATV(op1), RATV(op2)));
  1726.     }
  1727.     else if (sym == symbol_mulfxi || sym == symbol_mulfli) {
  1728.         const_check(op1, CONST_RAT);
  1729.         const_check(op2, CONST_UINT);
  1730.         RATV(op1) = RATV(op1);
  1731.         ivalue = rat_const(rat_red(int_mul(num(RATV(op1)), UINTV(op2)),
  1732.           den(RATV(op1))));
  1733.     }
  1734.     else if (sym == symbol_divfxi || sym == symbol_divfli) {
  1735.         const_check(op1, CONST_RAT);
  1736.         const_check(op2, CONST_UINT);
  1737.         if (int_eql(UINTV(op2),int_fri(0)))
  1738.             ivalue = const_new(CONST_OM);
  1739.         else
  1740.                ivalue = rat_const(rat_red(num(RATV(op1)), int_mul(den(RATV(op1)), 
  1741.               UINTV(op2))));
  1742.     }
  1743.     else if (sym == symbol_divi) {
  1744.         const_check(op1, CONST_UINT);
  1745.         const_check(op2, CONST_UINT);
  1746.         ivalue = uint_const(int_quo(UINTV(op1), UINTV(op2)));
  1747.     }
  1748.     else if (sym == symbol_divfl || sym == symbol_divfx) {
  1749.         const_check(op1, CONST_RAT);
  1750.         const_check(op2, CONST_RAT);
  1751.         ivalue =  rat_const(rat_div(RATV(op1), RATV(op2)));
  1752.     }
  1753.     else if (sym == symbol_remi) {
  1754.         const_check(op2, CONST_UINT);
  1755.         if (int_eql(UINTV(op2),int_fri(0)))
  1756.             ivalue = const_new(CONST_OM);
  1757.         else
  1758.             ivalue = uint_const(int_rem(UINTV(op1), UINTV(op2)));
  1759.     }
  1760.     else if (sym == symbol_modi) {
  1761.         const_check(op2, CONST_UINT);
  1762.         if (int_eql(UINTV(op2),int_fri(0)))
  1763.             ivalue = const_new(CONST_OM);
  1764.         else {
  1765.             const_check(op1, CONST_UINT);
  1766.             const_check(op2, CONST_UINT);
  1767.             ivalue = uint_const(int_mod(UINTV(op1), UINTV(op2)));
  1768.         }
  1769.     }
  1770.     else if (sym == symbol_expi) {
  1771.         const_check(op2, CONST_UINT);
  1772.         if (int_lss(UINTV(op2),int_fri(0)))
  1773.             ivalue = const_new(CONST_OM); 
  1774.         else {
  1775.             const_check(op1, CONST_UINT);
  1776.             const_check(op2, CONST_UINT);
  1777.             ivalue = uint_const(int_exp(UINTV(op1), UINTV(op2)));
  1778.         }
  1779.     }
  1780.     else if (sym == symbol_expfl) {
  1781.         const_check(op1, CONST_RAT);
  1782.         const_check(op2, CONST_UINT);
  1783.         ivalue = rat_const(rat_exp(RATV(op1), UINTV(op2)));
  1784.     }
  1785.     else if (sym == symbol_eq) {
  1786.         ivalue = int_const(const_eq(op1, op2));
  1787.     }
  1788.     else if (sym == symbol_ne) {
  1789.         ivalue = int_const(!const_eq(op1, op2));
  1790.     }
  1791.     else if(sym == symbol_gt) {
  1792.         ivalue = int_const(const_gt(op1, op2));
  1793.     }
  1794.     else if (sym == symbol_lt) {
  1795.         ivalue = int_const(const_lt(op1, op2));
  1796.     }
  1797.     else if (sym == symbol_ge) {
  1798.         ivalue= int_const(const_ge(op1, op2));
  1799.     }
  1800.     else if (sym == symbol_le)  {
  1801.         ivalue = int_const(const_le(op1, op2));
  1802.     }
  1803.     else if (sym == symbol_addui || sym == symbol_addufl || sym==symbol_addufx){
  1804.         ivalue = op1;
  1805.     }
  1806.     else if(sym == symbol_subui) {
  1807.         const_check(op1, CONST_UINT);
  1808.         ivalue = uint_const(int_umin(UINTV(op1)));
  1809.     }
  1810.     else if (sym == symbol_subufl || sym == symbol_subufx) {
  1811.         const_check(op1, CONST_RAT);
  1812.         ivalue = rat_const(rat_umin(RATV(op1)));
  1813.     }
  1814.     else if (sym == symbol_absi) {
  1815.         const_check(op1, CONST_UINT);
  1816.         ivalue = uint_const(int_abs(UINTV(op1)));
  1817.     }
  1818.     else if (sym == symbol_absfl || sym == symbol_absfx) {
  1819.         const_check(op1, CONST_RAT);
  1820.         ivalue = rat_const(rat_abs(RATV(op1)));
  1821.     }
  1822.     else {         /* Error: not a universal operator. */
  1823.         ivalue = const_new(CONST_OM); 
  1824.     }
  1825.  
  1826.     /* the previous calculus may have raised the overflow flag 
  1827.      * if (arith_overflow) {
  1828.      *     arith_overflow = FALSE;
  1829.      *     ivalue =  const_new (CONST_OM);}
  1830.      */
  1831.  
  1832.     ivalue = check_constant_overflow (ivalue);
  1833.  
  1834.     if (ivalue->const_kind == CONST_OM)
  1835.         create_raise(expn, symbol_constraint_error);
  1836.     else {
  1837.         N_KIND(expn) = as_ivalue;
  1838.         N_AST1(expn) = N_AST2(expn) = N_AST3(expn) = N_AST4(expn) = (Node)0;
  1839.         copy_span(e1, expn);
  1840.         N_VAL(expn) = (char *)ivalue;
  1841.     }
  1842. }
  1843.  
  1844. static Tuple order_arg_list(Node arg_list_node, Tuple sig) /*;order_arg_list*/
  1845. {
  1846.     /* Normalize an argument list (possibly containing named associations)
  1847.      * according to the signature -sig-. Called for subprogram and operators.
  1848.      */
  1849.  
  1850.     Tuple    arg_list;
  1851.     Node    actual, arg, choice_list, a_expr, choice_node, id_node;
  1852.     int        p, actuals_seen, i, first_named;
  1853.     Tuple    new_list;
  1854.     Tuple    named_args;
  1855.     Symbol    f_name;
  1856.     int found_name;
  1857.     int        exists;
  1858.     Fortup    ft1, ft2;
  1859.  
  1860.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : order_arg_list");
  1861.  
  1862.     arg_list = N_LIST(arg_list_node);
  1863.     exists = FALSE;
  1864.     FORTUPI(actual=(Node), arg_list, p, ft1);
  1865.         if (N_KIND(actual) == as_choice_list) {
  1866.             exists = TRUE;
  1867.             break;
  1868.         }
  1869.     ENDFORTUP(ft1);
  1870.     if (exists) {
  1871.         first_named = p;
  1872.         exists = FALSE;
  1873.         for (i = p+1;i <= tup_size(arg_list); i++) {
  1874.             actual = (Node) arg_list[i];
  1875.             if (N_KIND(actual) != as_choice_list) {
  1876.                 exists= TRUE;
  1877.                 break;
  1878.             }
  1879.         }
  1880.         if (exists) {
  1881. #ifdef ERRNUM
  1882.             errmsgn(279, 280, actual);
  1883. #else
  1884.             errmsg("No positional arguments can appear after named ones",
  1885.               "6.4", actual);
  1886. #endif
  1887.             return (Tuple)0;
  1888.         }
  1889.     }
  1890.     else
  1891.         first_named = tup_size(arg_list) + 1;
  1892.     new_list = tup_new(first_named - 1);
  1893.     for (i = 1; i < first_named; i++)
  1894.         new_list[i] = arg_list[i];
  1895.     named_args = tup_new(tup_size(arg_list) - first_named + 1);
  1896.     for (i = first_named; i <= tup_size(arg_list); i++)
  1897.         named_args[i - first_named + 1] = arg_list[i];
  1898.     actuals_seen = first_named - 1;
  1899.  
  1900.     FORTUP(arg=(Node), named_args, ft1);
  1901.         choice_list = N_AST1(arg);
  1902.         a_expr = N_AST2(arg);
  1903.         exists = FALSE;
  1904.         if (tup_size(N_LIST(choice_list)) != 1) exists = TRUE;
  1905.         if (exists == FALSE) {
  1906.             FORTUP(choice_node = (Node), N_LIST(choice_list), ft2);
  1907.                 if (N_KIND(choice_node) != as_choice_unresolved) {
  1908.                     exists = TRUE;
  1909.                     break;
  1910.                 }
  1911.             ENDFORTUP(ft2);
  1912.         }
  1913.         if ( exists ) {
  1914. #ifdef ERRNUM
  1915.             errmsgn(281, 280, choice_list);
  1916. #else
  1917.             errmsg("Invalid format for argument association", "6.4",
  1918.               choice_list);
  1919. #endif
  1920.             return (Tuple)0;
  1921.         }
  1922.     ENDFORTUP(ft1);
  1923.  
  1924.     if (cdebug2 > 2) {
  1925.     }
  1926.  
  1927.     for (i = first_named; i <= tup_size(sig); i++) {
  1928.         f_name = (Symbol) sig[i];
  1929.         found_name = FALSE;
  1930.  
  1931.         FORTUP(arg=(Node), named_args, ft1);
  1932.             choice_list = N_AST1(arg);
  1933.             a_expr = N_AST2(arg);
  1934.             id_node = N_AST1((Node) (N_LIST(choice_list)[1]));
  1935.             if (streq(N_VAL(id_node), original_name(f_name))) {
  1936.                 found_name = TRUE;
  1937.                 break;
  1938.             }
  1939.         ENDFORTUP(ft1);
  1940.  
  1941.         if (found_name) {
  1942.             new_list = tup_with(new_list, (char *) a_expr);
  1943.             actuals_seen += 1;
  1944.             current_node = id_node;
  1945.             check_void(N_VAL(id_node));
  1946.         }
  1947.         else if ((Node) default_expr(f_name) != OPT_NODE)
  1948.             new_list = tup_with(new_list , (char *) OPT_NODE);
  1949.             /* Just a marker. Type is correct*/
  1950.         else            /* Name not present*/
  1951.             return (Tuple)0;
  1952.     }
  1953.  
  1954.     if (cdebug2 > 2) {
  1955.     }
  1956.  
  1957.     if (actuals_seen == tup_size(arg_list)        /* all actuals seen.*/
  1958.       && tup_size(new_list) == tup_size(sig))  /* all formals matched */
  1959.         return(new_list);
  1960.     else return (Tuple)0;
  1961. }
  1962.  
  1963. void complete_arg_list(Tuple formals, Node arg_list_node) /*;complete_arg_list*/
  1964. {
  1965.     /* This procedure completes the formatting of the argument list of
  1966.      * a subprogram or entry call. This is done in the second,
  1967.      * top-down pass of overloading resolution. The argument list is
  1968.      * reordered, the names of the formals are removed from the actuals,
  1969.      * and default values are inserted in the place of missing parameters.
  1970.      * Types have already been validated during pass one, and default para-
  1971.      * meters are known to exist where needed.
  1972.      */
  1973.  
  1974.     Tuple    arg_list, complete_args;
  1975.     int        i;
  1976.     Node    actual, default_node, default_copy;
  1977.     Fortup    ft1;
  1978.     Symbol    f;
  1979.  
  1980.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_arg_list");
  1981.  
  1982.     arg_list = order_arg_list(arg_list_node, formals); /* Normalize arguments*/
  1983.     /* if arg_list = om then ?*/
  1984.  
  1985.     complete_args = tup_new(0);
  1986.     /* Complete type resolution of each actual, and insert default expression
  1987.      * for those that are missing; default expressions are known to exist.
  1988.      */
  1989.     FORTUPI(f=(Symbol), formals, i, ft1);
  1990.         actual = (Node) arg_list[i];
  1991.         /* If no named association, a default value must be present,
  1992.          * unless, there was a previous error.
  1993.          */
  1994.  
  1995.         if (actual == OPT_NODE) {
  1996.             if (f != symbol_any_id) {
  1997.                 default_node = (Node) default_expr(f);
  1998.                 /* we assume all trees read in before use so node should be
  1999.                  * available.
  2000.                  */
  2001.                 default_copy = copy_tree(default_node);
  2002.                 if (fold_context) eval_static(default_copy);
  2003.                 /* No constant folding in the middle of a conformance check */
  2004.                 complete_args = tup_with(complete_args, (char *) default_copy);
  2005.             }
  2006.             else        /* previous error. */
  2007.                 complete_args = tup_with(complete_args, (char *) OPT_NODE);
  2008.         }
  2009.         else {
  2010.             bind_arg(actual, TYPE_OF(f), NATURE(f), i);
  2011.             if (fold_context) eval_static(actual);
  2012.             complete_args = tup_with(complete_args, (char *) actual);
  2013.         }
  2014.     ENDFORTUP(ft1);
  2015.     N_LIST(arg_list_node) = complete_args;
  2016. }
  2017.  
  2018. static void bind_arg(Node actual, Symbol f_type, int f_mode, int i)/*;bind_arg*/
  2019. {
  2020.     /* Unlike the high-level version of Ada/Ed, the C front-end does not
  2021.      * indicate what constraints, if any, must be applied to actual parameters.
  2022.      * The job is done completely by the code generator, and sequences of
  2023.      * constraint checks on entry and exit are emitted in gen_prelude and
  2024.      * gen_postlude.
  2025.      */
  2026.  
  2027.     Set a_types;
  2028.     Symbol    a_type;
  2029.     int out_c;
  2030.     Node    a;
  2031.     int        exists, may_others;
  2032.     Forset    fs1;
  2033.  
  2034.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  bind_arg");
  2035.  
  2036.     a_types = N_PTYPES(actual);
  2037.  
  2038.     /* One of its possible types must be compatible with the formal.*/
  2039.     exists = FALSE;
  2040.     FORSET(a_type=(Symbol), a_types, fs1);
  2041.         if(compatible_types(f_type, a_type)) {
  2042.             exists = TRUE;
  2043.             break;
  2044.         }
  2045.     ENDFORSET(fs1);
  2046.     if (!exists) /* assertion failure */
  2047.         chaos("assertion failure bind_arg");
  2048.     /* An out parameter may appear as the actual for another out parameter.*/
  2049.     out_c = out_context;
  2050.     out_context = (f_mode == na_out);
  2051.     /*  If the actual is an aggregate, there is no sliding for it, and named
  2052.      *  associations can appear with "others" (cf. 4.3.2(6)).
  2053.      */
  2054.     may_others = full_others;
  2055.     full_others = TRUE;
  2056.  
  2057.     resolve2(actual, f_type);
  2058.     apply_constraint (actual, f_type);
  2059.  
  2060.     /* verify that inout and out parameters are valid targets
  2061.      * of assignments.
  2062.      */
  2063.     if (N_KIND(actual) == as_qual_range || N_KIND(actual) == as_qual_index
  2064.       || N_KIND(actual) == as_qual_discr || N_KIND(actual) == as_qual_aindex 
  2065.       || N_KIND(actual) == as_qual_adiscr)
  2066.         a = N_AST1(actual);
  2067.     else
  2068.         a = actual;
  2069.  
  2070.     if (N_KIND(a) == as_insert)   /* case of an array conversion */
  2071.         a = N_AST1(a);
  2072.     if (f_mode != na_in && !is_variable(a)) {
  2073. #ifdef ERRNUM
  2074.         str_num_errmsgn(282, nature_str(f_mode), i, 283, actual);
  2075. #else
  2076.         errmsg_str_num("% actual parameter no. % in call is not a variable",
  2077.           nature_str(f_mode), i, "6.4.1", actual);
  2078. #endif
  2079.     }
  2080.  
  2081.     if (is_scalar_type(f_type)) /* Convert from universal value if need be.*/
  2082.         specialize(actual, f_type);
  2083.     out_context = out_c;
  2084.     full_others = may_others;
  2085. }
  2086.  
  2087. static int in_comparison_ops(Symbol op)            /*;in_comparison_ops*/
  2088. {
  2089.     /* test for comparison operator */
  2090.     return (
  2091.       op == symbol_eq || op == symbol_ne
  2092.       || op == symbol_lt || op == symbol_gt
  2093.       || op == symbol_le || op == symbol_ge );
  2094. }
  2095.  
  2096. static Set find_compatible_type(Set typ1, Set typ2) /*; find_compatible_type */
  2097. {
  2098.     /* return the types of typ1 (t1) such as the component type of t1 is 
  2099.      * compatible with at least one type of typ2
  2100.     */
  2101.  
  2102.     Set result;
  2103.     Symbol t1, t2;
  2104.     Forset fs1, fs2;
  2105.  
  2106.     result = set_new (0);
  2107.  
  2108.     FORSET (t1 = (Symbol), typ1, fs1);
  2109.         FORSET (t2 = (Symbol), typ2, fs2);
  2110.         if (compatible_types ((Symbol) component_type (t1), t2))
  2111.             result = set_with (result, (char *) base_type (t1)); 
  2112.         ENDFORSET (fs2);
  2113.     ENDFORSET (fs1);
  2114.     return result;
  2115. }
  2116.  
  2117. static Tuple valid_concatenation_type(Set typ1, Set typ2)
  2118.                                                 /*;valid_concatenation_type*/
  2119. {
  2120.     /* Concatenation is performed by 4 distinct operators, corresponding to
  2121.      * array-array, array-component, component-array, and component-component
  2122.      * cases. If either operand is an aggregate, or if both operands are
  2123.      * components, then the candidate resulting types are a subset of the
  2124.      * one-dimensional array types that are in scope.
  2125.      */
  2126.  
  2127.     Set arrays1, arrays2, arrays3, types, new_types;
  2128.     Set opns, types1, types2, types3;
  2129.     Symbol t1, t2, t3;
  2130.     Forset fs1, fs2, fs3;
  2131.     Tuple tup;
  2132.     int exist_composite_in_typ1, exist_composite_in_typ2;
  2133.  
  2134.     arrays1 = set_new (0);
  2135.     arrays2 = set_new (0);
  2136.     arrays3 = set_new (0);
  2137.     types = set_new (0);
  2138.     opns = set_new (0);
  2139.  
  2140.     FORSET  (t1=(Symbol), typ1, fs1);
  2141.         if (is_array (t1) && no_dimensions (t1) == 1)
  2142.             arrays1 = set_with (arrays1, (char *) base_type (t1));
  2143.     ENDFORSET (fs1);
  2144.  
  2145.     FORSET  (t1=(Symbol), typ2, fs1);
  2146.         if (is_array (t1) && no_dimensions (t1) == 1)
  2147.             arrays2 = set_with (arrays2, (char *) base_type (t1));
  2148.     ENDFORSET (fs1);
  2149.  
  2150.     FORSET  (t1=(Symbol), find_agg_types (), fs1);
  2151.         if (is_array (t1) && no_dimensions (t1) == 1)
  2152.             arrays3 = set_with (arrays3, (char *) base_type (t1));
  2153.     ENDFORSET (fs1);
  2154.  
  2155.     exist_composite_in_typ1 = FALSE;
  2156.     FORSET (t1 = (Symbol), typ1, fs1);
  2157.         if (NATURE (base_type (t1)) == na_aggregate)
  2158.         { 
  2159.             exist_composite_in_typ1 = TRUE; 
  2160.             break; 
  2161.         }
  2162.     ENDFORSET (fs1);
  2163.  
  2164.     exist_composite_in_typ2 = FALSE;
  2165.     FORSET (t1 = (Symbol), typ2, fs1);
  2166.         if (NATURE (base_type (t1)) == na_aggregate)
  2167.         { 
  2168.             exist_composite_in_typ2 = TRUE; 
  2169.             break; 
  2170.         }
  2171.     ENDFORSET (fs1);
  2172.  
  2173.     /* First we look for compatible arrays to concatenate. */
  2174.     if (exist_composite_in_typ1)
  2175.         types = arrays2; 
  2176.     else
  2177.     {
  2178.         FORSET (t1 = (Symbol), arrays1, fs1);
  2179.             FORSET (t2 = (Symbol), typ2, fs2);
  2180.                 if (compatible_types (t1, t2))
  2181.                     types = set_with (types, (char *) base_type (t1));
  2182.             ENDFORSET (fs2);
  2183.         ENDFORSET (fs1);
  2184.     }
  2185.     if (set_size (types) != 0)
  2186.         opns = set_with (opns, (char *)symbol_cat); 
  2187.  
  2188.     /* Next, look for aggregate or array type concatenated with compatible
  2189.      * component.
  2190.      */
  2191.     if (exist_composite_in_typ1)
  2192.         types1 = find_compatible_type (arrays3, typ2);
  2193.     else
  2194.         types1 = find_compatible_type (arrays1, typ2);
  2195.  
  2196.     if (set_size (types1) != 0)
  2197.     { 
  2198.         types = set_union (types, types1);
  2199.         opns = set_with (opns, (char *)symbol_cat_ac);
  2200.     }
  2201.  
  2202.     /* The component-array case is similar. */
  2203.     if (exist_composite_in_typ2)
  2204.         types2 = find_compatible_type (arrays3, typ1);
  2205.     else
  2206.         types2 = find_compatible_type (arrays2, typ1);
  2207.     if (set_size (types2) != 0)
  2208.     { 
  2209.         types = set_union (types, types2);
  2210.         opns = set_with (opns, (char *)symbol_cat_ca);
  2211.     }
  2212.  
  2213.     /* Next, both arguments may be the component type of some one-dimensional 
  2214.      * array type, as in `A` & 'B'. Note that the arguments may still be
  2215.      * arrays, and the result type be a one-dimensional array of arrays.
  2216.      * The candidate resulting types are all array types in scope whose
  2217.      * component types are compatible with both operands.
  2218.      */
  2219.  
  2220.     types3 = set_new (0);
  2221.     FORSET (t1 = (Symbol), arrays3, fs1);
  2222.         FORSET (t2 = (Symbol), typ1, fs2);
  2223.             FORSET (t3 = (Symbol), typ2, fs3);
  2224.             if (compatible_types ((Symbol) component_type (t1), t2)
  2225.               && compatible_types ((Symbol) component_type (t1), t3))
  2226.                 types3 = set_with (types3, (char *)base_type (t1)); 
  2227.             ENDFORSET (fs3);
  2228.         ENDFORSET (fs2);
  2229.     ENDFORSET (fs1);
  2230.  
  2231.     if (set_size (types3) != 0) { 
  2232.         types = set_union (types, types3);
  2233.         opns = set_with (opns, (char *)symbol_cat_cc);
  2234.     }
  2235.  
  2236.     /* Finally, if both arguments are aggregates, the result can be an array
  2237.      * type.
  2238.      */
  2239.     if ((exist_composite_in_typ1)  && (exist_composite_in_typ2)) {
  2240.         types = set_with (types, (char *)symbol_array_type);
  2241.         opns = set_with (opns, (char *)symbol_cat);
  2242.     }
  2243.  
  2244.     new_types = set_new (0);
  2245.     FORSET (t1 = (Symbol), types, fs1);
  2246.         if (! is_limited_type (t1))
  2247.             new_types = set_with (new_types , (char *) t1);
  2248.     ENDFORSET (fs1);
  2249.  
  2250.     tup = tup_new (2);
  2251.     tup [1] = (char *) opns;
  2252.     tup [2] = (char *) new_types;
  2253.  
  2254.     return tup;
  2255. }
  2256.