sytb.c

Go to the documentation of this file.
00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2 of the GNU General Public License as
00007   published by the Free Software Foundation.
00008 
00009   This program is distributed in the hope that it would be useful, but
00010   WITHOUT ANY WARRANTY; without even the implied warranty of
00011   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00012 
00013   Further, this software is distributed without any warranty that it is
00014   free of the rightful claim of any third person regarding infringement 
00015   or the like.  Any license provided herein, whether implied or 
00016   otherwise, applies only to this software file.  Patent licenses, if 
00017   any, provided herein do not apply to combinations of this program with 
00018   other software, or any other product whatsoever.  
00019 
00020   You should have received a copy of the GNU General Public License along
00021   with this program; if not, write the Free Software Foundation, Inc., 59
00022   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00023 
00024   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00025   Mountain View, CA 94043, or:
00026 
00027   http://www.sgi.com
00028 
00029   For further information regarding this notice, see:
00030 
00031   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00032 
00033 */
00034 
00035 
00036 
00037 static char USMID[] = "\n@(#)5.0_pl/sources/sytb.c      5.25    10/27/99 16:59:36\n";
00038 
00039 # include "defines.h"           /* Machine dependent ifdefs */
00040 
00041 # include "host.m"              /* Host machine dependent macros.*/
00042 # include "host.h"              /* Host machine dependent header.*/
00043 # include "target.m"            /* Target machine dependent macros.*/
00044 # include "target.h"            /* Target machine dependent header.*/
00045 
00046 # ifdef _ARITH_H
00047 # include "arith.h"
00048 # endif
00049 
00050 # include "globals.m"
00051 # include "tokens.m"
00052 # include "sytb.m"  
00053 # include "p_globals.m"
00054 # include "debug.m"
00055 
00056 # include "globals.h"
00057 # include "tokens.h"
00058 # include "sytb.h"
00059 # include "p_globals.h"
00060 
00061 # ifdef _WHIRL_HOST64_TARGET64
00062 int double_stride = 0;
00063 # endif /* _WHIRL_HOST64_TARGET64 */
00064 
00065 /******************************************************************\
00066 |* Function prototypes of static functions declared in this file. *|
00067 \******************************************************************/
00068 
00069 static  void    calculate_pad(size_offset_type  *, size_offset_type *, int);
00070 static  int     ntr_global_bounds_tbl(int);
00071 
00072 
00073 /******************************************************************\
00074 |* Other static stuff needed locally in this file.                *|
00075 \******************************************************************/
00076 
00077 /* "pvp_isnormal" mimics the "isnormal" IEEE macro but is used to detect      */
00078 /* an abnormal floating point value on a PVP machine.                         */
00079 
00080 static boolean pvp_isnormal(int, long_type *);
00081 
00082 
00083 /* ntr_abnormal_ieee_const is only needed for IEEE machines but since we have */
00084 /* no ifdef macros that control in/exclusion of code for IEEE machines, it    */
00085 /* exists on all machines.  It will only ever be called on IEEE machines.     */
00086 
00087 static int ntr_abnormal_ieee_const(int, long_type *);
00088 
00089 
00090 /* "is_normal" mimics the "isnormal" macro we put into our C compiler.        */
00091 /* "is_normal" evaluates to a nonzero int expression if the value is "normal";*/
00092 /* that is, not zero, subnormal, infinite, or NaN.  This is done by testing   */
00093 /* to see if its exponent is not All-1's or zero.                             */
00094 
00095 static boolean is_normal(int, long_type *);
00096 static int     is_normal_32(long_type *);
00097 static int     is_normal_64(int, long_type *);
00098 static int     is_normal_128(int, long_type *);
00099 
00100 
00101 /* "sign_bit" mimics the "signbit" macro we put into our C compiler.          */
00102 /* "sign_bit" evaluates to a nonzero int expression if its argument value is  */
00103 /* negative.                                                                  */
00104 
00105 static int     sign_bit(int, long_type *);
00106 static int     sign_bit_32(long_type *);
00107 static int     sign_bit_64(long_type *);
00108 static int     sign_bit_128(long_type *);
00109 
00110 
00111 /* "fp_classify" mimics the "fpclassify" macro we put into our C compiler.    */
00112 /* "fp_classify" evaluates to an int value that indicates the class of the    */
00113 /* argument.                                                                  */
00114 
00115 static int     fp_classify(int, long_type *);
00116 static int     fp_classify_32(long_type *);
00117 static int     fp_classify_64(int, long_type *);
00118 static int     fp_classify_128(int, long_type *);
00119 
00120 
00121 static int insert_constant(int, long_type *, int);
00122 static int insert_unordered_constant(int, long_type *, int, int);
00123 static void dump_cn_tree(int, int, int);
00124 
00125 /* The following #define constants are likewise only needed for IEEE machines */
00126 /* and are only referenced on IEEE machines.                                  */
00127 
00128 /* Values representing 32-bit real.                                           */
00129 
00130 #define IEEE_32_EXPO_BITS           8
00131 #define IEEE_32_MANT_BITS          23
00132 #define IEEE_32_EXPONENT           0XFF
00133 #define IEEE_32_EXPO_ALLONES(X)  ((X) == IEEE_32_EXPONENT)
00134 
00135 /* Values representing 64-bit real.                                           */
00136 
00137 #define IEEE_64_EXPO_BITS          11
00138 #define IEEE_64_MANTU_BITS         20
00139 #define IEEE_64_MANTL_BITS         32
00140 #define IEEE_64_EXPONENT           0X7FF
00141 #define IEEE_64_EXPO_ALLONES(X)  ((X) == IEEE_64_EXPONENT)
00142 
00143 /* Values representing the leftmost 64 bits of a 128-bit real.                */
00144 
00145 #define IEEE_128_EXPO_BITS      15
00146 #define IEEE_128_MANTTU_BITS    16
00147 #define IEEE_128_MANTTL_BITS    32
00148 #define IEEE_128_EXPO           0X7FFF
00149 #define IEEE_128_EXPO_ALLONES(X)  ((X) == IEEE_128_EXPO)
00150 
00151 
00152 /* Values representing the different classes of IEEE values.                  */
00153 
00154 #define FP_SGI_NAN           0
00155 #define FP_SGI_INFINITE      1
00156 #define FP_SGI_NORMAL        2
00157 #define FP_SGI_SUBNORMAL     3
00158 #define FP_SGI_ZERO          4
00159 
00160 union  ieee_real_4 { 
00161                         long_type integer_form;
00162                         struct {
00163 # ifdef _TARGET64
00164                                  Uint  UNUSED     : 32;
00165 # endif
00166                                  Uint  sign       : 1;
00167                                  Uint  exponent   : IEEE_32_EXPO_BITS;
00168                                  Uint  mantissa   : IEEE_32_MANT_BITS;
00169                                } parts;
00170                       };
00171 
00172 typedef union ieee_real_4 ieee_real_4_type;
00173 
00174 union  ieee_real_8 { 
00175                          long_type  integer_array[MAX_WORDS_FOR_INTEGER];
00176                          struct { Uint  sign         : 1;
00177                                   Uint  exponent     : IEEE_64_EXPO_BITS;
00178                                   Uint  mantissa_u   : IEEE_64_MANTU_BITS;
00179                                   Uint  mantissa_l   : IEEE_64_MANTL_BITS;
00180                                 } parts;
00181                     };
00182 
00183 typedef union ieee_real_8 ieee_real_8_type;
00184 
00185 union  ieee_real_16 { 
00186 # ifdef _TARGET64
00187                           long_type  integer_array[2];
00188 # else
00189                           long_type  integer_array[4];
00190 # endif
00191                           struct { Uint  sign         : 1;
00192                                    Uint  exponent     : IEEE_128_EXPO_BITS;
00193                                    Uint  mantissa_u1  : IEEE_128_MANTTU_BITS;
00194                                    Uint  mantissa_u2  : IEEE_128_MANTTL_BITS;
00195                                    Uint  mantissa_l1  : IEEE_128_MANTTL_BITS;
00196                                    Uint  mantissa_l2  : IEEE_128_MANTTL_BITS;
00197                                  } parts;
00198                         };
00199 
00200 typedef union ieee_real_16 ieee_real_16_type;
00201 
00202 
00203 /******************************************************************************\
00204 |*                                                                            *|
00205 |* Description:                                                               *|
00206 |*      Compare an integer or real value to the value in a Constant table     *|
00207 |*      entry according to the relational operator "opr".                     *|
00208 |*      The incoming value and the Constant table entry are assumed to be of  *|
00209 |*      the same type.                                                        *|
00210 |*                                                                            *|
00211 |* Input parameters:                                                          *|
00212 |*      value    : the incoming integer or real value                         *|
00213 |*      cn_idx   : Constant table index                                       *|
00214 |*      opr      : the comparison to be done                                  *|
00215 |*                                                                            *|
00216 |* Output parameters:                                                         *|
00217 |*      NONE                                                                  *|
00218 |*                                                                            *|
00219 |* Returns:                                                                   *|
00220 |*      The result of the comparison.                                         *|
00221 |*                                                                            *|
00222 \******************************************************************************/
00223 
00224 boolean compare_value_to_cn(long_type   *value,
00225                             int          cn_idx,
00226                             int          opr)
00227 
00228 {
00229    long_type            result[MAX_WORDS_FOR_NUMERIC];
00230    int                  i;
00231    boolean              is_true         = FALSE;
00232    boolean              tested_not_equal;
00233    int                  type_idx;
00234    int                  word_len;
00235 
00236 
00237    TRACE (Func_Entry,"compare_value_to_cn" , NULL);
00238 
00239 
00240    /* Don't use folder_driver to do EQ/NE comparisons because it's too        */
00241    /* expensive.                                                              */
00242 
00243    if (opr == Eq_Opr  ||  opr == Ne_Opr) {
00244       tested_not_equal = FALSE;
00245 
00246       word_len = TARGET_BITS_TO_WORDS(
00247                     storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]);
00248 
00249       for (i = 0;  i < word_len;  i++) {
00250 
00251          if (const_pool[CN_POOL_IDX(cn_idx) + i] != value[i]) {
00252             tested_not_equal = TRUE;
00253             break;
00254          }
00255       }
00256 
00257       if (opr == Eq_Opr  &&  ! tested_not_equal) {
00258          is_true = TRUE;
00259       }
00260       else if (opr == Ne_Opr  &&  tested_not_equal) {
00261          is_true = TRUE;
00262       }
00263    }
00264    else {
00265       type_idx = CG_LOGICAL_DEFAULT_TYPE;
00266 
00267       if (folder_driver( (char *) value,
00268                          CN_TYPE_IDX(cn_idx),
00269                          (char *) &CN_CONST(cn_idx),
00270                          CN_TYPE_IDX(cn_idx),
00271                          result,
00272                         &type_idx,
00273                          stmt_start_line,
00274                          stmt_start_col,
00275                          2,
00276                          opr)) {
00277 
00278          if (THIS_IS_TRUE(result, type_idx)) {
00279             is_true = TRUE;
00280          }
00281       }
00282    }
00283 
00284    TRACE (Func_Exit, "compare_value_to_cn", NULL);
00285 
00286    return(is_true);
00287 
00288 }  /* compare_value_to_cn */
00289 
00290 
00291 /******************************************************************************\
00292 |*                                                                            *|
00293 |* Description:                                                               *|
00294 |*      srch_sym_tbl searches the local name table for the identifier or      *|
00295 |*      label contained in the identifier field of token.                     *|
00296 |*                                                                            *|
00297 |* Input parameters:                                                          *|
00298 |*      token                   token containing identifier or label to       *|
00299 |*                              search for and length in chars of name        *|
00300 |*                                                                            *|
00301 |* Output parameters:                                                         *|
00302 |*      name_idx                local name table index where match occured    *|
00303 |*                              or where entry should be inserted             *|
00304 |*                                                                            *|
00305 |* Returns:                                                                   *|
00306 |*      attribute table index   if found                                      *|
00307 |*      NULL_IDX                if not found                                  *|
00308 |*                                                                            *|
00309 \******************************************************************************/
00310 
00311 int srch_sym_tbl (char  *name_str,
00312                   int    name_len,
00313                   int   *name_idx)
00314 
00315 {
00316    int          idx;
00317    long         tst_val;       /* result of name comparison */
00318       
00319 
00320    TRACE (Func_Entry, "srch_sym_tbl", name_str);
00321 
00322    /* This is a name table search utility routine */
00323 
00324   tst_val = srch_name_tbl(name_str, 
00325                           name_len,
00326                           &idx,
00327                           loc_name_tbl,
00328                           name_pool,
00329                           SCP_LN_FW_IDX(curr_scp_idx),
00330                           SCP_LN_LW_IDX(curr_scp_idx));
00331    *name_idx = idx;
00332 
00333    if (tst_val != 0) {
00334       idx = NULL_IDX;
00335       TRACE (Func_Exit, "srch_sym_tbl", NULL);
00336    }  
00337    else {
00338       TRACE (Func_Exit, "srch_sym_tbl", 
00339                         &name_pool[LN_NAME_IDX(*name_idx)].name_char);
00340       idx = LN_ATTR_IDX(*name_idx);
00341    }
00342    return (idx);
00343  
00344 }  /* srch_sym_tbl */
00345 
00346 /******************************************************************************\
00347 |*                                                                            *|
00348 |* Description:                                                               *|
00349 |*      ntr_sym_tbl adds the token name to the the name pool, links it        *|
00350 |*      to an attribute table entry through the local name table, and         *|
00351 |*      reserves an attribute table entry for the identifier or label.        *|
00352 |*      The attribute table entry field name_idx is linked to the name in     *|
00353 |*      the name pool.                                                        *|
00354 |*                                                                            *|
00355 |* Input parameters:                                                          *|
00356 |*      token                   token containing identifier or label and      *|
00357 |*                              length of name to be added to symbol table    *|
00358 |*                                                                            *|
00359 |*      name_idx                local name table index where entry is to      *|
00360 |*                              be inserted                                   *|
00361 |*                                                                            *|
00362 |* Output parameters:                                                         *|
00363 |*      NONE                                                                  *|
00364 |*                                                                            *|
00365 |* Returns:                                                                   *|
00366 |*      attribute table index of reserved entry                               *|
00367 |*                                                                            *|
00368 \******************************************************************************/
00369 
00370 int ntr_sym_tbl(token_type *token,
00371                 int         name_idx)
00372 
00373 {
00374    register int          attr_idx;
00375    register int          i;
00376    register int          np_idx;  
00377    register int          scp_idx;
00378 
00379 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00380    register long        *name_tbl_base; /* name table base address */
00381 # endif
00382 
00383 
00384    TRACE (Func_Entry, "ntr_sym_tbl", TOKEN_STR(*token));
00385 
00386 # if defined(_DEBUG)
00387 
00388    if (TOKEN_LEN(*token) == 0 || TOKEN_STR(*token) == NULL) {
00389       PRINTMSG(stmt_start_line, 1200, Internal, stmt_start_col);
00390    }
00391 
00392 # endif
00393 
00394    TBL_REALLOC_CK(loc_name_tbl, 1);             /* add local name table entry */
00395 
00396    NTR_NAME_POOL((long *) TOKEN_STR(*token), TOKEN_LEN(*token), np_idx);
00397 
00398    /* reserve attribute table entry and fill in common definition fields */
00399 
00400    NTR_ATTR_TBL(attr_idx);
00401    AT_DEF_LINE(attr_idx)        = TOKEN_LINE(*token);
00402    AT_DEF_COLUMN(attr_idx)      = TOKEN_COLUMN(*token);
00403    AT_NAME_LEN(attr_idx)        = TOKEN_LEN(*token);
00404    AT_NAME_IDX(attr_idx)        = np_idx;
00405 
00406    if ((loc_name_tbl_idx - 1) != SCP_LN_LW_IDX(curr_scp_idx)) {
00407 
00408       /* Attempting to enter name into a scope that does not reside at the    */
00409       /* end of the local name table.  Make room for this entry in that scope */
00410       /* and then adjust the other scopes name table LW and FW values.        */
00411 
00412       for (scp_idx = 1; scp_idx <= scp_tbl_idx; scp_idx++) {
00413 
00414          if (SCP_LN_FW_IDX(scp_idx) > SCP_LN_LW_IDX(curr_scp_idx)) {
00415             SCP_LN_FW_IDX(scp_idx) = SCP_LN_FW_IDX(scp_idx) + 1;
00416             SCP_LN_LW_IDX(scp_idx) = SCP_LN_LW_IDX(scp_idx) + 1;
00417          }
00418       }
00419       SCP_LN_LW_IDX(curr_scp_idx)++;
00420    }
00421    else {
00422    
00423       /* Adding to local name table for last (most recent) scope.  No        */
00424       /* adjusting of other scope local name table entries is necessary.     */
00425 
00426       SCP_LN_LW_IDX(curr_scp_idx)       = loc_name_tbl_idx;
00427    }
00428 
00429    /* Enter name in correct position.  Link name pool and attribute table */
00430 
00431 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00432    name_tbl_base = (long *) loc_name_tbl;
00433 # endif
00434 
00435    for (i = loc_name_tbl_idx; i >= name_idx; i--) {
00436 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00437       name_tbl_base [i] = name_tbl_base [i-1];
00438 # else
00439       loc_name_tbl [i]  = loc_name_tbl [i-1];
00440 # endif
00441    }
00442 
00443    CLEAR_TBL_NTRY(loc_name_tbl, name_idx);
00444    LN_ATTR_IDX(name_idx)        = attr_idx;
00445    LN_NAME_IDX(name_idx)        = np_idx;
00446    LN_NAME_LEN(name_idx)        = TOKEN_LEN(*token);
00447 
00448    TRACE (Func_Exit, "ntr_sym_tbl", TOKEN_STR(*token));
00449 
00450    return (attr_idx);
00451 
00452 }  /* ntr_sym_tbl */
00453 
00454 /******************************************************************************\
00455 |*                                                                            *|
00456 |* Description:                                                               *|
00457 |*      srch_host_sym_tbl searches the name tables of all hosts for the       *|
00458 |*      identifier or label contained in the identifier field of token.       *|
00459 |*                                                                            *|
00460 |* Input parameters:                                                          *|
00461 |*      token                   token containing identifier or label to       *|
00462 |*                              search for and length in chars of name        *|
00463 |*                                                                            *|
00464 |* Output parameters:                                                         *|
00465 |*      name_idx                local name table index where match occured    *|
00466 |*                                                                            *|
00467 |* Returns:                                                                   *|
00468 |*      attribute table index   if found                                      *|
00469 |*      NULL_IDX                if not found                                  *|
00470 |*      -1                      if found but name not visible in this scope   *|
00471 |*                              due to multiple USE association               *|
00472 |*                                                                            *|
00473 |*                                                                            *|
00474 \******************************************************************************/
00475 
00476 int srch_host_sym_tbl (char     *name_str,
00477                        int       name_len,
00478                        int      *name_idx,
00479                        boolean   search_intrin_scp)
00480 
00481 {
00482 
00483    int           idx            = NULL_IDX;
00484    int           save_scp_idx;
00485    int           search_range;
00486    
00487    TRACE (Func_Entry, "srch_host_sym_tbl", NULL);
00488 
00489    /* DO NOT search the host when processing an interface block */
00490 
00491    save_scp_idx = curr_scp_idx;
00492 
00493    if (search_intrin_scp) { 
00494       search_range = 0;
00495    }
00496    else {
00497       search_range = 1;
00498    } 
00499 
00500    if (SCP_IS_INTERFACE(curr_scp_idx)) {
00501       curr_scp_idx = 1;  /* search intrinsics */
00502    }
00503 
00504    while (idx == NULL_IDX && curr_scp_idx != search_range) {
00505 
00506       /* Set current scope to parent, for searching. */
00507 
00508       curr_scp_idx = SCP_PARENT_IDX(curr_scp_idx);
00509       idx = srch_sym_tbl (name_str, name_len, name_idx);
00510    }
00511 
00512    curr_scp_idx = save_scp_idx;
00513 
00514    TRACE (Func_Exit, "srch_host_sym_tbl", NULL);
00515 
00516     return (idx);
00517 
00518 }  /* srch_host_sym_tbl */
00519 
00520 /******************************************************************************\
00521 |*                                                                            *|
00522 |* Description:                                                               *|
00523 |*      ntr_host_in_sym_tbl adds an existing name to the local scope.         *|
00524 |*      It makes a local name table entry, and links it to a new attr.        *|
00525 |*      The name must already be in the name pool.                            *|
00526 |*                                                                            *|
00527 |* Input parameters:                                                          *|
00528 |*      token                   token containing identifier or label and      *|
00529 |*                              length of name to be added to symbol table    *|
00530 |*                                                                            *|
00531 |*      name_idx                local name table index where entry is to      *|
00532 |*                              be inserted                                   *|
00533 |*                                                                            *|
00534 |*      host_attr_idx           Index to attr entry in the host.              *|
00535 |*                                                                            *|
00536 |*      host_ln_idx             Index to local name entry in the host.        *|
00537 |*                                                                            *|
00538 |*      make_new_attr_and_link  FALSE means link new local entry directly to  *|
00539 |*                              the new local name entry.  TRUE means make a  *|
00540 |*                              new entry and use AT_ATTR_LINK to connect     *|
00541 |*                              the old and new attr entries.  new -> old     *|
00542 |*                                                                            *|
00543 |* Output parameters:                                                         *|
00544 |*      NONE                                                                  *|
00545 |*                                                                            *|
00546 |* Returns:                                                                   *|
00547 |*      attribute table index of reserved entry                               *|
00548 |*                                                                            *|
00549 \******************************************************************************/
00550 
00551 int ntr_host_in_sym_tbl(token_type     *token,
00552                         int             name_idx,
00553                         int             host_attr_idx,
00554                         int             host_ln_idx,
00555                         boolean         make_new_attr_and_link)
00556 
00557 {
00558    register int          attr_idx;
00559    register int          i;
00560    register int          scp_idx;
00561 
00562 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00563    register long        *name_tbl_base; /* name table base address */
00564 # endif
00565 
00566 
00567    TRACE (Func_Entry, "ntr_host_in_sym_tbl", TOKEN_STR(*token));
00568 
00569 
00570    /* If we need a new attr - reserve it - and link them together. */
00571 
00572    if (make_new_attr_and_link) {
00573       NTR_ATTR_TBL(attr_idx);
00574       AT_DEF_LINE(attr_idx)     = TOKEN_LINE(*token);
00575       AT_DEF_COLUMN(attr_idx)   = TOKEN_COLUMN(*token);
00576       AT_NAME_LEN(attr_idx)     = AT_NAME_LEN(host_attr_idx);
00577       AT_NAME_IDX(attr_idx)     = AT_NAME_IDX(host_attr_idx);
00578       AT_ATTR_LINK(attr_idx)    = host_attr_idx;
00579    }
00580    else {
00581       attr_idx                  = host_attr_idx;
00582    }
00583 
00584    TBL_REALLOC_CK(loc_name_tbl, 1);             /* add local name table entry */
00585 
00586    if ((loc_name_tbl_idx - 1) != SCP_LN_LW_IDX(curr_scp_idx)) {
00587 
00588       /* Attempting to enter name into a scope that does not reside at the    */
00589       /* end of the local name table.  Make room for this entry in that scope */
00590       /* and then adjust the other scopes name table LW and FW values.        */
00591 
00592       for (scp_idx = 1; scp_idx <= scp_tbl_idx; scp_idx++) {
00593 
00594          if (SCP_LN_FW_IDX(scp_idx) > SCP_LN_LW_IDX(curr_scp_idx)) {
00595             SCP_LN_FW_IDX(scp_idx) = SCP_LN_FW_IDX(scp_idx) + 1;
00596             SCP_LN_LW_IDX(scp_idx) = SCP_LN_LW_IDX(scp_idx) + 1;
00597          }
00598       }
00599       SCP_LN_LW_IDX(curr_scp_idx)++;
00600    }
00601    else {
00602    
00603       /* Adding to local name table for last (most recent) scope.  No        */
00604       /* adjusting of other scope local name table entries is necessary.     */
00605 
00606       SCP_LN_LW_IDX(curr_scp_idx)       = loc_name_tbl_idx;
00607    }
00608 
00609    /* Enter name in correct position.  Link name pool and attribute table.  */
00610 
00611 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00612    name_tbl_base = (long *) loc_name_tbl;
00613 # endif
00614 
00615    for (i = loc_name_tbl_idx; i >= name_idx; i--) {
00616 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00617       name_tbl_base [i] = name_tbl_base [i-1];
00618 # else
00619       loc_name_tbl [i]  = loc_name_tbl [i-1];
00620 # endif
00621    }
00622 
00623    CLEAR_TBL_NTRY(loc_name_tbl, name_idx);
00624    LN_ATTR_IDX(name_idx)        = attr_idx;
00625    LN_NAME_IDX(name_idx)        = LN_NAME_IDX(host_ln_idx);
00626    LN_NAME_LEN(name_idx)        = LN_NAME_LEN(host_ln_idx);
00627 
00628    TRACE (Func_Exit, "ntr_host_in_sym_tbl", TOKEN_STR(*token));
00629 
00630    return (attr_idx);
00631 
00632 }  /* ntr_host_in_sym_tbl */
00633 
00634 /******************************************************************************\
00635 |*                                                                            *|
00636 |* Description:                                                               *|
00637 |*                                                                            *|
00638 |* Input parameters:                                                          *|
00639 |*      name_idx                local name table index to remove.             *|
00640 |*                                                                            *|
00641 |* Output parameters:                                                         *|
00642 |*      NONE                                                                  *|
00643 |*                                                                            *|
00644 |* Returns:                                                                   *|
00645 |*      NOTHING                                                               *|
00646 |*                                                                            *|
00647 \******************************************************************************/
00648 
00649 void remove_ln_ntry(int         name_idx)
00650 
00651 {
00652    register int          i;
00653 
00654 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00655    register long        *name_tbl_base; /* name table base address */
00656 # endif
00657 
00658 
00659    TRACE (Func_Entry, "remove_ln_ntry", NULL);
00660 
00661 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00662    name_tbl_base = (long *) loc_name_tbl;
00663 # endif
00664 
00665    /* Remove name */
00666 
00667    for (i = name_idx; i < SCP_LN_LW_IDX(curr_scp_idx); i++) {
00668 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64)
00669       name_tbl_base [i] = name_tbl_base [i+1];
00670 # else
00671       loc_name_tbl [i]  = loc_name_tbl [i+1];
00672 # endif
00673    }
00674 
00675    if (loc_name_tbl_idx == SCP_LN_LW_IDX(curr_scp_idx)) {
00676       loc_name_tbl_idx--;
00677    }
00678 
00679    SCP_LN_LW_IDX(curr_scp_idx)--;
00680 
00681    TRACE (Func_Exit, "remove_ln_ntry", NULL);
00682 
00683    return;
00684 
00685 }  /* remove_ln_ntry */
00686 
00687 /******************************************************************************\
00688 |*                                                                            *|
00689 |* Description:                                                               *|
00690 |*      srch_kwd_name searches the secondary name table entries for the darg  *|
00691 |*      names of an explicit interface.                                       *|
00692 |*                                                                            *|
00693 |*      THIS ROUTINE IS ONLY FOR USE WITH DUMMY ARGUMENT LISTS.               *|
00694 |*                                                                            *|
00695 |* Input parameters:                                                          *|
00696 |*      name                    Char pointer of name to look for.             *|
00697 |*      length                  Length of name to look for.                   *|
00698 |*      attr_idx                index of the proc with the dargs to search.   *|
00699 |*                                                                            *|
00700 |* Output parameters:                                                         *|
00701 |*      sn_idx                  secondary name table index if found           *|
00702 |*                                                                            *|
00703 |* Returns:                                                                   *|
00704 |*      attribute table index of member if found                              *|
00705 |*      NULL_IDX                        if not found                          *|
00706 |*                                                                            *|
00707 \******************************************************************************/
00708 int srch_kwd_name(char          *name,
00709                   int            length,
00710                   int            attr_idx,
00711                   int           *sn_idx)
00712 
00713 {
00714    register int          i;
00715    register int          id_char_len;   /* character length of identifier */
00716    register int          id_wd_len;     /* word length of identifier */
00717    register int          num_dargs;
00718    register int          np_idx;
00719    register long        *id;
00720    register long         tst_val;
00721    register long        *sn_tbl_base;
00722 
00723 
00724 
00725    TRACE (Func_Entry, "srch_kwd_name", name);
00726 
00727    if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
00728        num_dargs        = ATP_NUM_DARGS(attr_idx);
00729       *sn_idx           = ATP_FIRST_IDX(attr_idx);
00730    }
00731    else if (AT_OBJ_CLASS(attr_idx) == Stmt_Func) {
00732        num_dargs        = ATP_NUM_DARGS(attr_idx);
00733       *sn_idx           = ATP_FIRST_IDX(attr_idx);
00734    }
00735    else {
00736       PRINTMSG(stmt_start_line, 136, Internal, stmt_start_col, "srch_kwd_name");
00737    }
00738    
00739    id           = (long *) name;
00740    id_char_len  = length;
00741    id_wd_len    = WORD_LEN(id_char_len);      
00742 
00743    /* don't forward sub else no vector */
00744 
00745    tst_val      = -1;
00746    sn_tbl_base  = (long *) sec_name_tbl;
00747 
00748 # if defined(_HOST_LITTLE_ENDIAN)
00749 
00750    for (i = 0; i < num_dargs; i++) {
00751       np_idx = SN_NP_IDX(*sn_idx + i);  
00752 
00753       if (SN_LEN(*sn_idx + i) == id_char_len) {
00754          tst_val = compare_names(&id[0],
00755                                  id_wd_len*HOST_BYTES_PER_WORD-1,
00756                                  &name_pool[np_idx].name_long,
00757                                  id_wd_len*HOST_BYTES_PER_WORD-1);
00758          if (tst_val == 0) {
00759             break;
00760          }
00761       }
00762    }
00763 
00764 # else
00765 
00766    switch (id_wd_len) {
00767       case 1:
00768          for (i = 0; i < num_dargs; i++) {
00769             np_idx = SN_NP_IDX(*sn_idx + i);  
00770 
00771 # if 0  /* JBL,BHJ - These are not vectorizing. Doing this makes it vectorize */
00772 
00773                tst_val = id[0] - name_pool[np_idx].name_long;
00774                if (tst_val == 0 && SN_LEN(*sn_idx + i) == id_char_len) {
00775                   break;
00776                } 
00777 # endif
00778             if (SN_LEN(*sn_idx + i) == id_char_len) {
00779                tst_val = id[0] - name_pool[np_idx].name_long;
00780 
00781                if (tst_val == 0) {
00782                   break;
00783                } 
00784             }
00785          }
00786          break;
00787 
00788       case 2:
00789 
00790          for (i = 0; i < num_dargs; i++) {
00791             np_idx = SN_NP_IDX(*sn_idx + i);  
00792 
00793             if (SN_LEN(*sn_idx + i) == id_char_len) {
00794                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00795                          (id[1] - name_pool[np_idx + 1].name_long);
00796 
00797                if (tst_val == 0) {
00798                   break;
00799                }
00800             }
00801          }
00802          break;
00803 
00804       case 3:
00805 
00806          for (i = 0; i < num_dargs; i++) {
00807             np_idx = SN_NP_IDX(*sn_idx + i);  
00808 
00809             if (SN_LEN(*sn_idx + i) == id_char_len) {
00810                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00811                          (id[1] - name_pool[np_idx + 1].name_long) |
00812                          (id[2] - name_pool[np_idx + 2].name_long);
00813 
00814                if (tst_val == 0) {
00815                   break;
00816                }
00817             }
00818          }
00819          break;
00820 
00821       case 4: 
00822          for (i = 0; i < num_dargs; i++) {
00823             np_idx = SN_NP_IDX(*sn_idx + i);  
00824             if (SN_LEN(*sn_idx + i) == id_char_len) {
00825                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00826                          (id[1] - name_pool[np_idx + 1].name_long) |
00827                          (id[2] - name_pool[np_idx + 2].name_long) |
00828                          (id[3] - name_pool[np_idx + 3].name_long);
00829                if (tst_val == 0) {
00830                   break;
00831                }
00832             }
00833          }
00834          break;
00835 
00836 # ifdef _HOST32
00837       case 5:
00838          for (i = 0; i < num_dargs; i++) {
00839             np_idx = SN_NP_IDX(*sn_idx + i);  
00840             if (SN_LEN(*sn_idx + i) == id_char_len) {
00841                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00842                          (id[1] - name_pool[np_idx + 1].name_long) |
00843                          (id[2] - name_pool[np_idx + 2].name_long) |
00844                          (id[3] - name_pool[np_idx + 3].name_long) |
00845                          (id[4] - name_pool[np_idx + 4].name_long);
00846                if (tst_val == 0) {
00847                   break;
00848                }
00849             }
00850          }
00851          break;
00852 
00853       case 6:
00854          for (i = 0; i < num_dargs; i++) {
00855             np_idx = SN_NP_IDX(*sn_idx + i);  
00856             if (SN_LEN(*sn_idx + i) == id_char_len) {
00857                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00858                          (id[1] - name_pool[np_idx + 1].name_long) |
00859                          (id[2] - name_pool[np_idx + 2].name_long) |
00860                          (id[3] - name_pool[np_idx + 3].name_long) |
00861                          (id[4] - name_pool[np_idx + 4].name_long) |
00862                          (id[5] - name_pool[np_idx + 5].name_long);
00863                if (tst_val == 0) {
00864                   break;
00865                }
00866             }
00867          }
00868          break;
00869 
00870       case 7:
00871          for (i = 0; i < num_dargs; i++) {
00872             np_idx = SN_NP_IDX(*sn_idx + i);  
00873             if (SN_LEN(*sn_idx + i) == id_char_len) {
00874                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00875                          (id[1] - name_pool[np_idx + 1].name_long) |
00876                          (id[2] - name_pool[np_idx + 2].name_long) |
00877                          (id[3] - name_pool[np_idx + 3].name_long) |
00878                          (id[4] - name_pool[np_idx + 4].name_long) |
00879                          (id[5] - name_pool[np_idx + 5].name_long) |
00880                          (id[6] - name_pool[np_idx + 6].name_long);
00881                if (tst_val == 0) {
00882                   break;
00883                }
00884             }
00885          }
00886          break;
00887 
00888       case 8:
00889          for (i = 0; i < num_dargs; i++) {
00890             np_idx = SN_NP_IDX(*sn_idx + i);  
00891             if (SN_LEN(*sn_idx + i) == id_char_len) {
00892                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
00893                          (id[1] - name_pool[np_idx + 1].name_long) |
00894                          (id[2] - name_pool[np_idx + 2].name_long) |
00895                          (id[3] - name_pool[np_idx + 3].name_long) |
00896                          (id[4] - name_pool[np_idx + 4].name_long) |
00897                          (id[5] - name_pool[np_idx + 5].name_long) |
00898                          (id[6] - name_pool[np_idx + 6].name_long) |
00899                          (id[7] - name_pool[np_idx + 7].name_long);
00900                if (tst_val == 0) {
00901                   break;
00902                }
00903             }
00904          }
00905          break;
00906 
00907 # endif
00908 
00909       default:
00910          PRINTMSG(stmt_start_line, 196, Internal, stmt_start_col, 
00911                   "srch_kwd_name",
00912                   NUM_ID_WDS * TARGET_CHARS_PER_WORD);
00913          break;
00914    }  /* switch (id_wd_len) */
00915 
00916 # endif
00917 
00918    if (tst_val == 0) {
00919       TRACE (Func_Exit, "srch_kwd_name", name);
00920       *sn_idx = *sn_idx + i;
00921       i       = SN_ATTR_IDX(*sn_idx);
00922    }
00923    else {
00924       TRACE (Func_Exit, "srch_kwd_name", NULL);
00925       i = NULL_IDX;
00926    }
00927 
00928    return (i); 
00929 
00930 }  /*  srch_kwd_name  */
00931 
00932 /******************************************************************************\
00933 |*                                                                            *|
00934 |* Description:                                                               *|
00935 |*      srch_stor_blk_tbl searches the local common/module table entries      *|
00936 |*      for an entry of the same name.                                        *|
00937 |*                                                                            *|
00938 |* Input parameters:                                                          *|
00939 |*      token                   token containing common or module name        *|
00940 |*                              and length of name                            *|
00941 |*                                                                            *|
00942 |* Output parameters:                                                         *|
00943 |*      NONE                                                                  *|
00944 |*                                                                            *|
00945 |* Returns:                                                                   *|
00946 |*      common/module table index   if found                                  *|
00947 |*      NULL_IDX                    if not found                              *|
00948 |*                                                                            *|
00949 \******************************************************************************/
00950 int srch_stor_blk_tbl (char             *name_str,
00951                        int               name_len,
00952                        int               scp_idx)
00953 
00954 {
00955    register int          i;
00956    register long        *id;
00957    register int          id_char_len;   /* character length of identifier */
00958    register int          id_wd_len;     /* word length of identifier */
00959    register int          j;
00960    register int          np_idx;
00961    register long         tst_val;
00962 
00963 
00964    TRACE (Func_Entry, "srch_stor_blk_tbl", name_str);
00965 
00966    id          = (long *) name_str;
00967    id_char_len = name_len;
00968    id_wd_len   = WORD_LEN(id_char_len);      
00969    tst_val     = -1;
00970 
00971 # if defined(_HOST_LITTLE_ENDIAN)
00972 
00973    for (i = 1; i <= stor_blk_tbl_idx; i++) {
00974       np_idx = SB_NAME_IDX(i);  
00975 
00976       if (SB_NAME_LEN(i) == id_char_len &&
00977           SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
00978 
00979          tst_val = compare_names(&id[0],
00980                                  id_wd_len*HOST_BYTES_PER_WORD-1,
00981                                  &name_pool[np_idx].name_long,
00982                                  id_wd_len*HOST_BYTES_PER_WORD-1);
00983 
00984          if (tst_val == 0) {
00985             break;
00986          }
00987       }
00988    }
00989 # else
00990 
00991    switch (id_wd_len) {
00992       case 1:
00993          for (i = 1; i <= stor_blk_tbl_idx; i++) {
00994             np_idx = SB_NAME_IDX(i);  
00995 
00996             if (SB_NAME_LEN(i) == id_char_len &&
00997                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
00998 
00999                tst_val = id[0] - name_pool[np_idx].name_long;
01000 
01001                if (tst_val == 0) {
01002                   break;
01003                }
01004             }
01005          }
01006          break;
01007 
01008       case 2:
01009          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01010             np_idx = SB_NAME_IDX(i);  
01011 
01012             if (SB_NAME_LEN(i) == id_char_len &&
01013                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01014 
01015                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01016                          (id[1] - name_pool[np_idx + 1].name_long);
01017 
01018                if (tst_val == 0) {
01019                   break;
01020                }
01021             }
01022          }
01023          break;
01024 
01025       case 3:
01026          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01027             np_idx = SB_NAME_IDX(i);  
01028 
01029             if (SB_NAME_LEN(i) == id_char_len &&
01030                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01031 
01032                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01033                          (id[1] - name_pool[np_idx + 1].name_long) |
01034                          (id[2] - name_pool[np_idx + 2].name_long);
01035 
01036                if (tst_val == 0) {
01037                   break;
01038                }
01039             }
01040          }
01041          break;
01042 
01043       case 4: 
01044          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01045             np_idx = SB_NAME_IDX(i);  
01046 
01047             if (SB_NAME_LEN(i) == id_char_len &&
01048                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01049 
01050                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01051                          (id[1] - name_pool[np_idx + 1].name_long) |
01052                          (id[2] - name_pool[np_idx + 2].name_long) |
01053                          (id[3] - name_pool[np_idx + 3].name_long);
01054 
01055                if (tst_val == 0) {
01056                   break;
01057                }
01058             }
01059          }
01060          break;
01061 
01062 # ifdef _HOST32
01063       case 5:
01064          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01065             np_idx = SB_NAME_IDX(i);
01066 
01067             if (SB_NAME_LEN(i) == id_char_len &&
01068                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01069 
01070                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01071                          (id[1] - name_pool[np_idx + 1].name_long) |
01072                          (id[2] - name_pool[np_idx + 2].name_long) |
01073                          (id[3] - name_pool[np_idx + 3].name_long) |
01074                          (id[4] - name_pool[np_idx + 4].name_long);
01075 
01076                if (tst_val == 0) {
01077                   break;
01078                }
01079             }
01080          }
01081          break;
01082       case 6:
01083          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01084             np_idx = SB_NAME_IDX(i);
01085 
01086             if (SB_NAME_LEN(i) == id_char_len &&
01087                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01088 
01089                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01090                          (id[1] - name_pool[np_idx + 1].name_long) |
01091                          (id[2] - name_pool[np_idx + 2].name_long) |
01092                          (id[3] - name_pool[np_idx + 3].name_long) |
01093                          (id[4] - name_pool[np_idx + 4].name_long) |
01094                          (id[5] - name_pool[np_idx + 5].name_long);
01095 
01096                if (tst_val == 0) {
01097                   break;
01098                }
01099             }
01100          }
01101          break;
01102       case 7:
01103          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01104             np_idx = SB_NAME_IDX(i);
01105 
01106             if (SB_NAME_LEN(i) == id_char_len &&
01107                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01108 
01109                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01110                          (id[1] - name_pool[np_idx + 1].name_long) |
01111                          (id[2] - name_pool[np_idx + 2].name_long) |
01112                          (id[3] - name_pool[np_idx + 3].name_long) |
01113                          (id[4] - name_pool[np_idx + 4].name_long) |
01114                          (id[5] - name_pool[np_idx + 5].name_long) |
01115                          (id[6] - name_pool[np_idx + 6].name_long);
01116 
01117                if (tst_val == 0) {
01118                   break;
01119                }
01120             }
01121          }
01122          break;
01123       case 8:
01124          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01125             np_idx = SB_NAME_IDX(i);
01126 
01127             if (SB_NAME_LEN(i) == id_char_len &&
01128                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01129 
01130                tst_val = (id[0] - name_pool[np_idx    ].name_long) |
01131                          (id[1] - name_pool[np_idx + 1].name_long) |
01132                          (id[2] - name_pool[np_idx + 2].name_long) |
01133                          (id[3] - name_pool[np_idx + 3].name_long) |
01134                          (id[4] - name_pool[np_idx + 4].name_long) |
01135                          (id[5] - name_pool[np_idx + 5].name_long) |
01136                          (id[6] - name_pool[np_idx + 6].name_long) |
01137                          (id[7] - name_pool[np_idx + 7].name_long);
01138 
01139                if (tst_val == 0) {
01140                   break;
01141                }
01142             }
01143          }
01144          break;
01145 # endif
01146 
01147       default:
01148 
01149          for (i = 1; i <= stor_blk_tbl_idx; i++) {
01150             np_idx = SB_NAME_IDX(i);  
01151 
01152             if (SB_NAME_LEN(i) == id_char_len &&
01153                 SB_SCP_IDX(i) == scp_idx && !SB_HIDDEN(i)) {
01154                tst_val = 0;
01155 
01156                for (j = 0; j < id_wd_len; j++) {
01157                   tst_val = tst_val | (id[j] - name_pool[np_idx+j].name_long);
01158                }
01159 
01160                if (tst_val == 0) {
01161                   break;
01162                }
01163             }
01164          }
01165          break;
01166    }  /* switch (id_wd_len) */
01167 
01168 # endif
01169 
01170    if (tst_val != 0) {
01171       i = NULL_IDX;
01172    }
01173 
01174    TRACE (Func_Exit, "srch_stor_blk_tbl", NULL);
01175 
01176    return (i); 
01177 
01178 }  /* srch_stor_blk_tbl */
01179 
01180 /******************************************************************************\
01181 |*                                                                            *|
01182 |* Description:                                                               *|
01183 |*      ntr_stor_blk_tbl makes a storage block table entry and name pool      *|
01184 |*      entry, filling in the name index and name length fields of the        *|
01185 |*      storage block table entry.                                            *|
01186 |*                                                                            *|
01187 |* Input parameters:                                                          *|
01188 |*      storage block name                                                    *|
01189 |*      length of name                                                        *|
01190 |*      defining line of storage block name                                   *|
01191 |*      defining column of storage block name                                 *|
01192 |*      type of block for SB_BLK_TYPE                                         *|
01193 |*                                                                            *|
01194 |* Output parameters:                                                         *|
01195 |*      NONE                                                                  *|
01196 |*                                                                            *|
01197 |* Returns:                                                                   *|
01198 |*      common/module table index where entry is made                         *|
01199 |*                                                                            *|
01200 \******************************************************************************/
01201 
01202 int ntr_stor_blk_tbl (char *name_str,
01203                       int   name_len,
01204                       int   def_line,
01205                       int   def_column,
01206                       int   blk_type)
01207  
01208 {
01209    register int          np_idx;  
01210 
01211 
01212    TRACE (Func_Entry, "ntr_stor_blk_tbl", name_str);
01213 
01214    NTR_NAME_POOL((long *) name_str, name_len, np_idx);
01215 
01216    TBL_REALLOC_CK(stor_blk_tbl, 1);
01217 
01218    CLEAR_TBL_NTRY(stor_blk_tbl, stor_blk_tbl_idx);
01219 
01220    SB_NAME_LEN(stor_blk_tbl_idx)        = name_len;
01221    SB_NAME_IDX(stor_blk_tbl_idx)        = np_idx;
01222    SB_DEF_LINE(stor_blk_tbl_idx)        = def_line;
01223    SB_DEF_COLUMN(stor_blk_tbl_idx)      = def_column;
01224    SB_SCP_IDX(stor_blk_tbl_idx)         = curr_scp_idx;
01225    SB_ORIG_SCP_IDX(stor_blk_tbl_idx)    = curr_scp_idx;
01226    SB_LEN_IDX(stor_blk_tbl_idx)         = CN_INTEGER_ZERO_IDX;
01227    SB_LEN_FLD(stor_blk_tbl_idx)         = CN_Tbl_Idx;
01228    SB_BLK_TYPE(stor_blk_tbl_idx)        = (sb_type_type) blk_type;
01229 
01230    switch (blk_type) {
01231       case Common:
01232       case Task_Common:
01233       case Threadprivate:
01234          SB_IS_COMMON(stor_blk_tbl_idx)         = TRUE;
01235          SB_RUNTIME_INIT(stor_blk_tbl_idx)      = FALSE;
01236          break;
01237 
01238       case Coment:
01239       case Static:
01240       case Static_Named:
01241       case Static_Local:
01242          SB_RUNTIME_INIT(stor_blk_tbl_idx)      = FALSE;
01243          break;
01244 
01245       case Stack:
01246       case Formal:
01247       case Based:
01248       case Equivalenced:
01249       case Non_Local_Stack:
01250       case Non_Local_Formal:
01251       case Hosted_Stack:
01252       case Auxiliary:
01253          SB_RUNTIME_INIT(stor_blk_tbl_idx)      = TRUE;
01254          break;
01255 
01256 # if defined(_DEBUG)
01257       case Unknown_Seg:
01258       case Extern:
01259       case Exported:
01260       case Soft_External:
01261       case Global_Breg:
01262       case Global_Treg:
01263       case Restricted:
01264       case Distributed:
01265       case LM_Static:
01266       case LM_Common:
01267       case LM_Extern:
01268 
01269          /* Intentional fall through */
01270 
01271       default:
01272          PRINTMSG(def_line, 1592, Internal, def_column);
01273          break;
01274 # endif
01275    }  /* End switch */
01276 
01277    TRACE (Func_Exit, "ntr_stor_blk_tbl", NULL);
01278 
01279    return (stor_blk_tbl_idx); 
01280 
01281 }  /* ntr_stor_blk_tbl */
01282 
01283 /******************************************************************************\
01284 |*                                                                            *|
01285 |* Description:                                                               *|
01286 |*      ntr_array_in_bd_tbl makes an array table entry.   It is copied from   *|
01287 |*      the array table work area.  (Entries 0-7 of array table)              *|
01288 |*                                                                            *|
01289 |* Input parameters:                                                          *|
01290 |*      NONE                                                                  *|
01291 |*                                                                            *|
01292 |* Output parameters:                                                         *|
01293 |*      NONE                                                                  *|
01294 |*                                                                            *|
01295 |* Returns:                                                                   *|
01296 |*      array_idx       Index to start of new array entry.                    *|
01297 |*                                                                            *|
01298 \******************************************************************************/
01299 
01300 int ntr_array_in_bd_tbl(int     bd_idx)
01301  
01302 {
01303    int  free_idx;
01304    int  free_size;
01305    int  size;
01306 
01307 
01308    TRACE (Func_Entry, "ntr_array_in_bd_tbl", NULL);
01309 
01310    /* NOTE:  Deferred shape arrays share entries.  Also, array definitions  */
01311    /*        that are in the same statement can share bounds.  For example: */
01312    /*             INTEGER, DIMENSION(100) : A,B,C                           */
01313    /*        If there is nothing that changes these declarations, the same  */
01314    /*        bounds table entry will be used for A, B and C.                */
01315 
01316    if (BD_ARRAY_CLASS(bd_idx) == Deferred_Shape && FALSE ) {
01317 
01318       if (!BD_DCL_ERR(bd_idx)) {
01319          BD_LINE_NUM(BD_RANK(bd_idx))   = BD_LINE_NUM(bd_idx);
01320          BD_COLUMN_NUM(BD_RANK(bd_idx)) = BD_COLUMN_NUM(bd_idx);
01321          free_idx                       = bd_idx;
01322          free_size                      = BD_NTRY_SIZE(bd_idx);
01323          bd_idx                         = BD_RANK(bd_idx);
01324       }
01325       else {
01326          free_size                      = BD_NTRY_SIZE(bd_idx) - 1;
01327          free_idx                       = bd_idx + 1;
01328          BD_USED_NTRY(bd_idx)           = TRUE;
01329          BD_NTRY_SIZE(bd_idx)           = 1;
01330       }
01331    }
01332    else {
01333       size                              = BD_RANK(bd_idx) + 1;  
01334       free_size                         = BD_NTRY_SIZE(bd_idx) - size;
01335       free_idx                          = bd_idx + size;
01336       BD_USED_NTRY(bd_idx)              = TRUE;
01337       BD_NTRY_SIZE(bd_idx)              = size;
01338    }
01339 
01340    if (free_size > 0) {
01341 
01342       if ((free_idx + free_size - 1) == bounds_tbl_idx) {
01343          bounds_tbl_idx -= free_size;
01344       }
01345       else {
01346          BD_NEXT_FREE_NTRY(free_idx) = BD_NEXT_FREE_NTRY(BD_FREE_LIST_IDX);
01347          BD_NEXT_FREE_NTRY(BD_FREE_LIST_IDX)    = free_idx;
01348          BD_NTRY_SIZE(free_idx)                 = free_size;
01349          BD_USED_NTRY(free_idx)                 = FALSE;
01350       }
01351    }
01352   
01353 
01354    TRACE (Func_Exit, "ntr_array_in_bd_tbl", NULL);
01355 
01356    return(bd_idx);
01357 
01358 }  /* ntr_array_in_bd_tbl */
01359 
01360 /******************************************************************************\
01361 |*                                                                            *|
01362 |* Description:                                                               *|
01363 |*      reserve_array_ntry finds an unused entry in the bounds table to hold  *|
01364 |*              an array of the specified rank.                               *|
01365 |*                                                                            *|
01366 |* Input parameters:                                                          *|
01367 |*      size     -> Rank of array.                                            *|
01368 |*      deferred -> True if this is definitely a deferred shape array.        *|
01369 |*                                                                            *|
01370 |* Output parameters:                                                         *|
01371 |*      NONE                                                                  *|
01372 |*                                                                            *|
01373 |* Returns:                                                                   *|
01374 |*      bd_idx  -> Index to start of new array entry.                         *|
01375 |*                                                                            *|
01376 \******************************************************************************/
01377 
01378 int reserve_array_ntry (int     rank)
01379  
01380 {
01381    int           bd_idx;
01382    int           i;
01383    int           size;
01384    long         *tbl_idx;
01385 
01386 
01387    TRACE (Func_Entry, "reserve_array_ntry", NULL);
01388 
01389    size         = ++rank;
01390    bd_idx       = BD_NEXT_FREE_NTRY(BD_FREE_LIST_IDX);
01391 
01392    while (bd_idx != NULL_IDX && size > BD_NTRY_SIZE(bd_idx)) {
01393       bd_idx    = BD_NEXT_FREE_NTRY(bd_idx);
01394    }
01395 
01396    if (bd_idx == NULL_IDX) {
01397       bd_idx = bounds_tbl_idx + 1;
01398       TBL_REALLOC_CK(bounds_tbl, size);     /* Get space for whole thing */
01399    }
01400    else if (BD_NTRY_SIZE(bd_idx) > size) {
01401       BD_NTRY_SIZE(bd_idx)      = BD_NTRY_SIZE(bd_idx) - size;
01402       bd_idx                    = size + bd_idx;
01403    }
01404    else {
01405       BD_NEXT_FREE_NTRY(BD_FREE_LIST_IDX) = BD_NEXT_FREE_NTRY(bd_idx);
01406    }
01407 
01408    tbl_idx = ((long *) (&bounds_tbl[bd_idx]));
01409 
01410    for (i = 0; i < NUM_BD_WDS * size; i++) {
01411       *(tbl_idx) = 0;
01412       tbl_idx++;
01413    }
01414 
01415    BD_NTRY_SIZE(bd_idx) = size;
01416    BD_USED_NTRY(bd_idx) = TRUE;
01417 
01418    TRACE (Func_Exit, "reserve_array_ntry", NULL);
01419 
01420    return(bd_idx);
01421 
01422 }  /* reserve_array_ntry */
01423 
01424 
01425 /******************************************************************************\
01426 |*                                                                            *|
01427 |* Description:                                                               *|
01428 |*      Initialize symbol table.  Called once per compilation.                *|
01429 |*                                                                            *|
01430 |* Input parameters:                                                          *|
01431 |*      NONE                                                                  *|
01432 |*                                                                            *|
01433 |* Output parameters:                                                         *|
01434 |*      NONE                                                                  *|
01435 |*                                                                            *|
01436 |* Returns:                                                                   *|
01437 |*      NOTHING                                                               *|
01438 |*                                                                            *|
01439 \******************************************************************************/
01440 
01441 void    init_sytb()
01442 
01443 {
01444 
01445    TRACE (Func_Entry, "init_sytb", NULL);
01446 
01447 /*    Check to make sure that the following table definitions are correct */
01448 
01449 # ifdef _DEBUG
01450    if (sizeof(attr_list_tbl_type) != (NUM_AL_WDS * HOST_BYTES_PER_WORD)) {
01451       PRINTMSG(1, 138, Internal, 0, "Attribute list table");
01452    }
01453 
01454    if (sizeof(attr_tbl_type) != (NUM_AT_WDS * HOST_BYTES_PER_WORD)) {
01455       PRINTMSG(1, 138, Internal, 0, "Attribute table");
01456    }
01457 
01458    if (sizeof(bounds_tbl_type) != (NUM_BD_WDS * HOST_BYTES_PER_WORD)) {
01459       PRINTMSG(1, 138, Internal, 0, "Bounds table");
01460    }
01461 
01462    if (sizeof(file_path_tbl_type) != (NUM_FP_WDS * HOST_BYTES_PER_WORD)) {
01463       PRINTMSG(1, 138, Internal, 0, "File path table");
01464    }
01465 
01466    if (sizeof(loc_name_tbl_type) != (NUM_LN_WDS * HOST_BYTES_PER_WORD)) {
01467       PRINTMSG(1, 138, Internal, 0, "Local name table");
01468    }
01469 
01470    if (sizeof(mod_link_tbl_type) != (NUM_ML_WDS * HOST_BYTES_PER_WORD)) {
01471       PRINTMSG(1, 138, Internal, 0, "Module link table");
01472    }
01473 
01474 # if 0
01475    if (sizeof(mod_tbl_type) != (NUM_MD_WDS * HOST_BYTES_PER_WORD)) {
01476       PRINTMSG(1, 138, Internal, 0, "Module table");
01477    }
01478 # endif
01479 
01480    if (sizeof(scp_tbl_type) != (NUM_SCP_WDS * HOST_BYTES_PER_WORD)) {
01481       PRINTMSG(1, 138, Internal, 0, "Scope table");
01482    }
01483 
01484    if (sizeof(pdg_link_tbl_type) != (NUM_PDG_WDS * HOST_BYTES_PER_WORD)) {
01485       PRINTMSG(1, 138, Internal, 0, "Pdg link table");
01486    }
01487 
01488    if (sizeof(stor_blk_tbl_type) != (NUM_SB_WDS * HOST_BYTES_PER_WORD)) {
01489       PRINTMSG(1, 138, Internal, 0, "Storage block table");
01490    }
01491 
01492    if (sizeof(sec_name_tbl_type) != (NUM_SN_WDS * HOST_BYTES_PER_WORD)) {
01493       PRINTMSG(1, 138, Internal, 0, "Secondary name table");
01494    }
01495 
01496    if (sizeof(ir_tbl_type) != (NUM_IR_WDS * HOST_BYTES_PER_WORD)) {
01497       PRINTMSG(1, 138, Internal, 0, "IR table");
01498    }
01499 
01500    if (sizeof(ir_list_tbl_type) != (NUM_IL_WDS * HOST_BYTES_PER_WORD)) {
01501       PRINTMSG(1, 138, Internal, 0, "IR list table");
01502    }
01503 
01504    if (sizeof(sh_tbl_type) != (NUM_SH_WDS * HOST_BYTES_PER_WORD)) {
01505       PRINTMSG(1, 138, Internal, 0, "statement header table");
01506    }
01507 
01508    if (sizeof(rename_only_tbl_type) != (NUM_RO_WDS * HOST_BYTES_PER_WORD)) {
01509       PRINTMSG(1, 138, Internal, 0, "rename only table");
01510    }
01511 
01512    if (sizeof(type_tbl_type) != (NUM_TYP_WDS * HOST_BYTES_PER_WORD)) {
01513       PRINTMSG(1, 138, Internal, 0, "type table");
01514    }
01515 
01516    if (sizeof(global_line_tbl_type) != (NUM_GL_WDS * HOST_BYTES_PER_WORD)) {
01517       PRINTMSG(1, 138, Internal, 0, "global line table");
01518    }
01519 
01520    if (sizeof(global_name_tbl_type) != (NUM_GN_WDS * HOST_BYTES_PER_WORD)) {
01521       PRINTMSG(1, 138, Internal, 0, "global name table");
01522    }
01523 # endif
01524 
01525    /* Create this token.  It's used in case of error in the program, module   */
01526    /* blockdata, function, or subroutine statement.  At the beginning of the  */
01527    /* parser, $MAIN is put into the name pool, but not into the local name tbl*/
01528    /* It only gets entered into the local name table if it's needed because   */
01529    /* of a missing program statement.  This is done in the parse driver.      */
01530 
01531    CREATE_ID(TOKEN_ID(main_token), 
01532              UNNAMED_PROGRAM_NAME, 
01533              UNNAMED_PROGRAM_NAME_LEN);
01534 
01535    TOKEN_LEN(main_token)                = UNNAMED_PROGRAM_NAME_LEN;
01536    TOKEN_LINE(main_token)               = 1;
01537    TOKEN_COLUMN(main_token)             = 1;
01538    TOKEN_VALUE(main_token)              = Tok_Id;
01539    TOKEN_KIND_STR(main_token)[0]        = EOS;
01540    TOKEN_KIND_LEN(main_token)           = 0;
01541 
01542    /* Initialize here for debug variant checking */
01543 
01544    stmt_start_line      = 1;
01545    stmt_start_col       = 1;
01546 
01547    TRACE (Func_Exit, "init_sytb", NULL);
01548 
01549    return;
01550 
01551 }  /* init_sytb */
01552 
01553 
01554 /******************************************************************************\
01555 |*                                                                            *|
01556 |* Description:                                                               *|
01557 |*      ntr_const_tbl add non-character constants to the constant table.  It  *|
01558 |*      searches for a match and returns the matching index if found.  If not *|
01559 |*      found it adds the constant and returns the new index.                 *|
01560 |*                                                                            *|
01561 |* Input parameters:                                                          *|
01562 |*      type_idx        data type.                                            *|
01563 |*      extra_zero_word add an extra word to constant and set flag.           *|
01564 |*      constant        The address of the constant to be entered.            *|
01565 |*                                                                            *|
01566 |* Output parameters:                                                         *|
01567 |*      NONE                                                                  *|
01568 |*                                                                            *|
01569 |* Returns:                                                                   *|
01570 |*      constant table index of entry                                         *|
01571 |*                                                                            *|
01572 \******************************************************************************/
01573 
01574 int ntr_const_tbl (int           type_idx,
01575                    boolean       extra_zero_word,
01576                    long_type    *constant)
01577 
01578 {
01579    register     int                     const_idx;
01580                 long64                  const_word_len;
01581    register     int                     i;
01582                 long64                  input_word_len;
01583                 size_offset_type        length;
01584    register     int                     pool_idx;
01585                 int                     num_long_types;
01586 
01587 
01588 /* NOTE:  Although it is impossible to have a native compiler under the MPP   */
01589 /*        MAX operating system, we use the perhaps unfortunate name           */
01590 /*        _HOST_OS_MAX also on UNICOS/mk MPP systems to indicate the host is  */
01591 /*        an MPP.                                                             */
01592 
01593 #if (defined(_HOST_OS_UNICOS)   &&  defined(_TARGET_OS_UNICOS))   ||           \
01594     (defined(_HOST_OS_MAX)      &&  defined(_TARGET_OS_MAX))      ||           \
01595     (defined(_HOST_OS_SOLARIS)  &&  defined(_TARGET_OS_SOLARIS))  ||           \
01596     ((defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))      &&  (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)))
01597 
01598    /* ASSUMPTION:  long and float occupy the same number of bits on PVP and   */
01599    /*              Solaris machines.                                          */
01600    /*              long and double occupy the same number of bits (64) on     */
01601    /*              MPPs.                                                      */
01602 
01603    union  integer_and_real      { long          integer_form;
01604 
01605 #ifdef _TARGET_OS_MAX
01606                                   double        real_form;
01607 #else
01608                                   float         real_form;
01609 #endif
01610                         };
01611 
01612    union  integer_and_real  value;   /* BRIANJ - never used */
01613    union  integer_and_real  high_cn;   /* BRIANJ - never used */
01614    union  integer_and_real  low_cn;   /* BRIANJ - never used */
01615    union  integer_and_real  mid_cn;  /* BRIANJ - never used */
01616 
01617 #endif
01618 
01619 
01620    TRACE (Func_Entry, "ntr_const_tbl", NULL);
01621 
01622    switch(TYP_TYPE(type_idx)) {
01623 
01624    case Typeless:
01625 
01626       input_word_len = STORAGE_WORD_SIZE(TYP_BIT_LEN(type_idx));
01627 
01628       if (extra_zero_word || (input_word_len == 0)) {
01629          const_word_len         = input_word_len + 1;
01630          extra_zero_word        = TRUE;
01631       }
01632       else {
01633          const_word_len         = input_word_len;
01634       }
01635       break;
01636 
01637 
01638    case Character:
01639 
01640       input_word_len = TARGET_BYTES_TO_WORDS(((long)
01641                                CN_INT_TO_C(TYP_IDX(type_idx))));
01642 
01643       if (extra_zero_word || (input_word_len == 0)) {
01644          const_word_len         = input_word_len + 1;
01645          extra_zero_word        = TRUE;
01646       }
01647       else {
01648          const_word_len         = input_word_len;
01649       }
01650       break;
01651 
01652 
01653    case Integer: 
01654    case Real:
01655    case Logical:
01656 
01657       const_word_len =
01658          TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
01659       input_word_len = const_word_len;
01660       break;
01661 
01662 
01663    case Complex:
01664 
01665       const_word_len =
01666          TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
01667 
01668 # if defined(_TARGET_OS_MAX) || defined(_WHIRL_HOST64_TARGET64)
01669 
01670       if (TYP_LINEAR(type_idx) == Complex_4) {
01671          const_word_len = 2;
01672       }
01673 
01674 # endif
01675 
01676       input_word_len = const_word_len;
01677       break;
01678 
01679 
01680    /* Issue error - constant too big??? */
01681 
01682    case Structure:
01683 
01684       length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));;
01685       length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));;
01686 
01687       BITS_TO_WORDS(length, TARGET_BITS_PER_WORD);
01688 
01689       /* Potential range problem here */
01690 
01691       const_word_len = F_INT_TO_C(length.constant, TYP_LINEAR(length.type_idx));
01692 
01693       if (length.fld == CN_Tbl_Idx) {
01694          const_word_len = CN_INT_TO_C(length.idx);
01695 
01696          if (const_word_len == 0) {
01697             const_word_len      = 1;
01698             extra_zero_word     = TRUE;
01699          }
01700       }
01701       else {
01702          PRINTMSG(AT_DEF_LINE(TYP_IDX(type_idx)), 1201, Internal,
01703                   AT_DEF_COLUMN(TYP_IDX(type_idx)),
01704                   AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
01705       }
01706 
01707       input_word_len = const_word_len;
01708       break;
01709    }
01710 
01711 
01712    if (constant != NULL_IDX) {
01713 
01714       if (TYP_TYPE(type_idx) == Integer  ||  TYP_TYPE(type_idx) == Real) {
01715 
01716          /* the insert_constant routine will support comparisons */
01717          /* using local 'c' integer compares for both types if   */
01718          /* the constant's type can be viewed as a long or a     */
01719          /* long long on the host machine. So, if num_long_types */
01720          /* is a 1 or a 2, arith is not used, even for weird real*/
01721          /* constants (abnormals). Anything that requires a      */
01722          /* call to arith comparison should set num_long_types   */
01723          /* to 0.                                                */
01724 
01725          num_long_types = num_host_wds[TYP_LINEAR(type_idx)];
01726 
01727          /* this is where long_type is already a long long */
01728          /* or else long long is the same as long */
01729 
01730          if (sizeof(long_type) == sizeof(long long) &&
01731              num_long_types != 1) {
01732             num_long_types = 0;
01733          }
01734 
01735          if (TYP_TYPE(type_idx) == Real && 
01736              num_long_types != 1 &&
01737              num_long_types != 2) {
01738 
01739             if (target_ieee) {
01740 
01741                if (! is_normal(type_idx, constant)) {
01742                   const_idx = ntr_abnormal_ieee_const(type_idx,
01743                                                       constant);
01744                   goto FOUND;
01745                }
01746             }
01747             else {
01748 
01749                if (! pvp_isnormal(type_idx, constant)) {
01750                   const_idx = ntr_unshared_const_tbl(type_idx,
01751                                                      FALSE,
01752                                                      constant);
01753                   goto FOUND;
01754                }
01755             }
01756          }
01757 
01758 # ifdef _DEBUG
01759          if (dump_flags.constant_bits) {
01760             long neg_one = -1;
01761             write(1,constant, 
01762                   sizeof(long_type)*num_host_wds[TYP_LINEAR(type_idx)]);
01763             write(1,&neg_one, 4);
01764          }
01765 # endif
01766          const_idx = insert_constant(type_idx,
01767                                      constant,
01768                                      num_long_types);
01769 
01770          if (CN_POOL_IDX(const_idx) != NULL_IDX) {
01771             goto FOUND;
01772          }
01773          else {
01774             goto ATTACH_POOL_IDX;
01775          }
01776       }
01777       else {
01778          const_idx = insert_unordered_constant(type_idx,
01779                                                constant,
01780                                                input_word_len,
01781                                                const_word_len);
01782 
01783          if (CN_POOL_IDX(const_idx) != NULL_IDX) {
01784             goto FOUND;
01785          }
01786          else {
01787             goto ATTACH_POOL_IDX;
01788          }
01789       }
01790    }
01791 
01792 
01793    /* ----------------------------------------------------------------------- */
01794    /* Enter the incoming value into the Constant table.                       */
01795    /* ----------------------------------------------------------------------- */
01796 
01797    TBL_REALLOC_CK(const_tbl, 1);
01798    CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
01799    const_idx = const_tbl_idx;
01800 
01801 ATTACH_POOL_IDX:
01802 
01803    pool_idx = const_pool_idx + 1;
01804 
01805 #if defined(_HOST32) 
01806 
01807    if (DALIGN_TEST_CONDITION(type_idx)) {
01808 
01809       while ((((long)&const_pool[pool_idx]) % 8) != 0) {
01810          pool_idx++;
01811          const_pool_idx++;
01812       }
01813    }
01814 
01815 #endif
01816 
01817 
01818    CN_POOL_IDX(const_idx) = pool_idx;
01819 
01820    if ((const_pool_idx += const_word_len) >= const_pool_size) {
01821       const_pool_size = const_pool_size + 
01822                         ( ( ( (const_pool_idx - const_pool_size + 1) /
01823                               const_pool_inc) + 1) * const_pool_inc);
01824       MEM_REALLOC (const_pool, const_pool_type, const_pool_size);
01825    }
01826 
01827    CN_TYPE_IDX(const_idx)        = type_idx;
01828    CN_EXTRA_ZERO_WORD(const_idx) = extra_zero_word;
01829 
01830 
01831    /* If constant does not point to anything, then the caller will put the    */
01832    /* constant into the constant pool.  Otherwise copy the constant in.       */
01833 
01834    if (const_word_len == 0) {
01835 
01836       /* We don't want to write to any const_pool words for zero length.      */
01837       /* Intentionally blank.                                                 */
01838 
01839    }
01840    else if (constant != NULL_IDX) {
01841       const_pool[const_pool_idx] = 0L;
01842 
01843       if (TYP_TYPE(type_idx) == Character) {
01844 
01845          if (extra_zero_word) {
01846             const_pool[const_pool_idx - 1] = 0L;
01847          }
01848 
01849          strncpy((char *) &CN_CONST(const_idx), 
01850                  (char *)  constant,
01851                  (long)    CN_INT_TO_C(TYP_IDX(type_idx)));
01852       }
01853       else {
01854          for (i = 0; i < input_word_len; i++) {
01855             const_pool[pool_idx + i] = constant[i];
01856          }
01857       }
01858    }
01859    else {
01860 
01861       for (i = pool_idx;  i <= const_pool_idx;  i++) {
01862          const_pool[i] = 0L;
01863       }
01864    }
01865 
01866 
01867 FOUND:
01868 
01869 # if 0
01870    printf("************************************************************\n");
01871    dump_cn_tree(cn_root_idx[TYP_LINEAR(type_idx)],
01872                 type_idx,
01873                 0);
01874 # endif
01875 
01876 
01877    TRACE (Func_Exit, "ntr_const_tbl", NULL);
01878 
01879    return (const_idx);
01880 
01881 }  /* ntr_const_tbl */
01882 
01883 /******************************************************************************\
01884 |*                                                                            *|
01885 |* Description:                                                               *|
01886 |*      <description>                                                         *|
01887 |*                                                                            *|
01888 |* Input parameters:                                                          *|
01889 |*      NONE                                                                  *|
01890 |*                                                                            *|
01891 |* Output parameters:                                                         *|
01892 |*      NONE                                                                  *|
01893 |*                                                                            *|
01894 |* Returns:                                                                   *|
01895 |*      NOTHING                                                               *|
01896 |*                                                                            *|
01897 \******************************************************************************/
01898 
01899 static int insert_constant(int          type_idx,
01900                            long_type    *constant,
01901                            int          num_long_types)
01902 
01903 {
01904 
01905    int          balance_factor;                 /* d */
01906    int          cn_idx = NULL_IDX;              /* Y */
01907    int          idx = NULL_IDX;                 /* P */
01908    int          idx_B;                          /* B */
01909    int          idx_C;                          /* C */
01910    int          last_unbalanced_idx;            /* A */
01911    int          unbalanced_parent_idx = NULL_IDX; /* F */
01912    int          previous_idx = NULL_IDX;        /* Q */
01913    int          root;
01914    int          matched_cn_idx = NULL_IDX;
01915 
01916    TRACE (Func_Entry, "insert_constant", NULL);
01917 
01918    root = cn_root_idx[TYP_LINEAR(type_idx)];
01919 
01920    if (root == NULL_IDX) {
01921       /* nothing in the tree yet */
01922 
01923       TBL_REALLOC_CK(const_tbl, 1);
01924       CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
01925       cn_idx = const_tbl_idx;
01926 
01927       cn_root_idx[TYP_LINEAR(type_idx)] = cn_idx;
01928       goto EXIT;
01929    }
01930 
01931    last_unbalanced_idx = root;
01932    idx = root;
01933 
01934    switch (num_long_types) {
01935       case 1:
01936          while (idx) {
01937             if (CN_BALANCE_FACTOR(idx) != 0) {
01938                last_unbalanced_idx = idx;
01939                unbalanced_parent_idx = previous_idx;
01940             }
01941 
01942             if (*constant < CN_CONST(idx)) {
01943                previous_idx = idx;
01944                idx = CN_LEFT_CHILD(idx);
01945             }
01946             else if (*constant > CN_CONST(idx)) {
01947                previous_idx = idx;
01948                idx = CN_RIGHT_CHILD(idx);
01949             }
01950             else if (type_idx < CN_TYPE_IDX(idx)) {
01951                /* look to LEFT */
01952                matched_cn_idx = idx;
01953                previous_idx = idx;
01954                idx = CN_LEFT_CHILD(idx);
01955             }
01956             else if (type_idx > CN_TYPE_IDX(idx)) {
01957                /* look to RIGHT */
01958                matched_cn_idx = idx;
01959                previous_idx = idx;
01960                idx = CN_RIGHT_CHILD(idx);
01961             }
01962             else {
01963                /* found it. */
01964                cn_idx = idx;
01965                goto EXIT;
01966             }
01967          }
01968          break;
01969 
01970       case 2:
01971          while (idx) {
01972             if (CN_BALANCE_FACTOR(idx) != 0) {
01973                last_unbalanced_idx = idx;
01974                unbalanced_parent_idx = previous_idx;
01975             }
01976 
01977             if (*(long long *)constant < *(long long *)&CN_CONST(idx)) {
01978                previous_idx = idx;
01979                idx = CN_LEFT_CHILD(idx);
01980             }
01981             else if (*(long long *)constant > *(long long *)&CN_CONST(idx)) {
01982                previous_idx = idx;
01983                idx = CN_RIGHT_CHILD(idx);
01984             }
01985             else if (type_idx < CN_TYPE_IDX(idx)) {
01986                /* always look to LEFT */
01987                matched_cn_idx = idx;
01988                previous_idx = idx;
01989                idx = CN_LEFT_CHILD(idx);
01990             }
01991             else if (type_idx > CN_TYPE_IDX(idx)) {
01992                /* always look to RIGHT */
01993                matched_cn_idx = idx;
01994                previous_idx = idx;
01995                idx = CN_RIGHT_CHILD(idx);
01996             }
01997             else {
01998                /* found it. */
01999                cn_idx = idx;
02000                goto EXIT;
02001             }
02002          }
02003          break;
02004 
02005       default:
02006          while (idx) {
02007             if (CN_BALANCE_FACTOR(idx) != 0) {
02008                last_unbalanced_idx = idx;
02009                unbalanced_parent_idx = previous_idx;
02010             }
02011 
02012             if (compare_value_to_cn(constant, idx, Lt_Opr)) {
02013                previous_idx = idx;
02014                idx = CN_LEFT_CHILD(idx);
02015             }
02016             else if (compare_value_to_cn(constant, idx, Gt_Opr)) {
02017                previous_idx = idx;
02018                idx = CN_RIGHT_CHILD(idx);
02019             }
02020             else if (type_idx < CN_TYPE_IDX(idx)) {
02021                /* always look to LEFT */
02022                matched_cn_idx = idx;
02023                previous_idx = idx;
02024                idx = CN_LEFT_CHILD(idx);
02025             }
02026             else if (type_idx > CN_TYPE_IDX(idx)) {
02027                /* always look to RIGHT */
02028                matched_cn_idx = idx;
02029                previous_idx = idx;
02030                idx = CN_RIGHT_CHILD(idx);
02031             }
02032             else {
02033                /* found it. */
02034                cn_idx = idx;
02035                goto EXIT;
02036             }
02037          }
02038          break;
02039    } /* switch (num_long_types) */
02040 
02041    /* must insert */
02042    TBL_REALLOC_CK(const_tbl, 1);
02043    CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
02044    cn_idx = const_tbl_idx;
02045 
02046    if (matched_cn_idx != NULL_IDX) {
02047       COPY_TBL_NTRY(const_tbl, cn_idx, matched_cn_idx);
02048       CN_LEFT_CHILD(cn_idx) = NULL_IDX;
02049       CN_RIGHT_CHILD(cn_idx) = NULL_IDX;
02050       CN_TYPE_IDX(cn_idx) = type_idx;
02051    }
02052 
02053    switch (num_long_types) {
02054       case 1:
02055          if (*constant > CN_CONST(previous_idx)) {
02056             /* insert as right child */
02057             CN_RIGHT_CHILD(previous_idx) = cn_idx;
02058          }
02059          else if (*constant < CN_CONST(previous_idx)) {
02060             /* insert as left child */
02061             CN_LEFT_CHILD(previous_idx) = cn_idx;
02062          }
02063          else if (type_idx > CN_TYPE_IDX(previous_idx)) {
02064             /* insert as right child */
02065             CN_RIGHT_CHILD(previous_idx) = cn_idx;
02066          }
02067          else {
02068             /* insert as left child */
02069             CN_LEFT_CHILD(previous_idx) = cn_idx;
02070          }
02071 
02072          if (*constant > CN_CONST(last_unbalanced_idx)) {
02073             idx = CN_RIGHT_CHILD(last_unbalanced_idx);
02074             idx_B = idx;
02075             balance_factor = -1;
02076          }
02077          else if (*constant < CN_CONST(last_unbalanced_idx)) {
02078             idx = CN_LEFT_CHILD(last_unbalanced_idx);
02079             idx_B = idx;
02080             balance_factor = 1;
02081          }
02082          else if (type_idx > CN_TYPE_IDX(last_unbalanced_idx)) {
02083             idx = CN_RIGHT_CHILD(last_unbalanced_idx);
02084             idx_B = idx;
02085             balance_factor = -1;
02086          }
02087          else {
02088             idx = CN_LEFT_CHILD(last_unbalanced_idx);
02089             idx_B = idx;
02090             balance_factor = 1;
02091          }
02092 
02093          while (idx != cn_idx) {
02094             if (*constant > CN_CONST(idx)) {
02095                CN_BALANCE_FACTOR(idx) = -1;
02096                idx = CN_RIGHT_CHILD(idx);
02097             }
02098             else if (*constant < CN_CONST(idx)) {
02099                CN_BALANCE_FACTOR(idx) = 1;
02100                idx = CN_LEFT_CHILD(idx);
02101             }
02102             else if (type_idx > CN_TYPE_IDX(idx)) {
02103                CN_BALANCE_FACTOR(idx) = -1;
02104                idx = CN_RIGHT_CHILD(idx);
02105             }
02106             else {
02107                CN_BALANCE_FACTOR(idx) = 1;
02108                idx = CN_LEFT_CHILD(idx);
02109             }
02110          }
02111          break;
02112 
02113       case 2:
02114          if (*(long long *)constant > *(long long *)&CN_CONST(previous_idx)) {
02115             /* insert as right child */
02116             CN_RIGHT_CHILD(previous_idx) = cn_idx;
02117          }
02118          else if (*(long long *)constant < 
02119                     *(long long *)&CN_CONST(previous_idx)) {
02120             /* insert as left child */
02121             CN_LEFT_CHILD(previous_idx) = cn_idx;
02122          }
02123          else if (type_idx > CN_TYPE_IDX(previous_idx)) {
02124             /* insert as right child */
02125             CN_RIGHT_CHILD(previous_idx) = cn_idx;
02126          }
02127          else {
02128             /* insert as left child */
02129             CN_LEFT_CHILD(previous_idx) = cn_idx;
02130          }
02131 
02132          if (*(long long *)constant > 
02133                     *(long long *)&CN_CONST(last_unbalanced_idx)) {
02134             idx = CN_RIGHT_CHILD(last_unbalanced_idx);
02135             idx_B = idx;
02136             balance_factor = -1;
02137          }
02138          else if (*(long long *)constant < 
02139                            *(long long *)&CN_CONST(last_unbalanced_idx)) {
02140             idx = CN_LEFT_CHILD(last_unbalanced_idx);
02141             idx_B = idx;
02142             balance_factor = 1;
02143          }
02144          else if (type_idx > CN_TYPE_IDX(last_unbalanced_idx)) {
02145             idx = CN_RIGHT_CHILD(last_unbalanced_idx);
02146             idx_B = idx;
02147             balance_factor = -1;
02148          }
02149          else {
02150             idx = CN_LEFT_CHILD(last_unbalanced_idx);
02151             idx_B = idx;
02152             balance_factor = 1;
02153          }
02154 
02155          while (idx != cn_idx) {
02156             if (*(long long *)constant > *(long long *)&CN_CONST(idx)) {
02157                CN_BALANCE_FACTOR(idx) = -1;
02158                idx = CN_RIGHT_CHILD(idx);
02159             }
02160             else if (*(long long *)constant < *(long long *)&CN_CONST(idx)) {
02161                CN_BALANCE_FACTOR(idx) = 1;
02162                idx = CN_LEFT_CHILD(idx);
02163             }
02164             else if (type_idx > CN_TYPE_IDX(idx)) {
02165                CN_BALANCE_FACTOR(idx) = -1;
02166                idx = CN_RIGHT_CHILD(idx);
02167             }
02168             else {
02169                CN_BALANCE_FACTOR(idx) = 1;
02170                idx = CN_LEFT_CHILD(idx);
02171             }
02172          }
02173          break;
02174 
02175       default:
02176          if (compare_value_to_cn(constant, previous_idx, Gt_Opr)) {
02177             /* insert as right child */
02178             CN_RIGHT_CHILD(previous_idx) = cn_idx;
02179          }
02180          else if (compare_value_to_cn(constant, previous_idx, Lt_Opr)) {
02181             /* insert as left child */
02182             CN_LEFT_CHILD(previous_idx) = cn_idx;
02183          }
02184          else if (type_idx > CN_TYPE_IDX(previous_idx)) {
02185             /* insert as right child */
02186             CN_RIGHT_CHILD(previous_idx) = cn_idx;
02187          }
02188          else {
02189             /* insert as left child */
02190             CN_LEFT_CHILD(previous_idx) = cn_idx;
02191          }
02192 
02193 
02194          if (compare_value_to_cn(constant, last_unbalanced_idx, Gt_Opr)) {
02195             idx = CN_RIGHT_CHILD(last_unbalanced_idx);
02196             idx_B = idx;
02197             balance_factor = -1;  
02198          }
02199          else if (compare_value_to_cn(constant, last_unbalanced_idx, Lt_Opr)) {
02200             idx = CN_LEFT_CHILD(last_unbalanced_idx);
02201             idx_B = idx;
02202             balance_factor = 1;
02203          }
02204          else if (type_idx > CN_TYPE_IDX(last_unbalanced_idx)) {
02205             idx = CN_RIGHT_CHILD(last_unbalanced_idx);
02206             idx_B = idx;
02207             balance_factor = -1;
02208          }
02209          else {
02210             idx = CN_LEFT_CHILD(last_unbalanced_idx);
02211             idx_B = idx;
02212             balance_factor = 1;
02213          }
02214 
02215          while (idx != cn_idx) {
02216             if (compare_value_to_cn(constant, idx, Gt_Opr)) {
02217                CN_BALANCE_FACTOR(idx) = -1;
02218                idx = CN_RIGHT_CHILD(idx);
02219             }
02220             else if (compare_value_to_cn(constant, idx, Lt_Opr)) {
02221                CN_BALANCE_FACTOR(idx) = 1;
02222                idx = CN_LEFT_CHILD(idx);
02223             }
02224             else if (type_idx > CN_TYPE_IDX(idx)) {
02225                CN_BALANCE_FACTOR(idx) = -1;
02226                idx = CN_RIGHT_CHILD(idx);
02227             }
02228             else {
02229                CN_BALANCE_FACTOR(idx) = 1;
02230                idx = CN_LEFT_CHILD(idx);
02231             }
02232          }
02233          break;
02234    }
02235    
02236    if (CN_BALANCE_FACTOR(last_unbalanced_idx) == 0) {
02237       CN_BALANCE_FACTOR(last_unbalanced_idx) = balance_factor;
02238       goto EXIT;
02239    }
02240    
02241    if (CN_BALANCE_FACTOR(last_unbalanced_idx) + balance_factor == 0) {
02242       CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02243       goto EXIT;
02244    }
02245 
02246    /* tree unbalanced */
02247 
02248    if (balance_factor == 1) {
02249       /* left imbalance */
02250       if (CN_BALANCE_FACTOR(idx_B) == 1) {
02251          /* LL rotation */
02252          CN_LEFT_CHILD(last_unbalanced_idx) = CN_RIGHT_CHILD(idx_B);
02253          CN_RIGHT_CHILD(idx_B) = last_unbalanced_idx;
02254          CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02255          CN_BALANCE_FACTOR(idx_B) = 0;
02256       }
02257       else {
02258          /* LR rotation */
02259          idx_C = CN_RIGHT_CHILD(idx_B);
02260          CN_RIGHT_CHILD(idx_B) = CN_LEFT_CHILD(idx_C);
02261          CN_LEFT_CHILD(last_unbalanced_idx) = CN_RIGHT_CHILD(idx_C);
02262          CN_LEFT_CHILD(idx_C) = idx_B;
02263          CN_RIGHT_CHILD(idx_C) = last_unbalanced_idx;
02264 
02265          if (CN_BALANCE_FACTOR(idx_C) == 1) {
02266             /* LR (idx_B) */
02267             CN_BALANCE_FACTOR(last_unbalanced_idx) = -1;
02268             CN_BALANCE_FACTOR(idx_B) = 0;
02269          }
02270          else if (CN_BALANCE_FACTOR(idx_C) == -1) {
02271             /* LR (idx_C) */
02272             CN_BALANCE_FACTOR(idx_B) = 1;
02273             CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02274          }
02275          else {
02276             /* LR (last_unbalanced_idx) */
02277             CN_BALANCE_FACTOR(idx_B) = 0;
02278             CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02279          }
02280 
02281          CN_BALANCE_FACTOR(idx_C) = 0;
02282          idx_B = idx_C;
02283       }
02284    }
02285    else {
02286       /* right imbalance */
02287       if (CN_BALANCE_FACTOR(idx_B) == -1) {
02288          /* RR rotation */
02289          CN_RIGHT_CHILD(last_unbalanced_idx) = CN_LEFT_CHILD(idx_B);
02290          CN_LEFT_CHILD(idx_B) = last_unbalanced_idx;
02291          CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02292          CN_BALANCE_FACTOR(idx_B) = 0;
02293       }
02294       else {
02295          /* RL rotation */
02296          idx_C = CN_LEFT_CHILD(idx_B);
02297          CN_LEFT_CHILD(idx_B) = CN_RIGHT_CHILD(idx_C);
02298          CN_RIGHT_CHILD(last_unbalanced_idx) = CN_LEFT_CHILD(idx_C);
02299          CN_RIGHT_CHILD(idx_C) = idx_B;
02300          CN_LEFT_CHILD(idx_C) = last_unbalanced_idx;
02301 
02302          if (CN_BALANCE_FACTOR(idx_C) == -1) {
02303             /* RL (idx_B) */
02304             CN_BALANCE_FACTOR(last_unbalanced_idx) = 1;
02305             CN_BALANCE_FACTOR(idx_B) = 0;
02306          }
02307          else if (CN_BALANCE_FACTOR(idx_C) == 1) {
02308             /* RL (idx_C) */
02309             CN_BALANCE_FACTOR(idx_B) = -1;
02310             CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02311          }
02312          else {
02313             /* RL (last_unbalanced_idx) */
02314             CN_BALANCE_FACTOR(idx_B) = 0;
02315             CN_BALANCE_FACTOR(last_unbalanced_idx) = 0;
02316          }
02317 
02318          CN_BALANCE_FACTOR(idx_C) = 0;
02319          idx_B = idx_C;
02320       }
02321    }
02322 
02323    if (unbalanced_parent_idx == 0) {
02324       cn_root_idx[TYP_LINEAR(type_idx)] = idx_B;
02325    }
02326    else if (last_unbalanced_idx == CN_LEFT_CHILD(unbalanced_parent_idx)) {
02327       CN_LEFT_CHILD(unbalanced_parent_idx) = idx_B;
02328    }
02329    else if (last_unbalanced_idx == CN_RIGHT_CHILD(unbalanced_parent_idx)) {
02330       CN_RIGHT_CHILD(unbalanced_parent_idx) = idx_B;
02331    }
02332 
02333 EXIT:
02334 
02335    TRACE (Func_Exit, "insert_constant", NULL);
02336 
02337    return(cn_idx);
02338 
02339 }  /* insert_constant */
02340 
02341 /******************************************************************************\
02342 |*                                                                            *|
02343 |* Description:                                                               *|
02344 |*      Types that are not stored ordered are kept in a skewed tree (left).   *|
02345 |*                                                                            *|
02346 |* Input parameters:                                                          *|
02347 |*      NONE                                                                  *|
02348 |*                                                                            *|
02349 |* Output parameters:                                                         *|
02350 |*      NONE                                                                  *|
02351 |*                                                                            *|
02352 |* Returns:                                                                   *|
02353 |*      NOTHING                                                               *|
02354 |*                                                                            *|
02355 \******************************************************************************/
02356 
02357 static int insert_unordered_constant(int        type_idx,
02358                                      long_type  *constant,
02359                                      int        input_word_len,
02360                                      int        const_word_len)
02361 
02362 {
02363    int          cn_idx;
02364    int          i;
02365    int          idx;
02366    int          pool_idx;
02367    int          prev_idx;
02368    int          root;
02369 
02370    TRACE (Func_Entry, "insert_unordered_constant", NULL);
02371 
02372    root = cn_root_idx[TYP_LINEAR(type_idx)];
02373 
02374    if (root == NULL_IDX) {
02375       /* nothing in the tree yet */
02376 
02377       TBL_REALLOC_CK(const_tbl, 1);
02378       CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
02379       cn_idx = const_tbl_idx;
02380 
02381       cn_root_idx[TYP_LINEAR(type_idx)] = cn_idx;
02382       goto EXIT;
02383    }
02384 
02385    prev_idx = 0;
02386    idx = root;
02387 
02388    if (TYP_TYPE(type_idx) == Typeless) {
02389       while (idx) {
02390          if (type_idx == CN_TYPE_IDX(idx)) {
02391             if (CN_BOZ_CONSTANT(idx) ||
02392                 CN_BOOLEAN_CONSTANT(idx) ||
02393                 CN_HOLLERITH_TYPE(idx) != Not_Hollerith) {
02394                continue;
02395             }
02396             pool_idx = CN_POOL_IDX(idx);
02397             for (i = 0; i < input_word_len; i++) {
02398                if (const_pool[pool_idx + i] != constant[i]) {
02399                   break;
02400                }
02401             }
02402             if (i == input_word_len &&
02403                (input_word_len == const_word_len ||
02404                 const_pool[pool_idx + i] == 0)) {
02405                cn_idx = idx;
02406                goto EXIT;
02407             }
02408          }
02409 
02410          prev_idx = idx;
02411          idx = CN_LEFT_CHILD(idx);
02412       }
02413    }
02414    else {
02415       while (idx) {
02416          if (type_idx == CN_TYPE_IDX(idx)) {
02417             pool_idx = CN_POOL_IDX(idx);
02418 
02419             for (i = 0; i < input_word_len; i++) {
02420 
02421                if (const_pool[pool_idx + i] != constant[i]) {
02422                   break;
02423                }
02424             }
02425 
02426             if (i == input_word_len &&
02427                (input_word_len == const_word_len ||
02428                 const_pool[pool_idx + i] == 0)) {
02429                cn_idx = idx;
02430                goto EXIT;
02431             }
02432          }
02433 
02434          prev_idx = idx;
02435          idx = CN_LEFT_CHILD(idx);
02436       }
02437    }
02438 
02439    if (idx == NULL_IDX) {
02440       TBL_REALLOC_CK(const_tbl, 1);
02441       CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
02442       cn_idx = const_tbl_idx;
02443       CN_LEFT_CHILD(prev_idx) = cn_idx;
02444    }
02445 
02446 EXIT:
02447 
02448    TRACE (Func_Exit, "insert_unordered_constant", NULL);
02449 
02450    return(cn_idx);
02451 
02452 }  /* insert_unordered_constant */
02453 
02454 /******************************************************************************\
02455 |*                                                                            *|
02456 |* Description:                                                               *|
02457 |*      <description>                                                         *|
02458 |*                                                                            *|
02459 |* Input parameters:                                                          *|
02460 |*      NONE                                                                  *|
02461 |*                                                                            *|
02462 |* Output parameters:                                                         *|
02463 |*      NONE                                                                  *|
02464 |*                                                                            *|
02465 |* Returns:                                                                   *|
02466 |*      NOTHING                                                               *|
02467 |*                                                                            *|
02468 \******************************************************************************/
02469 
02470 static void dump_cn_tree(int            root,
02471                          int            type_idx,
02472                          int            indent)
02473 
02474 {
02475    int          i;
02476    char         shift[80];
02477    char         str[80];
02478 
02479    TRACE (Func_Entry, "dump_cn_tree", NULL);
02480 
02481    if (root != NULL_IDX) {
02482       for (i = 0; i < 3 * indent; i++) {
02483          shift[i] = ' ';
02484          if (i == 79)
02485             break;
02486       }
02487       shift[i] = '\0';
02488 
02489       printf("%s%s %c\n", shift, convert_to_string(&CN_CONST(root),
02490                                                     type_idx,
02491                                                     str),
02492                           TYP_DESC(CN_TYPE_IDX(root)) == Default_Typed ?
02493                                       'D' : 'K');
02494 
02495       if (CN_LEFT_CHILD(root) != NULL_IDX || 
02496           CN_RIGHT_CHILD(root) != NULL_IDX) {
02497          dump_cn_tree(CN_LEFT_CHILD(root), type_idx, indent+1);
02498          dump_cn_tree(CN_RIGHT_CHILD(root), type_idx, indent+1);
02499       }
02500    }
02501    else {
02502       printf("\n");
02503    }
02504 
02505    TRACE (Func_Exit, "dump_cn_tree", NULL);
02506 
02507    return;
02508 
02509 }  /* dump_cn_tree */
02510 
02511 /******************************************************************************\
02512 |*                                                                            *|
02513 |* Description:                                                               *|
02514 |*      ntr_boz_const_tbl adds BOZ constants to constant table. It            *|
02515 |*      searches for a match and returns the matching index if found.  If not *|
02516 |*      found it adds the constant and returns the new index.                 *|
02517 |*                                                                            *|
02518 |* Input parameters:                                                          *|
02519 |*      constant      The constant to be entered.                             *|
02520 |*                                                                            *|
02521 |* Output parameters:                                                         *|
02522 |*      NONE                                                                  *|
02523 |*                                                                            *|
02524 |* Returns:                                                                   *|
02525 |*      constant table index of entry                                         *|
02526 |*                                                                            *|
02527 \******************************************************************************/
02528 
02529 int     ntr_boz_const_tbl(int           type_idx,
02530                           long_type     *constant)
02531 
02532 {
02533    register int          const_idx;
02534    register int          i;
02535    register int          pool_idx;
02536    register int          word_len;
02537 
02538 
02539    TRACE (Func_Entry, "ntr_boz_const_tbl", NULL);
02540 
02541    word_len = STORAGE_WORD_SIZE(TYP_BIT_LEN(type_idx));
02542 
02543    for (const_idx = 1; const_idx <= const_tbl_idx; const_idx++) {
02544 
02545       if (CN_BOZ_CONSTANT(const_idx) &&
02546           CN_TYPE_IDX(const_idx) == type_idx) {
02547 
02548          pool_idx = CN_POOL_IDX(const_idx);
02549 
02550          for (i = 0; i < word_len; i++) {
02551 
02552             if (const_pool[pool_idx + i] != constant[i]) {
02553                break;
02554             }
02555          }
02556 
02557          if (i == word_len) {
02558             goto FOUND;
02559          }
02560       }
02561    }
02562 
02563    TBL_REALLOC_CK(const_tbl, 1);
02564    CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
02565    pool_idx = const_pool_idx + 1;
02566 
02567    CN_POOL_IDX(const_tbl_idx)   = pool_idx;
02568 
02569    if ((const_pool_idx += word_len) >= const_pool_size) {
02570       const_pool_size = const_pool_size +
02571                         ( ( ( (const_pool_idx - const_pool_size + 1) /
02572                              const_pool_inc) + 1) * const_pool_inc);
02573       MEM_REALLOC (const_pool, const_pool_type, const_pool_size);
02574    }
02575 
02576    const_idx                    = const_tbl_idx;
02577    CN_TYPE_IDX(const_idx)       = type_idx;
02578    CN_BOZ_CONSTANT(const_idx)   = TRUE;
02579 
02580    for (i = 0; i < word_len; i++) {
02581       const_pool[pool_idx + i] = constant[i];
02582    }
02583 
02584 FOUND:
02585 
02586    TRACE (Func_Exit, "ntr_boz_const_tbl", NULL);
02587 
02588    return (const_idx);
02589 
02590 }  /* ntr_boz_const_tbl */
02591 
02592 /******************************************************************************\
02593 |*                                                                            *|
02594 |* Description:                                                               *|
02595 |*      ntr_boolean_const_tbl adds boolean constants to constant table. It    *|
02596 |*      searches for a match and returns the matching index if found.  If not *|
02597 |*      found it adds the constant and returns the new index.                 *|
02598 |*                                                                            *|
02599 |* Input parameters:                                                          *|
02600 |*      constant      The constant to be entered.                             *|
02601 |*                                                                            *|
02602 |* Output parameters:                                                         *|
02603 |*      NONE                                                                  *|
02604 |*                                                                            *|
02605 |* Returns:                                                                   *|
02606 |*      constant table index of entry                                         *|
02607 |*                                                                            *|
02608 \******************************************************************************/
02609 int     ntr_boolean_const_tbl(int               type_idx,
02610                               long_type         *constant)
02611 
02612 {
02613    register int          const_idx;
02614    register int          i;
02615    register int          pool_idx;
02616    register int          word_len;
02617 
02618 
02619    TRACE (Func_Entry, "ntr_boolean_const_tbl", NULL);
02620 
02621    word_len = STORAGE_WORD_SIZE(TYP_BIT_LEN(type_idx));
02622 
02623    for (const_idx = 1; const_idx <= const_tbl_idx; const_idx++) {
02624 
02625       if (CN_BOOLEAN_CONSTANT(const_idx) &&
02626           CN_TYPE_IDX(const_idx) == type_idx) {
02627 
02628          pool_idx = CN_POOL_IDX(const_idx);
02629 
02630          for (i = 0; i < word_len; i++) {
02631 
02632             if (const_pool[pool_idx + i] != constant[i]) {
02633                break;
02634             }
02635          }
02636 
02637          if (i == word_len) {
02638             goto FOUND;
02639          }
02640       }
02641    }
02642 
02643    TBL_REALLOC_CK(const_tbl, 1);
02644    CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
02645    pool_idx = const_pool_idx + 1;
02646 
02647    CN_POOL_IDX(const_tbl_idx)   = pool_idx;
02648 
02649    if ((const_pool_idx += word_len) >= const_pool_size) {
02650       const_pool_size = const_pool_size +
02651                         ( ( ( (const_pool_idx - const_pool_size + 1) /
02652                              const_pool_inc) + 1) * const_pool_inc);
02653       MEM_REALLOC (const_pool, const_pool_type, const_pool_size);
02654    }
02655 
02656    const_idx                    = const_tbl_idx;
02657    CN_TYPE_IDX(const_idx)       = type_idx;
02658    CN_BOOLEAN_CONSTANT(const_idx)   = TRUE;
02659 
02660    for (i = 0; i < word_len; i++) {
02661       const_pool[pool_idx + i] = constant[i];
02662    }
02663 
02664 FOUND:
02665 
02666    TRACE (Func_Exit, "ntr_boolean_const_tbl", NULL);
02667 
02668    return (const_idx);
02669 
02670 }  /* ntr_boolean_const_tbl */
02671 
02672 
02673 /******************************************************************************\
02674 |*                                                                            *|
02675 |* Description:                                                               *|
02676 |*      ntr_unshared_const_tbl just slams the constant into the Constant      *|
02677 |*      table without doing any searches to see if the constant already       *|
02678 |*      exists in the table.  It is also used to add typeless constants that  *|
02679 |*      are used in numeric contexts to the Constant table because the normal *|
02680 |*      ntr_const_tbl can't be used because the bit pattern in the typeless   *|
02681 |*      entity might not be a valid floating-point bit pattern for example.   *|
02682 |*                                                                            *|
02683 |* Input parameters:                                                          *|
02684 |*      type_idx         The data type of the incoming constant.              *|
02685 |*      extra_zero_word  Add an extra word to constant and set flag.          *|
02686 |*      constant         The address of the constant to be entered.           *|
02687 |*                                                                            *|
02688 |* Output parameters:                                                         *|
02689 |*      NONE                                                                  *|
02690 |*                                                                            *|
02691 |* Returns:                                                                   *|
02692 |*      Constant table index of the new entry.                                *|
02693 |*                                                                            *|
02694 \******************************************************************************/
02695 
02696 int ntr_unshared_const_tbl (int           type_idx,
02697                             boolean       extra_zero_word,
02698                             long_type    *constant)
02699 
02700 {
02701    register     int                     const_idx;
02702                 long64                  const_word_len;
02703    register     int                     i;
02704                 long64                  input_word_len;
02705                 size_offset_type        length;
02706    register     int                     pool_idx;
02707 
02708 
02709    TRACE (Func_Entry, "ntr_unshared_const_tbl", NULL);
02710 
02711    switch(TYP_TYPE(type_idx)) {
02712 
02713       case Typeless:
02714 
02715          input_word_len = STORAGE_WORD_SIZE(TYP_BIT_LEN(type_idx));
02716          const_word_len =
02717             (extra_zero_word) ? input_word_len + 1 : input_word_len;
02718          break;
02719 
02720 
02721       case Character:
02722 
02723          input_word_len = TARGET_BYTES_TO_WORDS(CN_INT_TO_C(TYP_IDX(type_idx)));
02724          const_word_len =
02725             (extra_zero_word) ? input_word_len + 1 : input_word_len;
02726          break;
02727 
02728 
02729       case Integer:
02730       case Real:
02731       case Logical:
02732 
02733          const_word_len =
02734             TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
02735          input_word_len = const_word_len;
02736          break;
02737 
02738 
02739       case Complex:
02740 
02741          const_word_len =
02742             TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
02743 
02744 #if defined(_TARGET_OS_MAX) || defined(_WHIRL_HOST64_TARGET64)
02745 
02746          if (TYP_LINEAR(type_idx) == Complex_4) {
02747             const_word_len = 2;
02748          }
02749 
02750 #endif
02751          input_word_len = const_word_len;
02752          break;
02753 
02754 
02755       case Structure:
02756 
02757          /* Issue error - constant too big??? */
02758          /* This cannot ever be executed, because it will not work. KAY */
02759 
02760          length.fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));;
02761          length.idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));;
02762 
02763          BITS_TO_WORDS(length, TARGET_BITS_PER_WORD);
02764 
02765          if (length.fld == CN_Tbl_Idx) {
02766             const_word_len =  CN_INT_TO_C(length.idx);
02767          }
02768          else {
02769             PRINTMSG(AT_DEF_LINE(TYP_IDX(type_idx)), 1201, Internal,
02770                      AT_DEF_COLUMN(TYP_IDX(type_idx)),
02771                      AT_OBJ_NAME_PTR(TYP_IDX(type_idx)));
02772          }
02773    
02774          input_word_len = const_word_len;
02775          break;
02776    }
02777 
02778 
02779    TBL_REALLOC_CK(const_tbl, 1);
02780    CLEAR_TBL_NTRY(const_tbl, const_tbl_idx);
02781    pool_idx = const_pool_idx + 1;
02782 
02783 
02784 #if defined(_HOST32)
02785 
02786    if (DALIGN_TEST_CONDITION(type_idx)) {
02787 
02788       while ((((long)&const_pool[pool_idx]) % 8) != 0) {
02789          pool_idx++;
02790          const_pool_idx++;
02791       }
02792    }
02793 
02794 #endif
02795 
02796 
02797    CN_POOL_IDX(const_tbl_idx) = pool_idx;
02798 
02799    if ((const_pool_idx += const_word_len) >= const_pool_size) {
02800       const_pool_size = const_pool_size +
02801                         ( ( ( (const_pool_idx - const_pool_size + 1) /
02802                              const_pool_inc) + 1) * const_pool_inc);
02803       MEM_REALLOC (const_pool, const_pool_type, const_pool_size);
02804    }
02805 
02806    const_idx                     = const_tbl_idx;
02807    CN_TYPE_IDX(const_idx)        = type_idx;
02808    CN_EXTRA_ZERO_WORD(const_idx) = extra_zero_word;
02809 
02810 
02811    /* If constant does not point to anything, then the caller will put the */
02812    /* constant into the constant pool.  Otherwise copy the constant in.    */
02813 
02814    if (const_word_len == 0) {
02815 
02816       /* Intentionally blank because we don't want to write to any const_pool */
02817       /* words for a zero-length constant.                                    */
02818 
02819    }
02820    else if (constant != NULL_IDX) {
02821       const_pool[const_pool_idx] = 0L;
02822 
02823       if (TYP_TYPE(type_idx) == Character) {
02824 
02825          if (extra_zero_word) {
02826             const_pool[const_pool_idx - 1] = 0L;
02827          }
02828          strncpy((char *) &CN_CONST(const_idx),
02829                  (char *) constant,
02830                  (long) CN_INT_TO_C(TYP_IDX(type_idx)));
02831       }
02832       else {
02833 
02834          for (i = 0;  i < input_word_len;  i++) {
02835             const_pool[pool_idx + i] = constant[i];
02836          }
02837       }
02838    }
02839    else {
02840 
02841       for (i = pool_idx;  i <= const_pool_idx;  i++) {
02842          const_pool[i] = 0L;
02843       }
02844    }
02845 
02846    TRACE (Func_Exit, "ntr_unshared_const_tbl", NULL);
02847 
02848    return (const_idx);
02849 
02850 }  /* ntr_unshared_const_tbl */
02851 
02852 
02853 
02854 /******************************************************************************\
02855 |*                                                                            *|
02856 |* Description:                                                               *|
02857 |*      This procedure adds an abnormal IEEE constant to the Constant table   *|
02858 |*      or finds such a constant if it already exists in the Constant table.  *|
02859 |*                                                                            *|
02860 |* Input parameters:                                                          *|
02861 |*      type_idx         data type of the incoming constant                   *|
02862 |*      constant         the address of the constant to be entered or located *|
02863 |*                                                                            *|
02864 |* Output parameters:                                                         *|
02865 |*      NONE                                                                  *|
02866 |*                                                                            *|
02867 |* Returns:                                                                   *|
02868 |*      Constant table index of the incoming constant.                        *|
02869 |*                                                                            *|
02870 \******************************************************************************/
02871 
02872 static int ntr_abnormal_ieee_const(int           type_idx,
02873                                    long_type    *constant)
02874 
02875 {
02876    int  const_idx;
02877    int  idx;
02878 
02879    enum   abnormal_value    { Real_4_Nan,
02880                               Real_8_Nan,
02881                               Real_16_Nan,
02882                               Real_4_Pos_Inf,
02883                               Real_8_Pos_Inf,
02884                               Real_16_Pos_Inf,
02885                               Real_4_Neg_Inf,
02886                               Real_8_Neg_Inf,
02887                               Real_16_Neg_Inf,
02888                               Real_4_Subnormal,
02889                               Real_8_Subnormal,
02890                               Real_16_Subnormal,
02891                               Real_4_Pos_Zero,
02892                               Real_8_Pos_Zero,
02893                               Real_16_Pos_Zero,
02894                               Real_4_Neg_Zero,
02895                               Real_8_Neg_Zero,
02896                               Real_16_Neg_Zero
02897                             };
02898 
02899 
02900    TRACE (Func_Entry, "ntr_abnormal_ieee_const", NULL);
02901 
02902 
02903    switch (TYP_LINEAR(type_idx)) {
02904 
02905       case Real_4:
02906 
02907          switch (fp_classify(type_idx, constant)) {
02908 
02909             case FP_SGI_NAN:
02910                idx = (int) Real_4_Nan;
02911                break;
02912 
02913             case FP_SGI_INFINITE:
02914                idx = (sign_bit(type_idx, constant) == 0) ?
02915                         (int) Real_4_Pos_Inf : (int) Real_4_Neg_Inf;
02916                break;
02917 
02918             case FP_SGI_SUBNORMAL:
02919                idx = (int) Real_4_Subnormal;
02920                break;
02921 
02922             case FP_SGI_ZERO:
02923                idx = (sign_bit(type_idx, constant) == 0) ?
02924                         (int) Real_4_Pos_Zero : (int) Real_4_Neg_Zero;
02925                break;
02926 
02927             default:                                /* FP_SGI_NORMAL */
02928                PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col,
02929                      "ntr_abnormal_ieee_const");
02930          }
02931 
02932          break;
02933 
02934 
02935       case Real_8:
02936 
02937          switch (fp_classify(type_idx, constant)) {
02938 
02939             case FP_SGI_NAN:
02940                idx = (int) Real_8_Nan;
02941                break;
02942 
02943             case FP_SGI_INFINITE:
02944                idx = (sign_bit(type_idx, constant) == 0) ?
02945                         (int) Real_8_Pos_Inf : (int) Real_8_Neg_Inf;
02946                break;
02947 
02948             case FP_SGI_SUBNORMAL:
02949                idx = (int) Real_8_Subnormal;
02950                break;
02951 
02952             case FP_SGI_ZERO:
02953                idx = (sign_bit(type_idx, constant) == 0) ?
02954                         (int) Real_8_Pos_Zero : (int) Real_8_Neg_Zero;
02955                break;
02956 
02957             default:                                /* FP_SGI_NORMAL */
02958                PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col,
02959                      "ntr_abnormal_ieee_const");
02960          }
02961 
02962          break;
02963 
02964 
02965       case Real_16:
02966 
02967          switch (fp_classify(type_idx, constant)) {
02968 
02969             case FP_SGI_NAN:
02970                idx = (int) Real_16_Nan;
02971                break;
02972 
02973             case FP_SGI_INFINITE:
02974                idx = (sign_bit(type_idx, constant) == 0) ?
02975                         (int) Real_16_Pos_Inf : (int) Real_16_Neg_Inf;
02976                break;
02977 
02978             case FP_SGI_SUBNORMAL:
02979                idx = (int) Real_16_Subnormal;
02980                break;
02981 
02982             case FP_SGI_ZERO:
02983                idx = (sign_bit(type_idx, constant) == 0) ?
02984                         (int) Real_16_Pos_Zero : (int) Real_16_Neg_Zero;
02985                break;
02986 
02987             default:                                /* FP_SGI_NORMAL */
02988                PRINTMSG(stmt_start_line, 179, Internal, stmt_start_col,
02989                      "ntr_abnormal_ieee_const");
02990          }
02991    }
02992 
02993    if (ieee_const_tbl_idx[idx] == NULL_IDX) {
02994       const_idx = ntr_unshared_const_tbl(type_idx, FALSE, constant);
02995       ieee_const_tbl_idx[idx] = const_idx;
02996    }
02997    else {
02998       const_idx = ieee_const_tbl_idx[idx];
02999    }
03000 
03001    TRACE (Func_Exit, "ntr_abnormal_ieee_const", NULL);
03002 
03003    return(const_idx);
03004 
03005 }  /* ntr_abnormal_ieee_const */
03006 
03007 
03008 
03009 /******************************************************************************\
03010 |*                                                                            *|
03011 |* Description:                                                               *|
03012 |*      srch_host_stor_blk_tbl searches the stor_blk tables of all hosts for  *|
03013 |*      the identifier contained in the identifier field of token.            *|
03014 |*                                                                            *|
03015 |* Input parameters:                                                          *|
03016 |*      token                   token containing identifier to                *|
03017 |*                              search for and length in chars of name        *|
03018 |*                                                                            *|
03019 |*                                                                            *|
03020 |* Returns:                                                                   *|
03021 |*      stor_blk table index   if found                                       *|
03022 |*      NULL_IDX                if not found                                  *|
03023 |*                                                                            *|
03024 |*                                                                            *|
03025 \******************************************************************************/
03026 
03027 int srch_host_stor_blk_tbl (token_type *token)
03028 
03029 {
03030 
03031    int           idx            = NULL_IDX;
03032    token_type    nme_token;
03033    int           save_scp_idx;
03034    
03035    TRACE (Func_Entry, "srch_host_stor_blk_tbl", NULL);
03036 
03037    /* DO NOT search the host when processing an interface block */
03038 
03039    if (SCP_IS_INTERFACE(curr_scp_idx)) {
03040       return (NULL_IDX);
03041    }
03042 
03043    save_scp_idx = curr_scp_idx;
03044 
03045    while (idx == NULL_IDX && SCP_PARENT_IDX(curr_scp_idx) != NULL_IDX) {
03046 
03047       /* Set current scope to parent, for searching. */
03048 
03049       curr_scp_idx      = SCP_PARENT_IDX(curr_scp_idx);
03050 
03051       nme_token         = *token;
03052       idx               = srch_stor_blk_tbl(TOKEN_STR(nme_token),
03053                                             TOKEN_LEN(nme_token),
03054                                             curr_scp_idx);
03055    }  /* while */
03056 
03057    curr_scp_idx = save_scp_idx;
03058 
03059    TRACE (Func_Exit, "srch_host_stor_blk_tbl", NULL);
03060 
03061     return (idx);
03062 
03063 }  /* srch_host_stor_blk_tbl */
03064 
03065 /******************************************************************************\
03066 |*                                                                            *|
03067 |* Description:                                                               *|
03068 |*      Compare two derived types, to see if they are the same.               *|
03069 |*                                                                            *|
03070 |* Input parameters:                                                          *|
03071 |*      dt_idx1 ->  Index to first derived type to compare.                   *|
03072 |*      dt_idx2 ->  Index to second derived type to compare.                  *|
03073 |*                                                                            *|
03074 |* Output parameters:                                                         *|
03075 |*      NONE                                                                  *|
03076 |*                                                                            *|
03077 |* Returns:                                                                   *|
03078 |*      TRUE if they are the same, else FALSE.                                *|
03079 |*                                                                            *|
03080 \******************************************************************************/
03081 boolean compare_derived_types(int       dt_idx1,
03082                               int       dt_idx2)
03083 
03084 {
03085    int           at_idx1;
03086    int           at_idx2;
03087    int           bit_idx1;
03088    int           bit_idx2;
03089    boolean       check;
03090    int           entry_idx1;
03091    int           entry_idx2;
03092    int           id1;
03093    int           id2;
03094    int           idx;
03095    boolean       keep_compare;
03096    int           len1;
03097    int           len2;
03098    int           mod_idx1;
03099    int           mod_idx2;
03100    long         *name1;
03101    long         *name2;
03102    int           s_idx1;
03103    int           s_idx2;
03104    boolean       same;
03105 
03106    static        long   dt_cmp_tbl_size;
03107    static        int    entry_size;
03108    static        long   num_of_entries;
03109    static        long   unique_dt_number;
03110 
03111 
03112    TRACE (Func_Entry, "compare_derived_types", NULL);
03113 
03114    /* first check to see if they resolve to the same attr */
03115 
03116    dt_idx1 = TYP_IDX(dt_idx1);
03117    dt_idx2 = TYP_IDX(dt_idx2);
03118 
03119    while (AT_ATTR_LINK(dt_idx1) != NULL_IDX) {
03120       dt_idx1 = AT_ATTR_LINK(dt_idx1);
03121    }
03122 
03123    while (AT_ATTR_LINK(dt_idx2) != NULL_IDX) {
03124       dt_idx2 = AT_ATTR_LINK(dt_idx2);
03125    }
03126 
03127    if (dt_idx1 == dt_idx2) {
03128       same = TRUE;
03129       return(TRUE);
03130    }
03131 
03132    /* Check to see if this attr has already been compared */
03133 
03134    /* This routine uses a bit table to keep track of whether two derived  */
03135    /* types have been compared and if they are the same or not.  This     */
03136    /* prevents checking over and over if a derived type is the same.      */
03137    /* Keeping the bit format, keeps storage space small.                  */
03138    /* The number of derived types is counted during pass 1.  All derived  */
03139    /* types in a program unit and all containing program units get unique */
03140    /* id's.  This id is used to check the type in the dt_cmp_tbl.         */
03141    /* The table is a 2-D table, where each derived type gets an entry.    */
03142    /* Each entry is a group of longs, containing a bit for each derived   */
03143    /* type.  Thus if a program unit has 100 derived types, the table will */
03144    /* have 100 entries and each entry will be 128 bits long (100 rounded  */
03145    /* up to the next full word).  Since this is 2-D, each combination of  */
03146    /* derived types exists in two places.  The two places hold separate   */
03147    /* information.  If you access [lower id][higher id] the bit says if   */
03148    /* the types have been compared.  TRUE = compared. If you access       */
03149    /* [higher id][lower id] the bit says if the types are the same or     */
03150    /* not.  TRUE = same.  For example, you have two derived types, #8 and */
03151    /* #33.  [entry #8][bit #33] tells whether these two derived types     */
03152    /* have been compared.  If that bit is set, then [entry #33][bit #8]   */
03153    /* tells you if they are the same or not.  It's compact and fast.      */
03154 
03155 
03156    if (dt_cmp_tbl == NULL) {  /* Need to allocate table. */
03157 
03158       if (comp_phase >= Decl_Semantics) {
03159          num_of_entries = num_of_derived_types;
03160       }
03161       else {
03162          num_of_entries = (num_of_derived_types > 500) ? num_of_derived_types :
03163                                                          500;
03164       }
03165 
03166       entry_size        = ((num_of_entries-1) / HOST_BITS_PER_WORD) + 1;
03167       dt_cmp_tbl_size   = (1 + num_of_entries) * entry_size;
03168       unique_dt_number  = 0;
03169 
03170       /* must do original malloc */
03171 
03172       MEM_ALLOC(dt_cmp_tbl, long, dt_cmp_tbl_size);
03173 
03174       for (idx = 0; idx < dt_cmp_tbl_size; idx++) dt_cmp_tbl[idx] = 0;
03175    }
03176    id1  = ATT_UNIQUE_ID(dt_idx1);
03177    id2  = ATT_UNIQUE_ID(dt_idx2);
03178 
03179    if (id1 == 0) {
03180       id1                       = ++unique_dt_number;
03181       ATT_UNIQUE_ID(dt_idx1)    = id1;
03182    }
03183    
03184    if (id2 == 0) {
03185       id2                       = ++unique_dt_number;
03186       ATT_UNIQUE_ID(dt_idx2)    = id2;
03187    }
03188 
03189 
03190    if (id1 > num_of_entries || id2 > num_of_entries) {
03191 
03192       /* We cannot keep track of these.  Have them use the last extra entry. */
03193 
03194       keep_compare      = FALSE;
03195    }
03196    else {
03197       keep_compare      = TRUE;
03198 
03199       /* The lower of the two becomes id1.  The larger becomes id2. */
03200 
03201       if (id2 < id1) {
03202          entry_idx1     = id2;  /* Temp holder. */
03203          id2            = id1;
03204          id1            = entry_idx1;
03205       }
03206 
03207       entry_idx1        = ((id1-1)*entry_size) + ((id2-1) / HOST_BITS_PER_WORD);
03208       entry_idx2        = ((id2-1)*entry_size) + ((id1-1) / HOST_BITS_PER_WORD);
03209       bit_idx1          = ((id2-1) % HOST_BITS_PER_WORD);
03210       bit_idx2          = ((id1-1) % HOST_BITS_PER_WORD);
03211 
03212       check             = (1 << bit_idx1) & dt_cmp_tbl[entry_idx1];
03213 
03214       if (check) {
03215          same = (1 << bit_idx2) & dt_cmp_tbl[entry_idx2]; 
03216          goto DONE;
03217       }
03218    
03219       /* Didn't find this attr.  Set the check bit and compare bit */
03220       /* to same in case a recursive call happens.  Same  will get */
03221       /* set correctly at the end of this routine.                 */
03222 
03223       dt_cmp_tbl[entry_idx1]    |= (1 << bit_idx1);     /* Check */
03224       dt_cmp_tbl[entry_idx2]    |= (1 << bit_idx2);     /* Same  */
03225 
03226    }
03227 
03228    if (AT_USE_ASSOCIATED(dt_idx1)) {
03229       name1     = AT_ORIG_NAME_LONG(dt_idx1);
03230       len1      = AT_ORIG_NAME_LEN(dt_idx1);
03231       mod_idx1  = AT_MODULE_IDX(dt_idx1);
03232    }
03233    else {
03234       name1     = AT_OBJ_NAME_LONG(dt_idx1);
03235       len1      = AT_NAME_LEN(dt_idx1);
03236       mod_idx1  = NULL_IDX;
03237    }
03238 
03239    if (AT_USE_ASSOCIATED(dt_idx2)) {
03240       name2     = AT_ORIG_NAME_LONG(dt_idx2);
03241       len2      = AT_ORIG_NAME_LEN(dt_idx2);
03242       mod_idx2  = AT_MODULE_IDX(dt_idx2);
03243    }
03244    else {
03245       name2     = AT_OBJ_NAME_LONG(dt_idx2);
03246       len2      = AT_NAME_LEN(dt_idx2);
03247       mod_idx2  = NULL_IDX;
03248    }
03249 
03250    if (compare_names(name1, len1, name2, len2) != 0) {
03251       same = FALSE;
03252       goto DONE;
03253    }
03254 
03255    if (mod_idx1 != NULL_IDX && mod_idx2 != NULL_IDX &&
03256        compare_names(AT_OBJ_NAME_LONG(mod_idx1),
03257                      AT_NAME_LEN(mod_idx1),
03258                      AT_OBJ_NAME_LONG(mod_idx2),
03259                      AT_NAME_LEN(mod_idx2)) == 0) {
03260       same = TRUE;
03261       goto DONE;
03262    }
03263 
03264    same = (!ATT_PRIVATE_CPNT(dt_idx1) && 
03265            !ATT_PRIVATE_CPNT(dt_idx2) &&
03266            (!AT_PRIVATE(dt_idx1) || AT_USE_ASSOCIATED(dt_idx1)) &&
03267            (!AT_PRIVATE(dt_idx2) || AT_USE_ASSOCIATED(dt_idx1)) &&
03268             ATT_SEQUENCE_SET(dt_idx1) &&
03269             ATT_SEQUENCE_SET(dt_idx2) &&
03270             ATT_NUM_CPNTS(dt_idx1) == ATT_NUM_CPNTS(dt_idx2));
03271 
03272    if (!same) {
03273       goto DONE;
03274    }
03275 
03276    s_idx1 = ATT_FIRST_CPNT_IDX(dt_idx1);
03277    s_idx2 = ATT_FIRST_CPNT_IDX(dt_idx2);
03278 
03279    while (s_idx1 != NULL_IDX) {
03280       at_idx1 = SN_ATTR_IDX(s_idx1);
03281       at_idx2 = SN_ATTR_IDX(s_idx2);
03282 
03283       same = same &&
03284              ATD_POINTER(at_idx1) == ATD_POINTER(at_idx2) &&
03285              TYP_TYPE(ATD_TYPE_IDX(at_idx1)) == 
03286                       TYP_TYPE(ATD_TYPE_IDX(at_idx2)) &&
03287              compare_array_entries(ATD_ARRAY_IDX(at_idx1), 
03288                                    ATD_ARRAY_IDX(at_idx2)) &&
03289              (compare_names(AT_OBJ_NAME_LONG(at_idx1),
03290                             AT_NAME_LEN(at_idx1),
03291                             AT_OBJ_NAME_LONG(at_idx2),
03292                             AT_NAME_LEN(at_idx2)) == 0);
03293 
03294       /* Components, so they must be constants */
03295 
03296       if (TYP_TYPE(ATD_TYPE_IDX(at_idx1)) == Character) {
03297          same = same && fold_relationals(TYP_IDX(ATD_TYPE_IDX(at_idx1)),
03298                                          TYP_IDX(ATD_TYPE_IDX(at_idx2)),
03299                                          Eq_Opr);
03300       }
03301       else if (TYP_TYPE(ATD_TYPE_IDX(at_idx1)) == Structure) {
03302 
03303          if (TYP_IDX(ATD_TYPE_IDX(at_idx1)) == dt_idx1 &&
03304              TYP_IDX(ATD_TYPE_IDX(at_idx2)) == dt_idx2) {
03305 
03306             /* intentionally blank */
03307          }
03308          else if (TYP_IDX(ATD_TYPE_IDX(at_idx1)) == dt_idx1 &&
03309                   TYP_IDX(ATD_TYPE_IDX(at_idx2)) != dt_idx2) {
03310             same = FALSE;
03311             goto DONE;
03312          }
03313          else if (TYP_IDX(ATD_TYPE_IDX(at_idx1)) != dt_idx1 &&
03314                   TYP_IDX(ATD_TYPE_IDX(at_idx2)) == dt_idx2) {
03315             same = FALSE;
03316             goto DONE;
03317          }
03318          else {
03319             same=same && compare_derived_types(ATD_TYPE_IDX(at_idx1),
03320                                                ATD_TYPE_IDX(at_idx2));
03321          }
03322       }
03323       else {
03324          same = same && TYP_LINEAR(ATD_TYPE_IDX(at_idx1)) ==
03325                         TYP_LINEAR(ATD_TYPE_IDX(at_idx2));
03326       }
03327 
03328       s_idx1 = SN_SIBLING_LINK(s_idx1);
03329       s_idx2 = SN_SIBLING_LINK(s_idx2);
03330    }  
03331 
03332 DONE: 
03333 
03334    if (keep_compare) {
03335 
03336       if (same) {
03337          dt_cmp_tbl[entry_idx2] |= (1 << bit_idx2);     /* Same bit */
03338       }
03339       else {
03340          dt_cmp_tbl[entry_idx2] &= ~(1 << bit_idx2);    /* Same bit */
03341       }
03342    }
03343 
03344    TRACE (Func_Exit, "compare_derived_types", NULL);
03345 
03346    return(same);
03347 
03348 }  /* compare_derived_types */
03349 
03350 /******************************************************************************\
03351 |*                                                                            *|
03352 |* Description:                                                               *|
03353 |*      <description>                                                         *|
03354 |*                                                                            *|
03355 |* Input parameters:                                                          *|
03356 |*      NONE                                                                  *|
03357 |*                                                                            *|
03358 |* Output parameters:                                                         *|
03359 |*      NONE                                                                  *|
03360 |*                                                                            *|
03361 |* Returns:                                                                   *|
03362 |*      NOTHING                                                               *|
03363 |*                                                                            *|
03364 \******************************************************************************/
03365 
03366 boolean compare_array_entries(int       bd_idx1,
03367                               int       bd_idx2)
03368 {
03369    long_type    folded_const[MAX_WORDS_FOR_NUMERIC];
03370    int          i;
03371    boolean      same;
03372    int          type_idx;
03373 
03374 
03375    TRACE (Func_Entry, "compare_array_entries", NULL);
03376 
03377    if (bd_idx1 == bd_idx2) {
03378       same = TRUE;
03379    }
03380    else if (bd_idx1 == NULL_IDX || bd_idx2 == NULL_IDX) {
03381       same = FALSE;
03382    }
03383    else {  /* Compare rank, size and class */
03384 
03385       same = (BD_RANK(bd_idx1) == BD_RANK(bd_idx2)) &&
03386              (BD_ARRAY_SIZE(bd_idx1) == BD_ARRAY_SIZE(bd_idx2)) &&
03387              (BD_ARRAY_CLASS(bd_idx1) == BD_ARRAY_CLASS(bd_idx2));
03388 
03389       if (same) { /*  && BD_ARRAY_CLASS(bd_idx1) != Deferred_Shape) { */
03390          type_idx = CG_LOGICAL_DEFAULT_TYPE;
03391 
03392          for (i = 1; i <= BD_RANK(bd_idx1); i++) {
03393 
03394             if (BD_LB_FLD(bd_idx1, i) == CN_Tbl_Idx && 
03395                 BD_LB_FLD(bd_idx2, i) == CN_Tbl_Idx) {
03396 
03397                if (folder_driver((char *)&CN_CONST(BD_LB_IDX(bd_idx1, i)),
03398                                  CN_TYPE_IDX(BD_LB_IDX(bd_idx1, i)),
03399                                  (char *)&CN_CONST(BD_LB_IDX(bd_idx2, i)),
03400                                  CN_TYPE_IDX(BD_LB_IDX(bd_idx2, i)),
03401                                  folded_const,
03402                                  &type_idx,
03403                                  BD_LINE_NUM(bd_idx1),
03404                                  BD_COLUMN_NUM(bd_idx1),
03405                                  2,
03406                                  Ne_Opr)) {
03407                }
03408 
03409                if (THIS_IS_TRUE(folded_const, type_idx)) {
03410                   same = FALSE;
03411                }
03412             }
03413 
03414             if (BD_UB_FLD(bd_idx1, i) == CN_Tbl_Idx && 
03415                 BD_UB_FLD(bd_idx2, i) == CN_Tbl_Idx) {
03416 
03417                if (folder_driver((char *)&CN_CONST(BD_UB_IDX(bd_idx1, i)),
03418                                  CN_TYPE_IDX(BD_UB_IDX(bd_idx1, i)),
03419                                  (char *)&CN_CONST(BD_UB_IDX(bd_idx2, i)),
03420                                  CN_TYPE_IDX(BD_UB_IDX(bd_idx2, i)),
03421                                  folded_const,
03422                                  &type_idx,
03423                                  BD_LINE_NUM(bd_idx1),
03424                                  BD_COLUMN_NUM(bd_idx1),
03425                                  2,
03426                                  Ne_Opr)) {
03427                }
03428 
03429                if (THIS_IS_TRUE(folded_const, type_idx)) {
03430                   same = FALSE;
03431                }
03432             }
03433          }
03434       }
03435    }
03436 
03437    TRACE (Func_Exit, "compare_array_entries", NULL);
03438 
03439    return(same);
03440 
03441 }  /* compare_array_entries */
03442 
03443 /******************************************************************************\
03444 |*                                                                            *|
03445 |* Description:                                                               *|
03446 |*      Initialize next 2 entries in local name table to point to the all     *|
03447 |*      zero word and to the all one word, to act as guards for the name      *|
03448 |*      table search.  Initialize next 2 enteries in the stor block table     *|
03449 |*      to stack and static blocks.                                           *|
03450 |*                                                                            *|
03451 |* Input parameters:                                                          *|
03452 |*      NONE                                                                  *|
03453 |*                                                                            *|
03454 |* Output parameters:                                                         *|
03455 |*      NONE                                                                  *|
03456 |*                                                                            *|
03457 |* Returns:                                                                   *|
03458 |*      NONE                                                                  *|
03459 |*                                                                            *|
03460 \******************************************************************************/
03461 void init_name_and_stor_tbls(int        scp_idx,
03462                              boolean    create_full_scp)
03463 {
03464    int                  ln_idx;
03465    id_str_type          name;
03466    int                  new_idx;
03467 
03468 
03469    TRACE (Func_Entry, "init_name_and_stor_tbls", NULL);
03470 
03471    ln_idx                               = loc_name_tbl_idx + 1;
03472 
03473    TBL_REALLOC_CK(loc_name_tbl, 2);
03474    CLEAR_TBL_NTRY(loc_name_tbl, ln_idx);
03475    LN_NAME_IDX(ln_idx)                  = NAME_POOL_ZERO_IDX; /* Zero word */
03476    LN_NAME_LEN(ln_idx)                  = HOST_BYTES_PER_WORD;
03477    SCP_LN_FW_IDX(scp_idx)               = ln_idx;
03478 
03479    CLEAR_TBL_NTRY(loc_name_tbl, loc_name_tbl_idx);
03480    LN_NAME_IDX(loc_name_tbl_idx)        = NAME_POOL_ONES_IDX; /* Ones word   */
03481    LN_NAME_LEN(loc_name_tbl_idx)        = HOST_BYTES_PER_WORD;
03482    SCP_LN_LW_IDX(scp_idx)               = loc_name_tbl_idx;
03483 
03484    if (create_full_scp) {
03485 
03486       create_hidden_name_tbl(scp_idx);
03487 
03488       /* Create storage blocks for static, stack, and darg storage        */
03489       /* segments.  Fields in the scope table point to these stor blocks. */
03490 
03491       /* Create an entry for local data block.                            */
03492 
03493       CREATE_ID(name, sb_name[Data_Blk], sb_len[Data_Blk]);
03494       new_idx                   = ntr_stor_blk_tbl(name.string,
03495                                                    sb_len[Data_Blk],
03496                                                    stmt_start_line,
03497                                                    stmt_start_col,
03498                                                    Static_Local);
03499       SCP_SB_STATIC_IDX(scp_idx)        = new_idx;
03500       SB_PAD_BLK(new_idx)               = cmd_line_flags.pad;
03501 
03502 # if defined(_SPLIT_STATIC_STORAGE_2) || defined(_SPLIT_STATIC_STORAGE_3)
03503 
03504       /* Create an entry for local data block for data initialized vars.  */
03505 
03506       CREATE_ID(name, sb_name[Data_Init_Blk], sb_len[Data_Init_Blk]);
03507       new_idx                           = ntr_stor_blk_tbl(name.string,
03508                                                           sb_len[Data_Init_Blk],
03509                                                           stmt_start_line,
03510                                                           stmt_start_col,
03511                                                           Static_Named);
03512       SCP_SB_STATIC_INIT_IDX(scp_idx)   = new_idx;
03513       SB_PAD_BLK(new_idx)               = cmd_line_flags.pad;
03514 
03515 # if defined(_SPLIT_STATIC_STORAGE_3)
03516       CREATE_ID(name, sb_name[Data_Uninit_Blk], sb_len[Data_Uninit_Blk]);
03517       new_idx                           = ntr_stor_blk_tbl(name.string,
03518                                                         sb_len[Data_Uninit_Blk],
03519                                                         stmt_start_line,
03520                                                         stmt_start_col,
03521                                                         Static_Named);
03522       SCP_SB_STATIC_UNINIT_IDX(scp_idx) = new_idx;
03523       SB_PAD_BLK(new_idx)               = cmd_line_flags.pad;
03524 # endif
03525 
03526 # else
03527       SCP_SB_STATIC_INIT_IDX(scp_idx)   = SCP_SB_STATIC_IDX(scp_idx);
03528       SCP_SB_STATIC_UNINIT_IDX(scp_idx) = SCP_SB_STATIC_IDX(scp_idx);
03529 # endif
03530 
03531       if (cmd_line_flags.pad_amount != 0) {
03532 
03533 # if defined(_SPLIT_STATIC_STORAGE_3)
03534          SB_PAD_AMOUNT(SCP_SB_STATIC_UNINIT_IDX(scp_idx)) =
03535                                               cmd_line_flags.pad_amount;
03536          SB_PAD_AMOUNT_SET(SCP_SB_STATIC_UNINIT_IDX(scp_idx))     = TRUE;
03537 # endif
03538 
03539 # if defined(_SPLIT_STATIC_STORAGE_2)
03540 
03541          SB_PAD_AMOUNT(SCP_SB_STATIC_INIT_IDX(scp_idx)) = 
03542                                               cmd_line_flags.pad_amount;
03543          SB_PAD_AMOUNT_SET(SCP_SB_STATIC_INIT_IDX(scp_idx)) = TRUE;
03544 # endif
03545          SB_PAD_AMOUNT(SCP_SB_STATIC_IDX(scp_idx))= cmd_line_flags.pad_amount;
03546          SB_PAD_AMOUNT_SET(SCP_SB_STATIC_IDX(scp_idx))  = TRUE;
03547       }
03548 
03549       /* Create an entry for a local stack block                          */
03550 
03551       CREATE_ID(name, sb_name[Stack_Blk], sb_len[Stack_Blk]);
03552       new_idx                   = ntr_stor_blk_tbl(name.string,
03553                                                    sb_len[Stack_Blk],
03554                                                    stmt_start_line,
03555                                                    stmt_start_col,
03556                                                    Stack);
03557       SCP_SB_STACK_IDX(scp_idx) = new_idx;
03558 
03559       /* Create an entry for a local darg block.                          */
03560 
03561       CREATE_ID(name, sb_name[Dargs_Blk], sb_len[Dargs_Blk]);
03562       new_idx                   = ntr_stor_blk_tbl(name.string,
03563                                                    sb_len[Dargs_Blk],
03564                                                    stmt_start_line,
03565                                                    stmt_start_col,
03566                                                    Formal);
03567       SCP_SB_DARG_IDX(scp_idx)  = new_idx;
03568 
03569       CREATE_ID(name, sb_name[Based_Blk], sb_len[Based_Blk]);
03570       new_idx                   = ntr_stor_blk_tbl(name.string, 
03571                                                    sb_len[Based_Blk],
03572                                                    stmt_start_line,
03573                                                    stmt_start_col,
03574                                                    Based);
03575       SCP_SB_BASED_IDX(scp_idx) = new_idx;
03576    }
03577    
03578    TRACE (Func_Exit, "init_name_and_stor_tbls", NULL);
03579 
03580    return;
03581 
03582 }  /* init_name_and_stor_tbls */
03583 
03584 # ifdef _DEBUG
03585 
03586 /******************************************************************************\
03587 |*                                                                            *|
03588 |* Description:                                                               *|
03589 |*      Issue internal err msg, if there is an attr table variant problem.    *|
03590 |*      NOTE:  been_here_before is a way of stopping a nasty infinite loop    *|
03591 |*             if you get an error in a field, and you try to print it out    *|
03592 |*             as part of the error output.                                   *|
03593 |*                                                                            *|
03594 |* Input parameters:                                                          *|
03595 |*      err_str  -> A string ptr to a description of the field in trouble.    *|
03596 |*      attr_idx -> Index of the attr entry in trouble.                       *|
03597 |*                                                                            *|
03598 |* Output parameters:                                                         *|
03599 |*      NONE                                                                  *|
03600 |*                                                                            *|
03601 |* Returns:                                                                   *|
03602 |*      NONE                                                                  *|
03603 |*                                                                            *|
03604 \******************************************************************************/
03605 attr_tbl_type   *sytb_var_error(char    *err_str,
03606                                 int      attr_idx)
03607 {
03608 static   int    been_here_before;
03609 
03610    if (been_here_before == 0) {
03611       been_here_before = 1;
03612       print_at_all(attr_idx);
03613       PRINTMSG(stmt_start_line, 42, Internal,stmt_start_col, attr_idx, err_str);
03614    }
03615    return(attr_tbl);
03616 }
03617 # endif
03618 
03619 
03620 # ifdef _DEBUG
03621 /******************************************************************************\
03622 |*                                                                            *|
03623 |* Description:                                                               *|
03624 |*      Issue internal err msg, if there is an attr aux table variant problem.*|
03625 |*      NOTE:  been_here_before is a way of stopping a nasty infinite loop    *|
03626 |*             if you get an error in a field, and you try to print it out    *|
03627 |*             as part of the error output.                                   *|
03628 |*                                                                            *|
03629 |* Input parameters:                                                          *|
03630 |*      err_str  -> A string ptr to a description of the field in trouble.    *|
03631 |*      attr_idx -> Index of the attr aux entry in trouble.                   *|
03632 |*                                                                            *|
03633 |* Output parameters:                                                         *|
03634 |*      NONE                                                                  *|
03635 |*                                                                            *|
03636 |* Returns:                                                                   *|
03637 |*      NONE                                                                  *|
03638 |*                                                                            *|
03639 \******************************************************************************/
03640 attr_aux_tbl_type       *attr_aux_var_error(char        *err_str,
03641                                             int  attr_idx)
03642 {
03643 static   int    been_here_before;
03644 
03645    if (been_here_before == 0) {
03646       been_here_before = 1;
03647       print_at_all(attr_idx);
03648       PRINTMSG(stmt_start_line, 42, Internal,stmt_start_col, attr_idx, err_str);
03649    }
03650    return(attr_aux_tbl);
03651 }
03652 # endif
03653 
03654 # ifdef _DEBUG
03655 /******************************************************************************\
03656 |*                                                                            *|
03657 |* Description:                                                               *|
03658 |*      Issue internal err msg, if there is a bounds tbl variant problem.     *|
03659 |*      NOTE:  been_here_before is a way of stopping a nasty infinite loop    *|
03660 |*             if you get an error in a field, and you try to print it out    *|
03661 |*             as part of the error output.                                   *|
03662 |*                                                                            *|
03663 |* Input parameters:                                                          *|
03664 |*      err_str  -> A string ptr to a description of the field in trouble.    *|
03665 |*      bd_idx   -> Index of the bounds entry in trouble.                     *|
03666 |*                                                                            *|
03667 |* Output parameters:                                                         *|
03668 |*      NONE                                                                  *|
03669 |*                                                                            *|
03670 |* Returns:                                                                   *|
03671 |*      NONE                                                                  *|
03672 |*                                                                            *|
03673 \******************************************************************************/
03674 bounds_tbl_type   *bd_var_error(char    *err_str,
03675                                 int      bd_idx)
03676 {
03677 static   int    been_here_before;
03678 
03679    if (been_here_before == 0) {
03680       been_here_before = 1;
03681       print_bd(bd_idx);
03682       PRINTMSG(stmt_start_line, 1367, Internal,stmt_start_col, bd_idx, err_str);
03683    }
03684    return(bounds_tbl);
03685 }
03686 # endif
03687 
03688 # ifdef _DEBUG
03689 /******************************************************************************\
03690 |*                                                                            *|
03691 |* Description:                                                               *|
03692 |*      Issue internal err msg, if there is an ir list tbl variant problem.   *|
03693 |*      NOTE:  been_here_before is a way of stopping a nasty infinite loop    *|
03694 |*             if you get an error in a field, and you try to print it out    *|
03695 |*             as part of the error output.                                   *|
03696 |*                                                                            *|
03697 |* Input parameters:                                                          *|
03698 |*      err_str  -> A string ptr to a description of the field in trouble.    *|
03699 |*      attr_idx -> Index of the attr entry in trouble.                       *|
03700 |*                                                                            *|
03701 |* Output parameters:                                                         *|
03702 |*      NONE                                                                  *|
03703 |*                                                                            *|
03704 |* Returns:                                                                   *|
03705 |*      NONE                                                                  *|
03706 |*                                                                            *|
03707 \******************************************************************************/
03708 ir_list_tbl_type   *ir_list_var_error(char    *err_str,
03709                                       int      il_idx)
03710 {
03711 static   int    been_here_before;
03712 
03713    if (been_here_before == 0) {
03714       been_here_before = 1;
03715       print_il(il_idx);
03716       PRINTMSG(stmt_start_line, 782, Internal,stmt_start_col, il_idx, err_str);
03717    }
03718    return(ir_list_tbl);
03719 }
03720 # endif
03721 
03722 # ifdef _DEBUG
03723 
03724 /******************************************************************************\
03725 |*                                                                            *|
03726 |* Description:                                                               *|
03727 |*      Issue internal err msg, if there is a global attr table variant       *|
03728 |*      problem.                                                              *|
03729 |*      NOTE:  been_here_before is a way of stopping a nasty infinite loop    *|
03730 |*             if you get an error in a field, and you try to print it out    *|
03731 |*             as part of the error output.                                   *|
03732 |*                                                                            *|
03733 |* Input parameters:                                                          *|
03734 |*      err_str  -> A string ptr to a description of the field in trouble.    *|
03735 |*      attr_idx -> Index of the global attr entry in trouble.                *|
03736 |*                                                                            *|
03737 |* Output parameters:                                                         *|
03738 |*      NONE                                                                  *|
03739 |*                                                                            *|
03740 |* Returns:                                                                   *|
03741 |*      NONE                                                                  *|
03742 |*                                                                            *|
03743 \******************************************************************************/
03744 global_attr_tbl_type    *ga_var_error(char      *err_str,
03745                                       int        ga_idx)
03746 {
03747 static   int    been_here_before;
03748 
03749    if (been_here_before == 0) {
03750       been_here_before = 1;
03751       print_ga(ga_idx);
03752       PRINTMSG(stmt_start_line, 42, Internal,stmt_start_col, ga_idx, err_str);
03753    }
03754    return(global_attr_tbl);
03755 }
03756 # endif
03757 
03758 /******************************************************************************\
03759 |*                                                                            *|
03760 |* Description:                                                               *|
03761 |*      Internal and debug labels start at @00001.                            *|
03762 |*      Internal labels are numbered @00001 and debug labels are @D00001.     *|
03763 |*      This routine creates an internal label, enters the label into the     *|
03764 |*      symbol table and sets the attribute fields to reflect an internal lbl.*|
03765 |*                                                                            *|
03766 |* Input parameters:                                                          *|
03767 |*      label_type      The type of label - Lbl_Internal or Lbl_Debug.        *|
03768 |*      label_line      The global line number of the label definition.       *|
03769 |*                                                                            *|
03770 |* Output parameters:                                                         *|
03771 |*       NONE                                                                 *|
03772 |*                                                                            *|
03773 |* Returns:                                                                   *|
03774 |*      lbl_attr_idx    Index to symbol table attribute entry for this lable. *|
03775 |*                                                                            *|
03776 \******************************************************************************/
03777 
03778 int gen_internal_lbl (int               label_line)
03779 
03780 {
03781    int                  attr_idx;
03782    int                  length;
03783    id_str_type          name;
03784 
03785 
03786    TRACE (Func_Entry, "gen_internal_lbl", NULL);
03787 
03788    curr_internal_lbl++;
03789 
03790    CREATE_ID(name, " ", 1);
03791 
03792 # if defined(_NO_AT_SIGN_IN_NAMES)
03793    length = (int) sprintf(name.string, "l.%05d", curr_internal_lbl);
03794 # else
03795    length = (int) sprintf(name.string, "l@%05d", curr_internal_lbl);
03796 # endif
03797 
03798 # ifdef _HOST32
03799    length = strlen(name.string);
03800 # endif
03801 
03802 
03803 # ifdef _DEBUG  /* Have reached the maximum label - make it and issue message */
03804    if (curr_internal_lbl > MAX_GENERATED_LABELS) {
03805       PRINTMSG(label_line, 364, Limit, 0, MAX_GENERATED_LABELS);
03806    }
03807 # endif
03808 
03809    attr_idx                     = ntr_local_attr_list(name.string,
03810                                                       length,
03811                                                       label_line,
03812                                                       0);
03813    AT_OBJ_CLASS(attr_idx)       = Label;
03814    AT_COMPILER_GEND(attr_idx)   = TRUE;
03815    AT_REFERENCED(attr_idx)      = Referenced;
03816    ATL_CLASS(attr_idx)          = Lbl_Internal;
03817 
03818    if (! cdir_switches.vector) {
03819       ATL_NOVECTOR(attr_idx)  = TRUE;
03820    }
03821 
03822    /* Debug class is set to Ldbg_None by default for all internal labels */
03823 
03824    TRACE (Func_Exit, "gen_internal_lbl", NULL);
03825 
03826    return (attr_idx);
03827 
03828 }  /* gen_internal_lbl */
03829 
03830 /******************************************************************************\
03831 |*                                                                            *|
03832 |* Description:                                                               *|
03833 |*       Calculates the storage size in bits for the object represented by    *|
03834 |*       the attr.  This means the total size of the array or structure or    *|
03835 |*       pointer or whatever.  If a total size is requested, it is checked    *|
03836 |*       against maximum memory size available on the machine.                *|
03837 |*                                                                            *|
03838 |* Input parameters:                                                          *|
03839 |*       attr_idx         -> Attr index of item to find size of.              *|
03840 |*       all_elements     -> TRUE if a total size is requested.  If this is   *|
03841 |*                           FALSE, just return the size of one element.      *|
03842 |*       check_array_size -> TRUE if check all constant sized things for max  *|
03843 |*                           memory violations.                               *|
03844 |*                           FALSE, just check non explicit shape constant    *|
03845 |*                           size arrays for memory violations.  Need this    *|
03846 |*                           check because we call this more than once for    *|
03847 |*                           explicit shape constant arrays.                  *|
03848 |*                                                                            *|
03849 |* Output parameters:                                                         *|
03850 |*       NONE                                                                 *|
03851 |*                                                                            *|
03852 |* Returns:                                                                   *|
03853 |*       A constant table index of the bit size.                              *|
03854 |*                                                                            *|
03855 \******************************************************************************/
03856 size_offset_type        stor_bit_size_of(int             attr_idx,
03857                                          boolean         all_elements,
03858                                          boolean         check_array_size)
03859 {
03860    int                  bd_idx;
03861    size_offset_type     constant;
03862    boolean              issue_msg;
03863    size_offset_type     length;
03864    size_offset_type     max_storage_size;
03865    long                 num;
03866    size_offset_type     num_chars;
03867    size_offset_type     result;
03868    int                  type_idx;
03869 
03870 # if defined(GENERATE_WHIRL)
03871    long64               max_size;
03872 # endif
03873 
03874 
03875    TRACE (Func_Entry, "stor_bit_size_of", NULL);
03876 
03877    constant.type_idx    = CG_INTEGER_DEFAULT_TYPE;
03878    constant.fld         = NO_Tbl_Idx;
03879    C_TO_F_INT(constant.constant, 0, CG_INTEGER_DEFAULT_TYPE);
03880 
03881    if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
03882 
03883       if (ATD_IM_A_DOPE(attr_idx)) {
03884          num =  (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) ?
03885                 (TARGET_BITS_PER_WORD * (DV_HD_WORD_SIZE +
03886                     (DV_DIM_WORD_SIZE * 
03887                           (long) BD_RANK(ATD_ARRAY_IDX(attr_idx))))) :
03888                 (DV_HD_WORD_SIZE * TARGET_BITS_PER_WORD);
03889          C_TO_F_INT(constant.constant, num, CG_INTEGER_DEFAULT_TYPE);
03890       }
03891       else {
03892 
03893          type_idx = ATD_TYPE_IDX(attr_idx);
03894 
03895          switch (TYP_TYPE(type_idx)) {
03896          case Character:
03897 
03898             if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
03899                constant.fld             = CN_Tbl_Idx;
03900                constant.idx             = CN_INTEGER_CHAR_BIT_IDX;
03901                num_chars.fld            = TYP_FLD(type_idx);
03902                num_chars.idx            = TYP_IDX(type_idx);
03903 
03904                /* Assumption is that this will always be ok.  Char  */
03905                /* length is checked before we get to this point.    */
03906  
03907                size_offset_binary_calc(&num_chars, 
03908                                        &constant,
03909                                         Mult_Opr,
03910                                        &constant);
03911             }
03912 
03913             break;
03914 
03915          case Structure:
03916 
03917             constant.fld        = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
03918             constant.idx        = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
03919             break;
03920 
03921          case Typeless :
03922             C_TO_F_INT(constant.constant, TYP_BIT_LEN(type_idx), Integer_8);
03923             constant.type_idx   = Integer_8;
03924 
03925             align_bit_length(&constant, TARGET_BITS_PER_WORD);
03926             break;
03927 
03928          default:
03929 
03930 # ifdef _DEBUG
03931             if (TYP_LINEAR(type_idx) == Err_Res) {
03932                PRINTMSG(AT_DEF_LINE(attr_idx), 810, Internal,
03933                         AT_DEF_COLUMN(attr_idx),
03934                         AT_OBJ_NAME_PTR(attr_idx));
03935             }
03936 # endif
03937             C_TO_F_INT(constant.constant, 
03938                        storage_bit_size_tbl[TYP_LINEAR(type_idx)], 
03939                        CG_INTEGER_DEFAULT_TYPE);
03940          }
03941 
03942          bd_idx = ATD_ARRAY_IDX(attr_idx);
03943 
03944          if (all_elements) {
03945 
03946             if (bd_idx != NULL_IDX) {
03947 
03948                /* If this isn't an explicit shape, constant bound array, */
03949                /* num_array_elements becomes 0.                          */
03950 
03951                if (BD_ARRAY_SIZE(bd_idx) == Constant_Size ||
03952                    BD_ARRAY_SIZE(bd_idx) == Symbolic_Constant_Size) {
03953                   length.fld    = BD_LEN_FLD(bd_idx);
03954                   length.idx    = BD_LEN_IDX(bd_idx);
03955 
03956                   if (!size_offset_binary_calc(&length,
03957                                                &constant,
03958                                                 Mult_Opr,
03959                                                &constant)) {
03960 
03961                      AT_DCL_ERR(attr_idx)       = TRUE;
03962                   }
03963                }
03964                else {
03965                   constant.fld  = CN_Tbl_Idx;
03966                   constant.idx  =CN_INTEGER_TWO_IDX;  
03967                }
03968             }
03969 
03970 # if defined(_CHECK_MAX_MEMORY)
03971 
03972             if (!ATD_AUXILIARY(attr_idx) && 
03973                 constant.fld == NO_Tbl_Idx &&
03974                 (check_array_size ||
03975                  bd_idx == NULL_IDX ||
03976                   BD_ARRAY_CLASS(bd_idx) != Explicit_Shape && 
03977                   FALSE ||  
03978                  BD_ARRAY_SIZE(bd_idx) != Constant_Size)) {
03979 
03980                /* We cannot check arrays based on N$PE.              */
03981                /* Also, all explicit shape constant size arrays were */
03982                /* checked in array_dim_resolution.                   */
03983 
03984                issue_msg                = FALSE;
03985                max_storage_size.fld     = NO_Tbl_Idx;
03986 
03987 #              if defined(GENERATE_WHIRL)
03988                   max_storage_size.type_idx     = Integer_8;
03989 
03990                   if (cmd_line_flags.s_pointer8) {
03991                      max_size = 0400000000000000000LL;
03992                      C_TO_F_INT(max_storage_size.constant,
03993                                 max_size,
03994                                 Integer_8);
03995  
03996                   }
03997                   else {  /* 2 ** 32 currently */
03998                      C_TO_F_INT(max_storage_size.constant, pow(2,32),Integer_8);
03999                   }
04000 
04001 #              else
04002                   max_storage_size.type_idx     = Integer_8;
04003 
04004 #                 if defined(_TARGET32)
04005                      C_TO_F_INT(max_storage_size.constant,
04006                                 2147483616,
04007                                 Integer_8);
04008 #                 else
04009                      C_TO_F_INT(max_storage_size.constant,
04010                                (MAX_STORAGE_SIZE_IN_WORDS*TARGET_BITS_PER_WORD),
04011                                 Integer_8);
04012 #                 endif
04013 #              endif
04014 
04015                size_offset_logical_calc(&constant, 
04016                                         &max_storage_size, 
04017                                          Gt_Opr,
04018                                         &result);
04019 
04020                issue_msg = THIS_IS_TRUE(result.constant, result.type_idx);
04021 
04022                if (issue_msg) {
04023 
04024 # if defined(GENERATE_WHIRL)
04025 
04026                   if (cmd_line_flags.s_pointer8) {
04027                      constant   = max_storage_size;
04028  
04029                      if (!AT_DCL_ERR(attr_idx)) {
04030                         AT_DCL_ERR(attr_idx)    = TRUE;
04031 
04032                         if (AT_COMPILER_GEND(attr_idx)) {
04033                            ISSUE_EXPR_SIZE_EXCEEDED_MSG(AT_DEF_LINE(attr_idx),
04034                                                         AT_DEF_COLUMN(attr_idx),
04035                                                         Error);
04036                         }
04037                         else {
04038                            ISSUE_STORAGE_SIZE_EXCEEDED_MSG(attr_idx, Error);
04039                         }
04040                      }
04041                   }
04042                   else {
04043                      ATD_TOO_BIG_FOR_DV(attr_idx) = TRUE;
04044                   }
04045 # else
04046 
04047                   if (target_t3e) {
04048 
04049                      if (AT_COMPILER_GEND(attr_idx)) {
04050                         ISSUE_EXPR_SIZE_EXCEEDED_MSG(AT_DEF_LINE(attr_idx),
04051                                                      AT_DEF_COLUMN(attr_idx),
04052                                                      Warning);
04053                      }
04054                      else {
04055                         ISSUE_STORAGE_SIZE_EXCEEDED_MSG(attr_idx, Warning);
04056                      }
04057                   }
04058                   else {
04059                      constant = max_storage_size;
04060 
04061                      if (!AT_DCL_ERR(attr_idx)) {
04062                         AT_DCL_ERR(attr_idx)       = TRUE;
04063 
04064                         if (AT_COMPILER_GEND(attr_idx)) {
04065                            ISSUE_EXPR_SIZE_EXCEEDED_MSG(AT_DEF_LINE(attr_idx),
04066                                                         AT_DEF_COLUMN(attr_idx),
04067                                                         Error);
04068                         }
04069                         else {
04070                            ISSUE_STORAGE_SIZE_EXCEEDED_MSG(attr_idx, Error);
04071                         }
04072                      }
04073                   }
04074 # endif
04075                }
04076             }
04077 # endif
04078          }
04079       }
04080    }
04081 
04082    TRACE (Func_Exit, "stor_bit_size_of", NULL);
04083 
04084    return(constant);
04085 
04086 }  /* stor_bit_size_of */
04087 
04088 /******************************************************************************\
04089 |*                                                                            *|
04090 |* Description:                                                               *|
04091 |*      Compiler temps start at $T1 and go on indefinitely.  (If we start     *|
04092 |*      generating millions of temps, table sizes are going to blow.)         *|
04093 |*      This does NOT link tmps into the tmp list, the caller must do this    *|
04094 |*      if they need to be in the list.  SET YOUR OWN STORAGE BLOCK AND       *|
04095 |*      TYPE.  This routine does not set them.                                *|
04096 |*                                                                            *|
04097 |* Input parameters:                                                          *|
04098 |*      tmp_line         The global line number for the tmp definition.       *|
04099 |*      tmp_column       The column number for the tmp definition.            *|
04100 |*      scope            If in a parallel region, set scope based on this     *|
04101 |*                       Enum values are {Priv, Shared}                       *|
04102 |*      add_to_attr_list TRUE means add this to the local SCP_ATTR_LIST       *|
04103 |*                       FALSE means don't add.  This means that the tmp      *|
04104 |*                       will not go through attr_semantics, be written out   *|
04105 |*                       to a module or go through the interface unless       *|
04106 |*                       the temp is special cased.                           *|
04107 |*                                                                            *|
04108 |* Output parameters:                                                         *|
04109 |*       NONE                                                                 *|
04110 |*                                                                            *|
04111 |* Returns:                                                                   *|
04112 |*      attr_idx        Index to symbol table attribute entry for this tmp.   *|
04113 |*                                                                            *|
04114 \******************************************************************************/
04115 
04116 int gen_compiler_tmp (int               tmp_line,
04117                       int               tmp_column,
04118                       task_scope_type   scope,
04119                       boolean           add_to_attr_list)
04120 
04121 {
04122                 int             attr_idx;
04123                 int             length;
04124                 int             length1;
04125    static       int             curr_tmp        = 0;
04126                 id_str_type     name;
04127                 id_str_type     name1;
04128                 int             np_idx;
04129                 long            tst_val;
04130                 int             idx;
04131                 boolean         found_tmp_num;
04132 
04133 
04134    TRACE (Func_Entry, "gen_compiler_tmp", NULL);
04135 
04136    curr_tmp++;
04137    found_tmp_num = FALSE;
04138 
04139  while (!found_tmp_num) {
04140 
04141    CREATE_ID(name, " ", 1);
04142    CREATE_ID(name1, " ", 1);
04143 
04144 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
04145    length = sprintf(name.string, "t$%d", curr_tmp);
04146    length1 = sprintf(name1.string,"T$%d", curr_tmp);
04147 # else
04148 /*   sprintf(name.string, "t$%d", curr_tmp);*/
04149    sprintf(name.string, "t__%d", curr_tmp);
04150 /*   sprintf(name1.string, "T$%d", curr_tmp);*/
04151    sprintf(name1.string, "T__%d", curr_tmp);
04152 
04153    length = strlen(name.string);
04154    length1 = strlen(name1.string);
04155 # endif
04156 
04157 /* add here to see if there is same name aready in the symbol table 
04158    if there is same name such as T$2 or t$2 already int the table
04159    then curr_temp++  */
04160    
04161    tst_val = srch_name_tbl(name.string,
04162                            length,
04163                            &idx,
04164                            loc_name_tbl,
04165                            name_pool,
04166                            SCP_LN_FW_IDX(curr_scp_idx),
04167                            SCP_LN_LW_IDX(curr_scp_idx));
04168    if (tst_val ==0 )
04169          ++curr_tmp;
04170    else  {
04171       tst_val = srch_name_tbl(name1.string, 
04172                               length1,
04173                               &idx,
04174                               loc_name_tbl,
04175                               name_pool,
04176                               SCP_LN_FW_IDX(curr_scp_idx),
04177                               SCP_LN_LW_IDX(curr_scp_idx)); 
04178       if (tst_val == 0)
04179              ++curr_tmp;
04180       else found_tmp_num = TRUE;
04181     }
04182 }
04183       
04184 
04185      
04186  
04187    if (add_to_attr_list) {
04188       attr_idx                  = ntr_local_attr_list(name.string,
04189                                                       length,
04190                                                       tmp_line,
04191                                                       tmp_column);
04192    }
04193    else {
04194       NTR_NAME_POOL(&(name.words[0]), length, np_idx);
04195 
04196       NTR_ATTR_TBL(attr_idx);
04197       AT_DEF_LINE(attr_idx)     = tmp_line;
04198       AT_DEF_COLUMN(attr_idx)   = tmp_column;
04199