|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
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 AT_NAME_LEN(attr_idx) = length; 04200 AT_NAME_IDX(attr_idx) = np_idx; 04201 } 04202 04203 ATD_CLASS(attr_idx) = Compiler_Tmp; 04204 AT_REFERENCED(attr_idx) = Referenced; 04205 AT_COMPILER_GEND(attr_idx) = TRUE; 04206 AT_TYPED(attr_idx) = TRUE; /* Prevent implicit errors */ 04207 04208 if (scope == Priv) { 04209 ADD_TMP_TO_PRIVATE_LIST(attr_idx); 04210 } 04211 else { 04212 ADD_TMP_TO_SHARED_LIST(attr_idx); 04213 } 04214 04215 TRACE (Func_Exit, "gen_compiler_tmp", NULL); 04216 04217 return (attr_idx); 04218 04219 } /* gen_compiler_tmp */ 04220 04221 04222 /******************************************************************************\ 04223 |* Description: *| 04224 |* Compiler temps start at s$1 and go on for Assumed Size array's *| 04225 |* upper bound. *| 04226 |* This does NOT link tmps into the tmp list, the caller must do this *| 04227 |* if they need to be in the list. SET YOUR OWN STORAGE BLOCK AND *| 04228 |* TYPE. This routine does not set them. *| 04229 |* *| 04230 |* Input parameters: *| 04231 |* tmp_line The global line number for the tmp definition. *| 04232 |* tmp_column The column number for the tmp definition. *| 04233 |* scope If in a parallel region, set scope based on this *| 04234 |* Enum values are {Priv, Shared} *| 04235 |* add_to_attr_list TRUE means add this to the local SCP_ATTR_LIST *| 04236 |* FALSE means don't add. This means that the tmp *| 04237 |* will not go through attr_semantics, be written out *| 04238 |* to a module or go through the interface unless *| 04239 |* the temp is special cased. *| 04240 |* *| 04241 |* Output parameters: *| 04242 |* NONE *| 04243 |* *| 04244 |* Returns: *| 04245 |* attr_idx Index to symbol table attribute entry for this tmp. *| 04246 |* *| 04247 \******************************************************************************/ 04248 04249 int gen_compiler_star (int tmp_line, 04250 int tmp_column, 04251 task_scope_type scope, 04252 boolean add_to_attr_list) 04253 04254 04255 { 04256 int attr_idx; 04257 int length; 04258 static int curr_tmp = 0; 04259 id_str_type name; 04260 int np_idx; 04261 04262 04263 TRACE (Func_Entry, "gen_compiler_star", NULL); 04264 04265 curr_tmp++; 04266 04267 CREATE_ID(name, " ", 1); 04268 04269 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 04270 length = sprintf(name.string, " s$%d", curr_tmp); 04271 # else 04272 sprintf(name.string, "s$%d", curr_tmp); 04273 length = strlen(name.string); 04274 # endif 04275 04276 if (add_to_attr_list) { 04277 attr_idx = ntr_local_attr_list(name.string, 04278 length, 04279 tmp_line, 04280 tmp_column); 04281 } 04282 else { 04283 NTR_NAME_POOL(&(name.words[0]), length, np_idx); 04284 04285 NTR_ATTR_TBL(attr_idx); 04286 AT_DEF_LINE(attr_idx) = tmp_line; 04287 AT_DEF_COLUMN(attr_idx) = tmp_column; 04288 AT_NAME_LEN(attr_idx) = length; 04289 AT_NAME_IDX(attr_idx) = np_idx; 04290 } 04291 04292 ATD_CLASS(attr_idx) = Compiler_Tmp; 04293 AT_REFERENCED(attr_idx) = Referenced; 04294 AT_COMPILER_GEND(attr_idx) = TRUE; 04295 AT_TYPED(attr_idx) = TRUE; /* Prevent implicit errors */ 04296 04297 if (scope == Priv) { 04298 ADD_TMP_TO_PRIVATE_LIST(attr_idx); 04299 } 04300 else { 04301 ADD_TMP_TO_SHARED_LIST(attr_idx); 04302 } 04303 04304 TRACE (Func_Exit, "gen_compiler_star", NULL); 04305 04306 return (attr_idx); 04307 04308 } /* gen_compiler_star*/ 04309 04310 /******************************************************************************\ 04311 |* *| 04312 |* Description: *| 04313 |* Compiler temps start at u$1 and go on for Assumed Shape array's *| 04314 |* upper bound. *| 04315 |* This does NOT link tmps into the tmp list, the caller must do this *| 04316 |* if they need to be in the list. SET YOUR OWN STORAGE BLOCK AND *| 04317 |* TYPE. This routine does not set them. *| 04318 |* *| 04319 |* Input parameters: *| 04320 |* tmp_line The global line number for the tmp definition. *| 04321 |* tmp_column The column number for the tmp definition. *| 04322 |* scope If in a parallel region, set scope based on this *| 04323 |* Enum values are {Priv, Shared} *| 04324 |* add_to_attr_list TRUE means add this to the local SCP_ATTR_LIST *| 04325 |* FALSE means don't add. This means that the tmp *| 04326 |* will not go through attr_semantics, be written out *| 04327 |* to a module or go through the interface unless *| 04328 |* the temp is special cased. *| 04329 |* *| 04330 |* Output parameters: *| 04331 |* NONE *| 04332 |* *| 04333 |* Returns: *| 04334 |* attr_idx Index to symbol table attribute entry for this tmp. *| 04335 |* *| 04336 \******************************************************************************/ 04337 04338 int gen_compiler_upbd (int tmp_line, 04339 int tmp_column, 04340 task_scope_type scope, 04341 boolean add_to_attr_list) 04342 04343 { 04344 int attr_idx; 04345 int length; 04346 static int curr_tmp = 0; 04347 id_str_type name; 04348 int np_idx; 04349 04350 04351 TRACE (Func_Entry, "gen_compiler_upbd", NULL); 04352 04353 curr_tmp++; 04354 04355 CREATE_ID(name, " ", 1); 04356 04357 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 04358 length = sprintf(name.string, " u$%d", curr_tmp); 04359 # else 04360 sprintf(name.string, "u$%d", curr_tmp); 04361 length = strlen(name.string); 04362 # endif 04363 04364 if (add_to_attr_list) { 04365 attr_idx = ntr_local_attr_list(name.string, 04366 length, 04367 tmp_line, 04368 tmp_column); 04369 } 04370 else { 04371 NTR_NAME_POOL(&(name.words[0]), length, np_idx); 04372 04373 NTR_ATTR_TBL(attr_idx); 04374 AT_DEF_LINE(attr_idx) = tmp_line; 04375 AT_DEF_COLUMN(attr_idx) = tmp_column; 04376 AT_NAME_LEN(attr_idx) = length; 04377 AT_NAME_IDX(attr_idx) = np_idx; 04378 } 04379 ATD_CLASS(attr_idx) = Compiler_Tmp; 04380 AT_REFERENCED(attr_idx) = Referenced; 04381 AT_COMPILER_GEND(attr_idx) = TRUE; 04382 AT_TYPED(attr_idx) = TRUE; /* Prevent implicit errors */ 04383 04384 if (scope == Priv) { 04385 ADD_TMP_TO_PRIVATE_LIST(attr_idx); 04386 } 04387 else { 04388 ADD_TMP_TO_SHARED_LIST(attr_idx); 04389 } 04390 04391 TRACE (Func_Exit, "gen_compiler_upbd", NULL); 04392 04393 return (attr_idx); 04394 04395 } /* gen_compiler_upbd*/ 04396 04397 04398 /******************************************************************************\ 04399 |* *| 04400 |* Description: *| 04401 |* Change a data object to a program unit. If the input is Function, it *| 04402 |* creates a function result with the data object becoming the function *| 04403 |* result of the program unit. If input is Subroutine it creates a *| 04404 |* a program unit marked Pgm_Unknown. If input is Pgm_Unknown, it will *| 04405 |* switch the attr to a Function, if there is anything set on the attr *| 04406 |* which would trigger a Function set. It creates a dummy_proc, if the *| 04407 |* data object is a dummy argument. This routine assumes that all *| 04408 |* semantic errors are issued before the change occurs and that the attr *| 04409 |* is semantically correct to become a function result, a Pgm_Unit, or *| 04410 |* a Subroutine. *| 04411 |* *| 04412 |* Input parameters: *| 04413 |* attr_idx - index of attribute entry to change. *| 04414 |* pgm_unit - Set to Function, Subroutine or Pgm_Unknown *| 04415 |* proc_type- Set to type procedure type for this item. If it is set to *| 04416 |* Extern_Proc, but this is a dummy argument, it becomes *| 04417 |* Dummy_Proc. *| 04418 |* *| 04419 |* Output parameters: *| 04420 |* NONE *| 04421 |* *| 04422 |* Returns: *| 04423 |* NOTHING *| 04424 |* *| 04425 \******************************************************************************/ 04426 04427 void chg_data_obj_to_pgm_unit(int attr_idx, 04428 pgm_unit_type pgm_unit, 04429 atp_proc_type proc_type) 04430 04431 { 04432 int new_at_idx; 04433 04434 04435 TRACE (Func_Entry, "chg_data_obj_to_pgm_unit", NULL); 04436 04437 /* If intent is set, an error should have been issued. The intentness is */ 04438 /* lost, but the fact that it is a dummy argument is retained. If it is */ 04439 /* a dummy argument, it has to become a dummy proc. The input proc_type */ 04440 /* would always be extern_proc in this case. The Extern_Proc should be */ 04441 /* switched to Dummy_Proc. */ 04442 04443 if (ATD_CLASS(attr_idx) == Dummy_Argument) { 04444 proc_type = Dummy_Proc; 04445 } 04446 04447 /* Check to see if this should be a Function */ 04448 04449 if (pgm_unit == Function || 04450 (pgm_unit == Pgm_Unknown && (AT_TYPED(attr_idx) || 04451 ATD_TARGET(attr_idx) || 04452 ATD_POINTER(attr_idx) || 04453 ATD_ARRAY_IDX(attr_idx) != NULL_IDX))) { 04454 04455 NTR_ATTR_TBL(new_at_idx); /* Create func result entry */ 04456 COPY_ATTR_NTRY(new_at_idx, attr_idx);/* Copy data to func rslt */ 04457 AT_CIF_SYMBOL_ID(new_at_idx) = 0; 04458 ATD_CLASS(new_at_idx) = Function_Result; 04459 ATD_FUNC_IDX(new_at_idx) = attr_idx; 04460 pgm_unit = Function; 04461 } 04462 04463 CLEAR_VARIANT_ATTR_INFO(attr_idx, Pgm_Unit); /* Clear to make pgm unit */ 04464 ATP_PGM_UNIT(attr_idx) = pgm_unit; 04465 MAKE_EXTERNAL_NAME(attr_idx, AT_NAME_IDX(attr_idx), AT_NAME_LEN(attr_idx)); 04466 ATP_PROC(attr_idx) = proc_type; 04467 04468 04469 /* Set scope to current scope for now. attr_link_resolution will reset */ 04470 /* the scope if it ends up being host associated. */ 04471 04472 ATP_SCP_IDX(attr_idx) = curr_scp_idx; 04473 04474 if (pgm_unit == Function) { 04475 ATP_RSLT_IDX(attr_idx) = new_at_idx; 04476 } 04477 04478 TRACE (Func_Exit, "chg_data_obj_to_pgm_unit", NULL); 04479 04480 return; 04481 04482 } /* chg_data_obj_to_pgm_unit */ 04483 04484 04485 /******************************************************************************\ 04486 |* *| 04487 |* Description: *| 04488 |* This routine returns a type string suitable for printing in error msgs*| 04489 |* WARNING: If either of the input types can be structures, you cannot *| 04490 |* call this routine twice with the same PRINTMSG. strcat the *| 04491 |* result to a character array and then call it again. *| 04492 |* *| 04493 |* Input parameters: *| 04494 |* type - The type *| 04495 |* type_idx - the type idx union *| 04496 |* *| 04497 |* Output parameters: *| 04498 |* NONE *| 04499 |* *| 04500 |* Returns: *| 04501 |* a pointer to a character string, describing the type *| 04502 |* *| 04503 \******************************************************************************/ 04504 char *get_basic_type_str(int type_idx) 04505 { 04506 char *str; 04507 static char str1[45]; 04508 04509 04510 TRACE (Func_Entry, "get_basic_type_str", NULL); 04511 04512 switch (TYP_TYPE(type_idx)) { 04513 04514 case Typeless: 04515 if (TYP_LINEAR(type_idx) == Typeless_4 || 04516 TYP_LINEAR(type_idx) == Typeless_8 || 04517 TYP_LINEAR(type_idx) == Short_Typeless_Const) { 04518 str = "BOOLEAN"; 04519 } 04520 else { 04521 str = "TYPELESS"; 04522 } 04523 break; 04524 04525 case Integer: 04526 str = "INTEGER"; 04527 break; 04528 04529 case Logical: 04530 str = "LOGICAL"; 04531 break; 04532 04533 case Real: 04534 str = (TYP_LINEAR(type_idx) <= REAL_DEFAULT_TYPE) ? "REAL" : 04535 "DOUBLE PRECISION"; 04536 break; 04537 04538 case Complex: 04539 str = (TYP_LINEAR(type_idx) <= COMPLEX_DEFAULT_TYPE) ? "COMPLEX": 04540 "DOUBLE COMPLEX"; 04541 break; 04542 04543 case Character: 04544 str = "CHARACTER"; 04545 break; 04546 04547 case Structure: 04548 str1[0] = '\0'; 04549 strcat(str1, "type("); 04550 strcat(str1, AT_OBJ_NAME_PTR(TYP_IDX(type_idx))); 04551 strcat(str1, ")"); 04552 str = str1; 04553 break; 04554 04555 case CRI_Ptr: 04556 str = "Cray pointer"; 04557 break; 04558 04559 case CRI_Ch_Ptr: 04560 str = "Cray character pointer"; 04561 break; 04562 04563 case CRI_Parcel_Ptr: 04564 str = "Cray parcel pointer"; 04565 break; 04566 04567 } /* End switch */ 04568 04569 TRACE (Func_Exit, "get_basic_type_str", NULL); 04570 04571 return(str); 04572 04573 } /* get_basic_type_str */ 04574 04575 /******************************************************************************\ 04576 |* *| 04577 |* Description: *| 04578 |* Verify that the kind type is valid, and return the corresponding *| 04579 |* aux type. (If it's character or err, return the input aux type.) *| 04580 |* *| 04581 |* Input parameters: *| 04582 |* opnd - An operand holding the kind type. This operand *| 04583 |* will not be changed, so you can pass the IR *| 04584 |* attr_idx - Attr index to get the updated type index. *| 04585 |* kind0seen *| 04586 |* kind0E0seen *| 04587 |* kind0D0seen *| 04588 |* kindconstseen *| 04589 |* *| 04590 |* Output parameters: *| 04591 |* NONE *| 04592 |* *| 04593 |* Returns: *| 04594 |* NONE *| 04595 |* *| 04596 \******************************************************************************/ 04597 boolean kind_to_linear_type(opnd_type *opnd, 04598 int attr_idx, 04599 boolean kind0seen, 04600 boolean kind0E0seen, 04601 boolean kind0D0seen, 04602 boolean kindconstseen) 04603 04604 04605 { 04606 int column; 04607 boolean error = FALSE; 04608 long kind; 04609 int line; 04610 linear_type_type linear_type = Err_Res; 04611 basic_type_type type; 04612 int type_idx; 04613 #ifdef SOURCE_TO_SOURCE 04614 opnd_type *kwd_c; 04615 #endif 04616 04617 04618 TRACE (Func_Entry, "kind_to_linear_type", NULL); 04619 04620 type = TYP_TYPE(ATD_TYPE_IDX(attr_idx)); 04621 04622 #ifdef SOURCE_TO_SOURCE 04623 if (OPND_FLD((*opnd)) == IR_Tbl_Idx && 04624 IR_OPR(OPND_IDX((*opnd))) == Kwd_Opr) { 04625 kwd_c = opnd; 04626 opnd = &((IR_OPND_R(OPND_IDX((*opnd))))); 04627 } 04628 04629 #endif 04630 04631 if (OPND_FLD((*opnd)) != CN_Tbl_Idx || 04632 TYP_TYPE(CN_TYPE_IDX(OPND_IDX((*opnd)))) != Integer) { 04633 04634 find_opnd_line_and_column(opnd, &line, &column); 04635 PRINTMSG(line, 770, Error, column); 04636 error = TRUE; 04637 04638 /* For error recovery use the default type */ 04639 04640 switch (type) { 04641 case Integer: 04642 type_idx = INTEGER_DEFAULT_TYPE; 04643 break; 04644 04645 case Logical: 04646 type_idx = LOGICAL_DEFAULT_TYPE; 04647 break; 04648 04649 case Real: 04650 type_idx = REAL_DEFAULT_TYPE; 04651 break; 04652 04653 case Complex: 04654 type_idx = COMPLEX_DEFAULT_TYPE; 04655 break; 04656 04657 default: /* Includes Character */ 04658 type_idx = ATD_TYPE_IDX(attr_idx); 04659 break; 04660 } 04661 } 04662 else { 04663 kind = (long) CN_INT_TO_C(OPND_IDX((*opnd))); 04664 04665 error = validate_kind(type, 04666 OPND_LINE_NUM((*opnd)), 04667 OPND_COL_NUM((*opnd)), 04668 &kind, 04669 &linear_type); 04670 04671 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 04672 type_tbl[TYP_WORK_IDX] = type_tbl[ATD_TYPE_IDX(attr_idx)]; 04673 } 04674 else { 04675 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 04676 TYP_TYPE(TYP_WORK_IDX) = type; 04677 TYP_LINEAR(TYP_WORK_IDX) = linear_type; 04678 } 04679 04680 TYP_DCL_VALUE(TYP_WORK_IDX) = kind; 04681 TYP_DESC(TYP_WORK_IDX) = Kind_Typed; 04682 04683 if ((kind0seen && 04684 (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Logical || 04685 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Integer)) || 04686 (kind0E0seen && TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Real)) { 04687 04688 /* change to a default type idx */ 04689 04690 TYP_DESC(TYP_WORK_IDX) = Default_Typed; 04691 } 04692 else if (kind0D0seen && TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Real) { 04693 TYP_KIND_DOUBLE(TYP_WORK_IDX) = TRUE; 04694 } 04695 else if (kindconstseen) { 04696 TYP_KIND_CONST(TYP_WORK_IDX) = TRUE; 04697 } 04698 04699 type_idx = ntr_type_tbl(); 04700 } 04701 04702 ATD_TYPE_IDX(attr_idx) = type_idx; 04703 04704 TRACE (Func_Exit, "kind_to_linear_type", NULL); 04705 04706 return(error); 04707 04708 } /* kind_to_linear_type */ 04709 04710 /******************************************************************************\ 04711 |* *| 04712 |* Description: *| 04713 |* This generates a debug label before the input statement. *| 04714 |* Debug labels are numbered z@00001. *| 04715 |* This routine creates the debug label and the compiler generated *| 04716 |* continue statement, before the input statement. It sets *| 04717 |* ATL_DEBUG_CLASS to the input debug class. *| 04718 |* *| 04719 |* Input parameters: *| 04720 |* stmt_idx The SH idx which needs a label before it. *| 04721 |* label_type The debug label class. *| 04722 |* attr_idx If NULL - make new attr, else use this one for label *| 04723 |* *| 04724 |* Output parameters: *| 04725 |* NONE *| 04726 |* *| 04727 |* Returns: *| 04728 |* NONE *| 04729 |* *| 04730 \******************************************************************************/ 04731 int gen_debug_lbl_stmt(int stmt_idx, 04732 atl_debug_class_type label_type, 04733 int attr_idx) 04734 04735 { 04736 int ir_idx; 04737 int length; 04738 id_str_type name; 04739 int save_curr_stmt_sh_idx; 04740 04741 # if defined(_NO_AT_SIGN_IN_NAMES) 04742 char label_name[7] = "z.%05d"; 04743 # else 04744 char label_name[7] = "z@%05d"; 04745 # endif 04746 04747 04748 TRACE (Func_Entry, "gen_debug_lbl_stmt", NULL); 04749 04750 if (attr_idx == NULL_IDX) { 04751 curr_debug_lbl++; 04752 04753 CREATE_ID(name, " ", 1); 04754 04755 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 04756 length = sprintf (name.string, label_name, curr_debug_lbl); 04757 # else 04758 sprintf(name.string, label_name, curr_debug_lbl); 04759 length = strlen(name.string); 04760 # endif 04761 04762 # ifdef _DEBUG 04763 /* Have reached the maximum label - make it and issue message */ 04764 04765 if (curr_debug_lbl > MAX_GENERATED_LABELS) { 04766 PRINTMSG(SH_GLB_LINE(stmt_idx), 364, Limit, 0, MAX_GENERATED_LABELS); 04767 } 04768 # endif 04769 04770 attr_idx = ntr_local_attr_list(name.string, 04771 length, 04772 SH_GLB_LINE(stmt_idx), 04773 0); 04774 04775 AT_OBJ_CLASS(attr_idx) = Label; 04776 AT_COMPILER_GEND(attr_idx) = TRUE; 04777 ATL_CLASS(attr_idx) = Lbl_Debug; 04778 ATL_DEBUG_CLASS(attr_idx) = label_type; 04779 AT_DEFINED(attr_idx) = TRUE; 04780 ATL_DEF_STMT_IDX(attr_idx) = curr_stmt_sh_idx; 04781 } 04782 04783 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 04784 04785 if (SH_LABELED(stmt_idx)) { 04786 stmt_idx = SH_PREV_IDX(stmt_idx); 04787 } 04788 04789 curr_stmt_sh_idx = stmt_idx; 04790 04791 gen_sh(Before, 04792 Continue_Stmt, 04793 SH_GLB_LINE(stmt_idx), 04794 SH_COL_NUM(stmt_idx), 04795 FALSE, /* No errors */ 04796 TRUE, /* Labeled */ 04797 TRUE); /* Compiler generated */ 04798 04799 stmt_idx = SH_PREV_IDX(curr_stmt_sh_idx); 04800 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 04801 SH_P2_SKIP_ME(stmt_idx) = TRUE; 04802 04803 NTR_IR_TBL(ir_idx); 04804 SH_IR_IDX(stmt_idx) = ir_idx; 04805 IR_OPR(ir_idx) = Label_Opr; 04806 IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE; 04807 IR_LINE_NUM(ir_idx) = SH_GLB_LINE(stmt_idx); 04808 IR_COL_NUM(ir_idx) = SH_COL_NUM(stmt_idx); 04809 IR_LINE_NUM_L(ir_idx) = SH_GLB_LINE(stmt_idx); 04810 IR_COL_NUM_L(ir_idx) = SH_COL_NUM(stmt_idx); 04811 IR_FLD_L(ir_idx) = AT_Tbl_Idx; 04812 IR_IDX_L(ir_idx) = attr_idx; 04813 04814 TRACE (Func_Exit, "gen_debug_lbl_stmt", NULL); 04815 04816 return(stmt_idx); 04817 04818 } /* gen_debug_lbl_stmt */ 04819 04820 /******************************************************************************\ 04821 |* *| 04822 |* Description: *| 04823 |* This takes as input a string and sticks _in_PROC after it for each *| 04824 |* parent procedure above this child. *| 04825 |* *| 04826 |* Input parameters: *| 04827 |* name_str_idx A name_pool index to the beginning string. *| 04828 |* name_str_len A character length of the beginning string. *| 04829 |* scp_idx The first scope to use for appending. *| 04830 |* *| 04831 |* Output parameters: *| 04832 |* name_len A pointer to the length of the new string. *| 04833 |* *| 04834 |* Returns: *| 04835 |* name_pool_idx for the new string *| 04836 |* *| 04837 \******************************************************************************/ 04838 int make_in_parent_string(int name_str_idx, 04839 int name_str_len, 04840 int scp_idx, 04841 int *name_len) 04842 { 04843 int idx; 04844 int length; 04845 int new_name_idx; 04846 04847 04848 TRACE (Func_Entry, "make_in_parent_string", NULL); 04849 04850 new_name_idx = name_pool_idx + 1; 04851 length = name_str_len; 04852 04853 TBL_REALLOC_CK(name_pool, HOST_BYTES_TO_WORDS(MAX_EXTERNAL_ID_LEN)); 04854 04855 for (idx = new_name_idx; idx <= name_pool_idx; idx++) { 04856 name_pool[idx].name_long = 0; 04857 } 04858 04859 # if 0 04860 name_pool[new_name_idx].name_char[idx] = 04861 tolower(name_pool[name_str_idx].name_char[idx]); 04862 # endif 04863 04864 strcat(&name_pool[new_name_idx].name_char, 04865 &name_pool[name_str_idx].name_char); 04866 04867 while (scp_idx != NULL_IDX) { 04868 strcat(&name_pool[new_name_idx].name_char, UNIQUE_PROC_CONNECTOR); 04869 strcat(&name_pool[new_name_idx].name_char, 04870 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(scp_idx))); 04871 04872 length = length + AT_NAME_LEN(SCP_ATTR_IDX(scp_idx)) + UNIQUE_PROC_LEN; 04873 scp_idx = SCP_PARENT_IDX(scp_idx); 04874 } 04875 04876 name_pool_idx = name_pool_idx - (HOST_BYTES_TO_WORDS(MAX_EXTERNAL_ID_LEN) - 04877 WORD_LEN(length)); 04878 *name_len = length; 04879 04880 TRACE (Func_Exit, "make_in_parent_string", NULL); 04881 04882 return(new_name_idx); 04883 04884 } /* make_in_parent_string */ 04885 04886 /******************************************************************************\ 04887 |* *| 04888 |* Description: *| 04889 |* *| 04890 |* Input parameters: *| 04891 |* NONE *| 04892 |* *| 04893 |* Output parameters: *| 04894 |* NONE *| 04895 |* *| 04896 |* Returns: *| 04897 |* NOTHING *| 04898 |* *| 04899 \******************************************************************************/ 04900 int compare_names(long *id1, 04901 int id1_len, 04902 long *id2, 04903 int id2_len) 04904 04905 { 04906 int i; 04907 long matched = -1; 04908 04909 04910 TRACE (Func_Entry, "compare_names", NULL); 04911 04912 for (i = 0; i < WORD_LEN((id1_len > id2_len) ? id1_len : id2_len); i++) { 04913 matched = id1[i] - id2[i]; 04914 04915 if (matched != 0) { 04916 break; 04917 } 04918 } 04919 04920 # if defined(_HOST_LITTLE_ENDIAN) 04921 04922 04923 if (matched) { 04924 04925 /* some callers of this routine use the sign of the returned value */ 04926 /* to determine ordering for insertion of the non-matched sym. */ 04927 /* (Strings are written into the table storage by byte copy, which */ 04928 /* mean that, in terms of reading longs on little endian machine, */ 04929 /* they are stored big-ending (i.e. a long load will byte swap the */ 04930 /* data in the register before the subtract)...Compare the bytes */ 04931 /* in order... */ 04932 04933 unsigned char* i1 = (unsigned char *) &id1[i]; 04934 unsigned char* i2 = (unsigned char *) &id2[i]; 04935 04936 # ifdef _HOST64 04937 # ifdef _WHIRL_HOST64_TARGET64 04938 signed long t, t1, t2; 04939 /* 04940 int i; 04941 fprintf(stderr, "compare_names:"); 04942 fprintf(stderr, " id1 = "); 04943 for (i = 0; i < 8; i++) 04944 if (i1[i] == 0) 04945 break; 04946 else 04947 fprintf(stderr, "%c", i1[i]); 04948 fprintf(stderr, " id2 = "); 04949 for (i = 0; i < 8; i++) 04950 if (i2[i] == 0) 04951 break; 04952 else 04953 fprintf(stderr, "%c", i2[i]); 04954 fprintf(stderr, "\n"); 04955 */ 04956 t1 = 0; 04957 t2 = 0; 04958 t = i1[0]; t = t << 56; t1 += t; 04959 t = i1[1]; t = t << 48; t1 += t; 04960 t = i1[2]; t = t << 40; t1 += t; 04961 t = i1[3]; t = t << 32; t1 += t; 04962 t = i1[4]; t = t << 24; t1 += t; 04963 t = i1[5]; t = t << 16; t1 += t; 04964 t = i1[6]; t = t << 8; t1 += t; 04965 t = i1[7]; t1 += t; 04966 t = i2[0]; t = t << 56; t2 += t; 04967 t = i2[1]; t = t << 48; t2 += t; 04968 t = i2[2]; t = t << 40; t2 += t; 04969 t = i2[3]; t = t << 32; t2 += t; 04970 t = i2[4]; t = t << 24; t2 += t; 04971 t = i2[5]; t = t << 16; t2 += t; 04972 t = i2[6]; t = t << 8; t2 += t; 04973 t = i2[7]; t2 += t; 04974 matched = t1 - t2; 04975 /* 04976 fprintf(stderr, "compare_names: t1 = %ld, t2 = %ld, matched = %ld\n", 04977 t1, t2, matched); 04978 */ 04979 #else 04980 matched = (signed long) (i1[0]<<56 | i1[1]<<48 | i1[2]<<40| i1[3]<<32 04981 | i1[4]<<24 | i1[5]<<16 | i1[6]<<8 | i1[7] ) 04982 - 04983 (signed long) (i2[0]<<56 | i2[1]<<48 | i2[2]<<40| i2[3]<<32 04984 | i2[4]<<24 | i2[5]<<16 | i2[6]<<8 | i2[7] ); 04985 #endif 04986 #else 04987 matched = (signed long) (i1[0]<<24 | i1[1]<<16 | i1[2]<<8 | i1[3] ) 04988 - 04989 (signed long) (i2[0]<<24 | i2[1]<<16 | i2[2]<<8 | i2[3] ); 04990 04991 #endif 04992 } 04993 #endif 04994 04995 04996 TRACE (Func_Exit, "compare_names", NULL); 04997 04998 # ifdef _HOST64 04999 # ifdef _WHIRL_HOST64_TARGET64 05000 if (matched) 05001 matched = matched > 0 ? 1 : -1; 05002 #endif 05003 #endif 05004 05005 return(matched); 05006 05007 } /* compare_names */ 05008 05009 /******************************************************************************\ 05010 |* *| 05011 |* Description: *| 05012 |* *| 05013 |* Input parameters: *| 05014 |* length of name *| 05015 |* defining line *| 05016 |* *| 05017 |* Output parameters: *| 05018 |* NONE *| 05019 |* *| 05020 |* Returns: *| 05021 |* attr tbl index where entry is put *| 05022 |* *| 05023 \******************************************************************************/ 05024 05025 int ntr_local_attr_list(char *name_str, 05026 int name_len, 05027 int def_line, 05028 int def_column) 05029 05030 { 05031 int attr_idx; 05032 long *id; 05033 int np_idx; 05034 05035 05036 TRACE (Func_Entry, "ntr_local_attr_list", NULL); 05037 05038 id = (long *) name_str; 05039 05040 NTR_NAME_POOL(id, name_len, np_idx); 05041 05042 NTR_ATTR_TBL(attr_idx); 05043 AT_DEF_LINE(attr_idx) = def_line; 05044 AT_DEF_COLUMN(attr_idx) = def_column; 05045 AT_NAME_LEN(attr_idx) = name_len; 05046 AT_NAME_IDX(attr_idx) = np_idx; 05047 05048 ADD_ATTR_TO_LOCAL_LIST(attr_idx); 05049 05050 TRACE (Func_Exit, "ntr_local_attr_list", NULL); 05051 05052 return(attr_idx); 05053 05054 } /* ntr_local_attr_list */ 05055 05056 /******************************************************************************\ 05057 |* *| 05058 |* Description: *| 05059 |* *| 05060 |* Input parameters: *| 05061 |* *| 05062 |* Output parameters: *| 05063 |* NONE *| 05064 |* *| 05065 |* Returns: *| 05066 |* *| 05067 \******************************************************************************/ 05068 05069 int create_lib_entry_attr(char *name_str, 05070 int name_len, 05071 int def_line, 05072 int def_column) 05073 05074 { 05075 int attr_idx; 05076 id_str_type name; 05077 int np_idx; 05078 05079 05080 TRACE (Func_Entry, "create_lib_entry_attr", NULL); 05081 05082 CREATE_ID(name, name_str, name_len); 05083 NTR_NAME_POOL(&(name.words[0]), name_len, np_idx); 05084 NTR_ATTR_TBL(attr_idx); 05085 AT_OBJ_CLASS(attr_idx) = Pgm_Unit; 05086 AT_REFERENCED(attr_idx) = Referenced; 05087 AT_COMPILER_GEND(attr_idx) = TRUE; 05088 ATP_PGM_UNIT(attr_idx) = Subroutine; 05089 ATP_SCP_IDX(attr_idx) = curr_scp_idx; 05090 ATP_PROC(attr_idx) = Extern_Proc; 05091 AT_NAME_IDX(attr_idx) = np_idx; 05092 AT_NAME_LEN(attr_idx) = name_len; 05093 ATP_EXT_NAME_IDX(attr_idx) = np_idx; 05094 ATP_EXT_NAME_LEN(attr_idx) = name_len; 05095 AT_DEF_LINE(attr_idx) = def_line; 05096 AT_DEF_COLUMN(attr_idx) = def_column; 05097 05098 TRACE (Func_Exit, "create_lib_entry_attr", NULL); 05099 05100 return(attr_idx); 05101 05102 } /* create_lib_entry_attr */ 05103 05104 /******************************************************************************\ 05105 |* *| 05106 |* Description: *| 05107 |* *| 05108 |* Input parameters: *| 05109 |* NONE *| 05110 |* *| 05111 |* Output parameters: *| 05112 |* NONE *| 05113 |* *| 05114 |* Returns: *| 05115 |* NONE *| 05116 |* *| 05117 \******************************************************************************/ 05118 05119 void set_stride_for_first_dim(int type_idx, 05120 size_offset_type *stride) 05121 { 05122 long64 length; 05123 size_offset_type result; 05124 05125 05126 TRACE (Func_Entry, "set_stride_for_first_dim", NULL); 05127 05128 # ifdef _SM_UNIT_IS_ELEMENT 05129 05130 (*stride).fld = CN_Tbl_Idx; 05131 (*stride).idx = CN_INTEGER_ONE_IDX; 05132 05133 # else 05134 05135 switch (TYP_TYPE(type_idx)) { 05136 05137 case Typeless: 05138 length = STORAGE_WORD_SIZE(TYP_BIT_LEN(type_idx)); 05139 (*stride).fld = CN_Tbl_Idx; 05140 (*stride).idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, length); 05141 break; 05142 05143 case Integer: 05144 case Logical: 05145 case CRI_Ptr: 05146 case CRI_Ch_Ptr: 05147 case Real: 05148 case Complex: 05149 length = TARGET_BITS_TO_WORDS(storage_bit_size_tbl[ 05150 TYP_LINEAR(type_idx)]); 05151 # if defined(_TARGET64) && defined(_WHIRL_HOST64_TARGET64) 05152 if (double_stride && (storage_bit_size_tbl[TYP_LINEAR(type_idx)] > 32)) 05153 length *= 2; 05154 # endif /* defined(_TARGET64) && defined(_WHIRL_HOST64_TARGET64) */ 05155 (*stride).fld = CN_Tbl_Idx; 05156 (*stride).idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, length); 05157 break; 05158 05159 case Character: /* This is really number of bytes */ 05160 # if defined(_EXTENDED_CRI_CHAR_POINTER) 05161 if (TYP_FLD(type_idx) == AT_Tbl_Idx && 05162 AT_OBJ_CLASS(TYP_IDX(type_idx)) == Data_Obj && 05163 (TYP_TYPE(ATD_TYPE_IDX(TYP_IDX(type_idx))) == CRI_Ch_Ptr || 05164 TYP_TYPE(ATD_TYPE_IDX(TYP_IDX(type_idx))) == CRI_Ptr)) { 05165 05166 /* This is a character pointee with assumed length. */ 05167 /* Set the stride multiplier to one. */ 05168 05169 (*stride).fld = CN_Tbl_Idx; 05170 (*stride).idx = CN_INTEGER_ONE_IDX; 05171 } 05172 else { 05173 (*stride).fld = TYP_FLD(type_idx); 05174 (*stride).idx = TYP_IDX(type_idx); 05175 } 05176 # else 05177 (*stride).fld = TYP_FLD(type_idx); 05178 (*stride).idx = TYP_IDX(type_idx); 05179 # endif 05180 break; 05181 05182 case Structure: 05183 05184 if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) { 05185 05186 /* stride is in bytes, just like character */ 05187 05188 result.idx = CN_INTEGER_THREE_IDX; 05189 result.fld = CN_Tbl_Idx; 05190 (*stride).fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 05191 (*stride).idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 05192 05193 if (!size_offset_binary_calc(&(*stride), 05194 &result, 05195 Shiftr_Opr, 05196 &(*stride))) { 05197 05198 (*stride).fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 05199 (*stride).idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 05200 } 05201 } 05202 else { 05203 (*stride).fld = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx)); 05204 (*stride).idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)); 05205 05206 # if defined(_TARGET64) && defined(_WHIRL_HOST64_TARGET64) 05207 BITS_TO_WORDS((*stride), TARGET_BITS_PER_WORD/2); 05208 # else 05209 BITS_TO_WORDS((*stride), TARGET_BITS_PER_WORD); 05210 # endif /* defined(_TARGET64) && defined(_WHIRL_HOST64_TARGET64) */ 05211 } 05212 05213 if ((*stride).fld == NO_Tbl_Idx) { 05214 (*stride).fld = CN_Tbl_Idx; 05215 (*stride).idx = ntr_const_tbl((*stride).type_idx, 05216 FALSE, 05217 (*stride).constant); 05218 } 05219 05220 break; 05221 05222 } /* end switch */ 05223 # endif 05224 05225 TRACE (Func_Exit, "set_stride_for_first_dim", NULL); 05226 05227 return; 05228 05229 } /* set_stride_for_first_dim */ 05230 05231 /******************************************************************************\ 05232 |* *| 05233 |* Description: *| 05234 |* This routine adds new types to the type table. It attempts to share *| 05235 |* them all. If you are entering Typeless, pass Err_Res *| 05236 |* for the lin_type, and this routine will set it correctly.) *| 05237 |* *| 05238 |* Input parameters: *| 05239 |* NONE *| 05240 |* *| 05241 |* Output parameters: *| 05242 |* NONE *| 05243 |* *| 05244 |* Returns: *| 05245 |* NONE *| 05246 |* *| 05247 \******************************************************************************/ 05248 int ntr_type_tbl(void) 05249 05250 { 05251 boolean found; 05252 int i; 05253 int new_type_idx; 05254 long *null_base; 05255 long *type_tbl_base; 05256 05257 05258 TRACE (Func_Entry, "ntr_type_tbl", NULL); 05259 05260 switch (TYP_TYPE(TYP_WORK_IDX)) { 05261 case Integer: 05262 case Logical: 05263 case Real: 05264 case Complex: 05265 05266 if (TYP_DESC(TYP_WORK_IDX) == Default_Typed && 05267 TYP_LINEAR(TYP_WORK_IDX) != Err_Res) { 05268 new_type_idx = TYP_LINEAR(TYP_WORK_IDX); 05269 goto EXIT; 05270 } 05271 break; 05272 05273 case CRI_Ptr: 05274 05275 if (TYP_PTR_INCREMENT(TYP_WORK_IDX) != 0 && 05276 TYP_PTR_INCREMENT(TYP_WORK_IDX) != TARGET_BITS_PER_WORD) { 05277 break; 05278 } 05279 05280 case CRI_Parcel_Ptr: 05281 case CRI_Ch_Ptr: 05282 new_type_idx = TYP_LINEAR(TYP_WORK_IDX); 05283 goto EXIT; 05284 05285 case Typeless: 05286 05287 if (TYP_LINEAR(TYP_WORK_IDX) == Err_Res) { 05288 05289 switch (TYP_BIT_LEN(TYP_WORK_IDX)) { 05290 case 32: 05291 TYP_LINEAR(TYP_WORK_IDX) = Typeless_4; 05292 break; 05293 05294 case 64: 05295 TYP_LINEAR(TYP_WORK_IDX) = Typeless_8; 05296 break; 05297 05298 default: 05299 TYP_LINEAR(TYP_WORK_IDX) = Long_Typeless; 05300 break; 05301 } 05302 } 05303 break; 05304 05305 case Character: 05306 TYP_LINEAR(TYP_WORK_IDX) = (TYP_LINEAR(TYP_WORK_IDX) == Err_Res)? 05307 CHARACTER_DEFAULT_TYPE : 05308 TYP_LINEAR(TYP_WORK_IDX); 05309 break; 05310 05311 case Structure: 05312 break; 05313 } 05314 05315 null_base = (long *) type_tbl; 05316 05317 for (new_type_idx = 1; new_type_idx <= type_tbl_idx; new_type_idx++) { 05318 found = TRUE; 05319 type_tbl_base = (long *) &(type_tbl[new_type_idx]); 05320 05321 for (i = 0; i < NUM_TYP_WDS; i++) { 05322 05323 if (null_base[i] != type_tbl_base[i]) { 05324 found = FALSE; 05325 } 05326 } 05327 05328 if (found) { 05329 goto EXIT; 05330 } 05331 } 05332 05333 TBL_REALLOC_CK(type_tbl, 1); 05334 new_type_idx = type_tbl_idx; 05335 type_tbl[new_type_idx] = type_tbl[TYP_WORK_IDX]; 05336 05337 EXIT: 05338 05339 TRACE (Func_Exit, "ntr_type_tbl", NULL); 05340 05341 return(new_type_idx); 05342 05343 } /* ntr_type_tbl */ 05344 05345 /******************************************************************************\ 05346 |* *| 05347 |* Description: *| 05348 |* This routine adds new types to the type table. It attempts to share *| 05349 |* them all. *| 05350 |* It's called in cvrt-to-PDG to generate a type table entry for a *| 05351 |* derived type which no variable in the current PU.Added it for module *| 05352 |* Input parameters: *| 05353 |* NONE *| 05354 |* *| 05355 |* Output parameters: *| 05356 |* NONE *| 05357 |* *| 05358 |* Returns: *| 05359 |* NONE *| 05360 |* *| 05361 \******************************************************************************/ 05362 int ntr_derived_type_tbl(void) 05363 { 05364 boolean found; 05365 int i; 05366 int new_type_idx; 05367 long *null_base; 05368 long *type_tbl_base; 05369 05370 05371 TRACE (Func_Entry, "ntr_type_tbl", NULL); 05372 null_base = (long *) type_tbl; 05373 05374 for (new_type_idx = 1; new_type_idx <= type_tbl_idx; new_type_idx++) { 05375 found = TRUE; 05376 type_tbl_base = (long *) &(type_tbl[new_type_idx]); 05377 05378 for (i = 0; i < NUM_TYP_WDS; i++) { 05379 05380 if (null_base[i] != type_tbl_base[i]) { 05381 found = FALSE; 05382 } 05383 } 05384 05385 if (found) { 05386 goto EXIT; 05387 } 05388 } 05389 05390 TBL_REALLOC_CK(type_tbl, 1); 05391 new_type_idx = type_tbl_idx; 05392 type_tbl[new_type_idx] = type_tbl[TYP_WORK_IDX]; 05393 05394 EXIT: 05395 05396 TRACE (Func_Exit, "ntr_derived_type_tbl", NULL); 05397 05398 return(new_type_idx); 05399 05400 } /* ntr_type_tbl */ 05401 05402 05403 /******************************************************************************\ 05404 |* *| 05405 |* Description: *| 05406 |* srch_linked_sn searches linked lists in the secondary name table. *| 05407 |* *| 05408 |* Input parameters: *| 05409 |* name Char pointer of name to look for. *| 05410 |* length Length of name to look for. *| 05411 |* sn_idx Secondary name table index to start search. *| 05412 |* *| 05413 |* Output parameters: *| 05414 |* sn_idx Secondary name table index if found. *| 05415 |* *| 05416 |* Returns: *| 05417 |* attribute table index of member if found *| 05418 |* NULL_IDX if not found *| 05419 |* *| 05420 \******************************************************************************/ 05421 int srch_linked_sn(char *name, 05422 int length, 05423 int *sn_idx) 05424 05425 { 05426 int attr_idx; 05427 register int i; 05428 register int id_wd_len; 05429 register long *id; 05430 register long *id1; 05431 register long matched; 05432 05433 05434 TRACE (Func_Entry, "srch_linked_sn", name); 05435 05436 id = (long *) name; 05437 id_wd_len = WORD_LEN(length); 05438 matched = -1; 05439 attr_idx = NULL_IDX; 05440 05441 while (*sn_idx != NULL_IDX) { 05442 05443 if (SN_NAME_LEN(*sn_idx) == length) { 05444 id1 = (long *) &(name_pool[SN_NAME_IDX(*sn_idx)]); 05445 05446 for (i = 0; i < id_wd_len; i++) { 05447 matched = id[i] - id1[i]; 05448 05449 if (matched != 0) { 05450 break; 05451 } 05452 } 05453 05454 if (matched == 0) { 05455 attr_idx = SN_ATTR_IDX(*sn_idx); 05456 break; 05457 } 05458 } 05459 05460 *sn_idx = SN_SIBLING_LINK(*sn_idx); 05461 } 05462 05463 TRACE (Func_Exit, "srch_linked_sn", NULL); 05464 05465 return (attr_idx); 05466 05467 } /* srch_linked_sn */ 05468 05469 /******************************************************************************\ 05470 |* *| 05471 |* Description: *| 05472 |* Free memory before calling backends *| 05473 |* *| 05474 |* Input parameters: *| 05475 |* NONE *| 05476 |* *| 05477 |* Output parameters: *| 05478 |* NONE *| 05479 |* *| 05480 |* Returns: *| 05481 |* NOTHING *| 05482 |* *| 05483 \******************************************************************************/ 05484 05485 void free_tables() 05486 05487 { 05488 TRACE (Func_Entry, "free_tables", NULL); 05489 05490 /* program_unit_name is used by messages.c and cif.c, after the tables */ 05491 /* are gone. PDGCS issues messages and needs a program name to list. */ 05492 /* Can always copy 1 char more, because the namepool is zero filled and */ 05493 /* a zero always has to end the name. */ 05494 05495 strncpy(program_unit_name, 05496 AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)), 05497 AT_NAME_LEN(SCP_ATTR_IDX(curr_scp_idx))+1); 05498 05499 /* Clear because there is no table left. */ 05500 05501 curr_stmt_sh_idx = NULL_IDX; 05502 curr_scp_idx = NULL_IDX; 05503 expanded_intrinsic_list = NULL_IDX; 05504 05505 TBL_FREE (pdg_link_tbl); 05506 TBL_FREE (attr_list_tbl); 05507 TBL_FREE (attr_tbl); 05508 TBL_FREE (attr_aux_tbl); 05509 TBL_FREE (bounds_tbl); 05510 TBL_FREE (const_tbl); 05511 TBL_FREE (const_pool); 05512 TBL_FREE (sec_name_tbl); 05513 TBL_FREE (stor_blk_tbl); 05514 TBL_FREE (loc_name_tbl); 05515 TBL_FREE (name_pool); 05516 TBL_FREE (scp_tbl); 05517 TBL_FREE (type_tbl); 05518 TBL_FREE (ir_tbl); 05519 TBL_FREE (sh_tbl); 05520 TBL_FREE (ir_list_tbl); 05521 TBL_FREE (hidden_name_tbl); 05522 05523 TRACE (Func_Exit, "free_tables", NULL); 05524 05525 return; 05526 05527 } /* free_tables */ 05528 05529 05530 05531 /******************************************************************************\ 05532 |* *| 05533 |* Description: *| 05534 |* Verify that this is a valid kind for this type and machine. *| 05535 |* *| 05536 |* Input parameters: *| 05537 |* NONE *| 05538 |* *| 05539 |* Output parameters: *| 05540 |* NONE *| 05541 |* *| 05542 |* Returns: *| 05543 |* NOTHING *| 05544 |* *| 05545 \******************************************************************************/ 05546 05547 boolean validate_kind(basic_type_type type, 05548 int line, 05549 int column, 05550 long *kind, 05551 linear_type_type *linear_type) 05552 05553 { 05554 boolean ok = TRUE; 05555 char kind_str[32]; 05556 05557 05558 TRACE (Func_Entry, "validate_kind", NULL); 05559 05560 switch (type) { 05561 05562 case Integer: 05563 05564 switch(*kind) { 05565 case 1: 05566 *linear_type = Integer_1; 05567 break; 05568 05569 case 2: 05570 *linear_type = Integer_2; 05571 break; 05572 05573 case 4: 05574 *linear_type = Integer_4; 05575 break; 05576 05577 case 8: 05578 *linear_type = Integer_8; 05579 break; 05580 05581 default: 05582 *linear_type = INTEGER_DEFAULT_TYPE; 05583 ok = FALSE; 05584 break; 05585 } 05586 break; 05587 05588 05589 case Logical: 05590 05591 switch(*kind) { 05592 case 1: 05593 *linear_type = Logical_1; 05594 break; 05595 05596 case 2: 05597 *linear_type = Logical_2; 05598 break; 05599 05600 case 4: 05601 *linear_type = Logical_4; 05602 break; 05603 05604 case 8: 05605 *linear_type = Logical_8; 05606 break; 05607 05608 default: 05609 *linear_type = LOGICAL_DEFAULT_TYPE; 05610 ok = FALSE; 05611 break; 05612 } 05613 break; 05614 05615 05616 case Real: 05617 05618 switch(*kind) { 05619 case 4: 05620 *linear_type = Real_4; 05621 break; 05622 05623 case 8: 05624 *linear_type = Real_8; 05625 break; 05626 05627 case 16: 05628 *linear_type = Real_16; 05629 05630 # if defined(_TARGET_OS_MAX) 05631 PRINTMSG(line, 543, Warning, column, 16, 8); 05632 *linear_type = Real_8; 05633 05634 /* in source-level translation we don't need concern TARGET_OS----fzhao 05635 # elif defined(_TARGET_OS_LINUX) 05636 PRINTMSG(line, 541, Error, column); 05637 */ 05638 05639 # endif 05640 break; 05641 05642 default: 05643 ok = FALSE; 05644 /* *linear_type = REAL_DEFAULT_TYPE; */ 05645 break; 05646 } 05647 break; 05648 05649 05650 case Complex: 05651 05652 switch(*kind) { 05653 case 4: 05654 *linear_type = Complex_4; 05655 break; 05656 05657 case 8: 05658 *linear_type = Complex_8; 05659 break; 05660 05661 case 16: 05662 *linear_type = Complex_16; 05663 05664 # if defined(_TARGET_OS_MAX) 05665 PRINTMSG(line, 543, Warning, column, 16, 8); 05666 *linear_type = Complex_8; 05667 #if 0 05668 # elif defined(_TARGET_OS_LINUX) 05669 PRINTMSG(line, 541, Error, column); 05670 #endif 05671 05672 # endif 05673 break; 05674 05675 default: 05676 *linear_type = COMPLEX_DEFAULT_TYPE; 05677 ok = FALSE; 05678 break; 05679 } 05680 break; 05681 05682 05683 case Character: 05684 05685 switch(*kind) { 05686 case 1: 05687 *linear_type = Character_1; 05688 break; 05689 05690 default: 05691 *linear_type = CHARACTER_DEFAULT_TYPE; 05692 ok = FALSE; 05693 break; 05694 } 05695 break; 05696 05697 05698 default: 05699 *linear_type = Err_Res; 05700 ok = FALSE; 05701 break; 05702 05703 } /* End switch */ 05704 05705 if (!ok) { 05706 sprintf(kind_str,"%ld", *kind); 05707 PRINTMSG(line, 130, Error, column, 05708 kind_str, 05709 basic_type_str[type]); 05710 *kind = 0; 05711 } 05712 05713 TRACE (Func_Exit, "validate_kind", NULL); 05714 05715 return(ok); 05716 05717 } /* validate_kind */ 05718 05719 05720 /******************************************************************************\ 05721 |* *| 05722 |* Description: *| 05723 |* Assign the offset to an item in a storage block. *| 05724 |* Offsets are assigned as follows for MIPS. *| 05725 |* Complex*32 and complex*(kind=16) is aligned on a 4 word boundary if *| 05726 |* -align32 is not specified. *| 05727 |* *| 05728 |* Input parameters: *| 05729 |* NONE *| 05730 |* *| 05731 |* Output parameters: *| 05732 |* NONE *| 05733 |* *| 05734 |* Returns: *| 05735 |* NOTHING *| 05736 |* *| 05737 |* Info: *| 05738 |* *| 05739 |* Commandline control: -a dalign *| 05740 |* *| 05741 |* SGI: This option cannot be specified by the user. The option is on by *| 05742 |* default, as the SGI commandline processor (in whirl) sets it on. *| 05743 |* The only way it can be disabled is by user option -align32 *| 05744 |* User option -align64 causes -a dalign ON. *| 05745 |* (Se FE_align global variable in sgi_cmd_line.cxx) *| 05746 |* *| 05747 |* DEFAULT: -a dalign ON *| 05748 |* *| 05749 |* SUN: -a dalign is off by default. The user may specify the option. *| 05750 |* *| 05751 |* DEFAULT: -a dalign OFF *| 05752 |* *| 05753 |* The following are the classes of items that may be daligned: *| 05754 |* Common block members *| 05755 |* Numeric sequence components *| 05756 |* All other components *| 05757 |* Static local, module and stack data *| 05758 |* *| 05759 |* If -a dalign is ON these items are double aligned: *| 05760 |* Common block members *| 05761 |* Numeric sequence components *| 05762 |* All other components *| 05763 |* Static local, module and stack data *| 05764 |* *| 05765 |* If -a dalign is OFF, these items are double aligned: *| 05766 |* All other components *| 05767 |* Static local, module and stack data *| 05768 |* *| 05769 |* Types affected by dalign: *| 05770 |* Integer(8) *| 05771 |* Logical(8) *| 05772 |* Real(8) *| 05773 |* Real(16) *| 05774 |* Complex(4) (SUN only - NOT on SGI) *| 05775 |* Complex(8) *| 05776 |* Complex(16) *| 05777 |* Typeless_8 *| 05778 |* Long_Typeless *| 05779 |* *| 05780 |* Platforms where dalign is supported: *| 05781 |* SGI *| 05782 |* SUN *| 05783 |* SV2 *| 05784 |* *| 05785 \******************************************************************************/ 05786 void assign_offset(int attr_idx) 05787 05788 { 05789 size_offset_type offset; 05790 boolean pack; 05791 size_offset_type pad; 05792 size_offset_type storage_size; 05793 int type_idx; 05794 05795 # if defined(_TARGET_DOUBLE_ALIGN) 05796 size_offset_type result; 05797 # endif 05798 05799 05800 TRACE (Func_Entry, "assign_offset", NULL); 05801 05802 if (ATD_SYMBOLIC_CONSTANT(attr_idx)) { 05803 05804 /* This is a placeholder so it doesn't really need storage or an offset.*/ 05805 05806 ATD_OFFSET_ASSIGNED(attr_idx) = TRUE; 05807 ATD_OFFSET_IDX(attr_idx) = CN_INTEGER_ZERO_IDX; 05808 ATD_OFFSET_FLD(attr_idx) = CN_Tbl_Idx; 05809 return; 05810 } 05811 05812 if (ATD_CLASS(attr_idx) == Struct_Component) { 05813 offset.fld = ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME); 05814 offset.idx = ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME); 05815 pack = TRUE; 05816 } 05817 else { 05818 offset.fld = SB_LEN_FLD(ATD_STOR_BLK_IDX(attr_idx)); 05819 offset.idx = SB_LEN_IDX(ATD_STOR_BLK_IDX(attr_idx)); 05820 pack = SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)); 05821 } 05822 05823 storage_size = stor_bit_size_of(attr_idx, 05824 TRUE, /* All elements */ 05825 FALSE); 05826 05827 type_idx = ATD_TYPE_IDX(attr_idx); 05828 05829 if (ATD_IM_A_DOPE(attr_idx) || ATD_POINTER(attr_idx)) { 05830 05831 # if defined(GENERATE_WHIRL) 05832 align_bit_length(&offset, storage_bit_size_tbl[CRI_Ptr_8]); 05833 05834 if (ATD_CLASS(attr_idx) == Struct_Component) { 05835 05836 if (cmd_line_flags.s_pointer8 && !cmd_line_flags.align32) { 05837 ATT_DALIGN_ME(CURR_BLK_NAME) = TRUE; 05838 ATD_ALIGNMENT(attr_idx) = Align_64; 05839 } 05840 } 05841 # else 05842 align_bit_length(&offset, TARGET_BITS_PER_WORD); 05843 ATD_ALIGNMENT(attr_idx) = WORD_ALIGN; 05844 # endif 05845 05846 if (offset.fld == NO_Tbl_Idx) { 05847 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05848 offset.fld = CN_Tbl_Idx; 05849 } 05850 } 05851 else if (pack && 05852 (TYP_TYPE(type_idx) == Character || 05853 (TYP_TYPE(type_idx) == Structure && 05854 ATT_CHAR_SEQ(TYP_IDX(type_idx))))) { 05855 05856 /* Intentionally blank - offset_idx is okay. */ 05857 05858 if (TYP_TYPE(type_idx) == Character) { 05859 05860 # if defined(_CHAR_IS_ALIGN_8) 05861 ATD_ALIGNMENT(attr_idx) = Align_8; 05862 # else 05863 ATD_ALIGNMENT(attr_idx) = Align_Bit; 05864 # endif 05865 } 05866 else { 05867 ATD_ALIGNMENT(attr_idx) = Align_Bit; 05868 } 05869 } 05870 05871 # if defined(_TARGET_PACK_HALF_WORD_TYPES) 05872 05873 /* Complex_4 does not go here because we want it aligned on a 64 bit */ 05874 /* boundary for speed. */ 05875 05876 else if (PACK_HALF_WORD_TEST_CONDITION(type_idx)) { 05877 05878 /* This item is a 32 bit item or this structure has all 32 bit */ 05879 /* components (or components that are structures made up of 32 */ 05880 /* bit components). They can be packed up. */ 05881 05882 /* This option is only allowed on 64 bit machines. */ 05883 05884 align_bit_length(&offset, TARGET_BITS_PER_WORD / 2); 05885 ATD_ALIGNMENT(attr_idx) = Align_32; 05886 05887 if (offset.fld == NO_Tbl_Idx) { 05888 offset.fld = CN_Tbl_Idx; 05889 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05890 } 05891 } 05892 # endif 05893 05894 # if defined(_INTEGER_1_AND_2) 05895 05896 else if (on_off_flags.integer_1_and_2 && 05897 PACK_8_BIT_TEST_CONDITION(type_idx)) { 05898 align_bit_length(&offset, 8); 05899 ATD_ALIGNMENT(attr_idx) = Align_8; 05900 05901 if (offset.fld == NO_Tbl_Idx) { 05902 offset.fld = CN_Tbl_Idx; 05903 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05904 } 05905 } 05906 else if (on_off_flags.integer_1_and_2 && 05907 PACK_16_BIT_TEST_CONDITION(type_idx)){ 05908 align_bit_length(&offset, 16); 05909 ATD_ALIGNMENT(attr_idx) = Align_16; 05910 05911 if (offset.fld == NO_Tbl_Idx) { 05912 offset.fld = CN_Tbl_Idx; 05913 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05914 } 05915 } 05916 05917 # endif 05918 05919 # if defined(GENERATE_WHIRL) 05920 05921 # if 0 05922 else if (cmd_line_flags.align8) { 05923 align_bit_length(&offset, 8); 05924 ATD_ALIGNMENT(attr_idx) = Align_8; 05925 05926 if (offset.fld == NO_Tbl_Idx) { 05927 offset.fld = CN_Tbl_Idx; 05928 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05929 } 05930 } 05931 else if (cmd_line_flags.align16) { 05932 align_bit_length(&offset, 16); 05933 ATD_ALIGNMENT(attr_idx) = Align_16; 05934 05935 if (offset.fld == NO_Tbl_Idx) { 05936 offset.fld = CN_Tbl_Idx; 05937 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05938 } 05939 } 05940 # endif 05941 else if (cmd_line_flags.align32) { 05942 align_bit_length(&offset, 32); 05943 ATD_ALIGNMENT(attr_idx) = Align_32; 05944 05945 if (offset.fld == NO_Tbl_Idx) { 05946 offset.fld = CN_Tbl_Idx; 05947 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05948 } 05949 } 05950 # endif 05951 05952 # if defined(_ALIGN_REAL16_TO_16_BYTES) 05953 05954 else if (TYP_LINEAR(type_idx) == Complex_16 || 05955 TYP_LINEAR(type_idx) == Real_16) { 05956 #if defined(_TARGET64) && defined(_WHIRL_HOST64_TARGET64) 05957 align_bit_length(&offset, TARGET_BITS_PER_WORD*2); 05958 #else 05959 align_bit_length(&offset, TARGET_BITS_PER_WORD*4); 05960 #endif 05961 ATD_ALIGNMENT(attr_idx) = Align_128; 05962 05963 if (offset.fld == NO_Tbl_Idx) { 05964 offset.fld = CN_Tbl_Idx; 05965 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 05966 } 05967 } 05968 # endif 05969 05970 # if defined(_TARGET_DOUBLE_ALIGN) 05971 05972 else if (DALIGN_TEST_CONDITION(type_idx)) { 05973 05974 /* Equivalence is handled in normalize_offsets */ 05975 05976 if (cmd_line_flags.dalign) { 05977 05978 if (ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX && 05979 SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)) ) { 05980 05981 align_bit_length(&offset, TARGET_BITS_PER_WORD); 05982 05983 if (offset.fld == NO_Tbl_Idx) { 05984 offset.fld = CN_Tbl_Idx; 05985 offset.idx = ntr_const_tbl(offset.type_idx, 05986 FALSE, 05987 offset.constant); 05988 } 05989 05990 C_TO_F_INT(result.constant, 05991 TARGET_BITS_PER_WORD * 2, 05992 CG_INTEGER_DEFAULT_TYPE); 05993 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 05994 result.fld = NO_Tbl_Idx; 05995 05996 if (!size_offset_binary_calc(&offset, &result, Mod_Opr, &result)) { 05997 AT_DCL_ERR(attr_idx) = TRUE; 05998 } 05999 06000 if (result.fld == NO_Tbl_Idx) { 06001 result.fld = CN_Tbl_Idx; 06002 result.idx = ntr_const_tbl(result.type_idx, 06003 FALSE, 06004 result.constant); 06005 } 06006 06007 # if ! (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 06008 06009 /* -a dalign is always on for IRIX and there is no way to shut */ 06010 /* it off, so we do not need to issue this warning for IRIX. */ 06011 06012 /* KAY - N$PES */ 06013 06014 if (fold_relationals(result.idx, 06015 CN_INTEGER_ZERO_IDX, 06016 Ne_Opr)) { 06017 PRINTMSG(AT_DEF_LINE(attr_idx), 1013, Warning, 06018 AT_DEF_COLUMN(attr_idx), 06019 AT_OBJ_NAME_PTR(attr_idx), 06020 SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx)) ? 06021 "" : SB_NAME_PTR(ATD_STOR_BLK_IDX(attr_idx))); 06022 } 06023 # endif 06024 } 06025 else if (ATD_CLASS(attr_idx) == Struct_Component) { 06026 ATT_DALIGN_ME(CURR_BLK_NAME) = TRUE; 06027 } 06028 06029 align_bit_length(&offset, TARGET_BITS_PER_WORD * 2); 06030 ATD_ALIGNMENT(attr_idx) = Align_64; 06031 06032 if (offset.fld == NO_Tbl_Idx) { 06033 offset.fld = CN_Tbl_Idx; 06034 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 06035 } 06036 } 06037 else if (ATD_CLASS(attr_idx) == Struct_Component && 06038 !ATT_DCL_NUMERIC_SEQ(CURR_BLK_NAME)) { 06039 06040 /* We cannot dalign numeric sequence derived types */ 06041 06042 align_bit_length(&offset, TARGET_BITS_PER_WORD * 2); 06043 06044 if (offset.fld == NO_Tbl_Idx) { 06045 offset.fld = CN_Tbl_Idx; 06046 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 06047 } 06048 06049 ATT_DALIGN_ME(CURR_BLK_NAME) = TRUE; 06050 ATD_ALIGNMENT(attr_idx) = Align_64; 06051 } 06052 else if (ATD_STOR_BLK_IDX(attr_idx) != NULL_IDX) { 06053 06054 if (SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx))) { 06055 06056 align_bit_length(&offset, TARGET_BITS_PER_WORD); 06057 ATD_ALIGNMENT(attr_idx) = WORD_ALIGN; 06058 06059 if (offset.fld == NO_Tbl_Idx) { 06060 offset.fld = CN_Tbl_Idx; 06061 offset.idx = ntr_const_tbl(offset.type_idx, 06062 FALSE, 06063 offset.constant); 06064 } 06065 06066 C_TO_F_INT(result.constant, 06067 TARGET_BITS_PER_WORD * 2, 06068 CG_INTEGER_DEFAULT_TYPE); 06069 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 06070 result.fld = NO_Tbl_Idx; 06071 06072 if (!size_offset_binary_calc(&offset, &result, Mod_Opr, &result)) { 06073 AT_DCL_ERR(attr_idx) = TRUE; 06074 } 06075 06076 /* KAY N$PES */ 06077 06078 if (result.fld == NO_Tbl_Idx) { 06079 result.fld = CN_Tbl_Idx; 06080 result.idx = ntr_const_tbl(result.type_idx, 06081 FALSE, 06082 result.constant); 06083 } 06084 06085 if (fold_relationals(result.idx, 06086 CN_INTEGER_ZERO_IDX, 06087 Ne_Opr)) { 06088 06089 /* Warning - This double is not on a double word boundary. */ 06090 /* Can only double align these if -a dalign is */ 06091 /* specified on the commandline. */ 06092 06093 PRINTMSG(AT_DEF_LINE(attr_idx), 1161, Caution, 06094 AT_DEF_COLUMN(attr_idx), 06095 AT_OBJ_NAME_PTR(attr_idx), 06096 SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx)) ? 06097 "" : SB_NAME_PTR(ATD_STOR_BLK_IDX(attr_idx))); 06098 } 06099 } 06100 else { 06101 06102 align_bit_length(&offset, TARGET_BITS_PER_WORD * 2); 06103 ATD_ALIGNMENT(attr_idx) = Align_64; 06104 06105 if (offset.fld == NO_Tbl_Idx) { 06106 offset.fld = CN_Tbl_Idx; 06107 offset.idx = ntr_const_tbl(offset.type_idx, 06108 FALSE, 06109 offset.constant); 06110 } 06111 } 06112 } 06113 else { 06114 align_bit_length(&offset, TARGET_BITS_PER_WORD); 06115 ATD_ALIGNMENT(attr_idx) = WORD_ALIGN; 06116 06117 if (offset.fld == NO_Tbl_Idx) { 06118 offset.fld = CN_Tbl_Idx; 06119 offset.idx = ntr_const_tbl(offset.type_idx, 06120 FALSE, 06121 offset.constant); 06122 } 06123 06124 if (ATD_CLASS(attr_idx) == Struct_Component) { 06125 C_TO_F_INT(result.constant, 06126 TARGET_BITS_PER_WORD * 2, 06127 CG_INTEGER_DEFAULT_TYPE); 06128 result.fld = NO_Tbl_Idx; 06129 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 06130 06131 if (!size_offset_binary_calc(&offset, &result, Mod_Opr, &result)) { 06132 AT_DCL_ERR(attr_idx) = TRUE; 06133 } 06134 06135 if (result.fld == NO_Tbl_Idx) { 06136 result.fld = CN_Tbl_Idx; 06137 result.idx = ntr_const_tbl(result.type_idx, 06138 FALSE, 06139 result.constant); 06140 } 06141 06142 /* KAY N$PES */ 06143 06144 if (fold_relationals(result.idx, 06145 CN_INTEGER_ZERO_IDX, 06146 Ne_Opr)) { 06147 06148 /* Caution - This component is not on a double word boundary */ 06149 /* It is numeric sequence so we cannot pad it. */ 06150 06151 PRINTMSG(AT_DEF_LINE(attr_idx), 1198, Caution, 06152 AT_DEF_COLUMN(attr_idx), 06153 AT_OBJ_NAME_PTR(attr_idx), 06154 AT_OBJ_NAME_PTR(CURR_BLK_NAME)); 06155 } 06156 } 06157 } 06158 } 06159 06160 # endif /* DALIGN_TEST_CONDTION */ 06161 06162 # if defined(GENERATE_WHIRL) 06163 06164 else if (TYP_TYPE(type_idx) == Structure && 06165 ATT_ALIGNMENT(TYP_IDX(type_idx)) > WORD_ALIGN) { 06166 06167 switch (ATT_ALIGNMENT(TYP_IDX(type_idx))) { 06168 case Align_Double: 06169 case Align_128: 06170 align_bit_length(&offset, 128); 06171 ATD_ALIGNMENT(attr_idx) = ATT_ALIGNMENT(TYP_IDX(type_idx)); 06172 break; 06173 } 06174 06175 if (offset.fld == NO_Tbl_Idx) { 06176 offset.fld = CN_Tbl_Idx; 06177 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 06178 } 06179 } 06180 # endif 06181 else { 06182 align_bit_length(&offset, TARGET_BITS_PER_WORD); 06183 ATD_ALIGNMENT(attr_idx) = WORD_ALIGN; 06184 06185 if (offset.fld == NO_Tbl_Idx) { 06186 offset.fld = CN_Tbl_Idx; 06187 offset.idx = ntr_const_tbl(offset.type_idx, FALSE, offset.constant); 06188 } 06189 } 06190 06191 if (ATD_CLASS(attr_idx) == Struct_Component) { 06192 ATD_OFFSET_FLD(attr_idx) = offset.fld; 06193 ATD_CPNT_OFFSET_IDX(attr_idx) = offset.idx; 06194 06195 if (!size_offset_binary_calc(&offset, 06196 &storage_size, 06197 Plus_Opr, 06198 &storage_size)) { 06199 AT_DCL_ERR(attr_idx) = TRUE; 06200 } 06201 06202 if (storage_size.fld == NO_Tbl_Idx) { 06203 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = CN_Tbl_Idx; 06204 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = ntr_const_tbl( 06205 storage_size.type_idx, 06206 FALSE, 06207 storage_size.constant); 06208 } 06209 else { 06210 ATT_STRUCT_BIT_LEN_FLD(CURR_BLK_NAME) = storage_size.fld; 06211 ATT_STRUCT_BIT_LEN_IDX(CURR_BLK_NAME) = storage_size.idx; 06212 } 06213 } 06214 else { 06215 06216 /* Do not set ATD_OFFSET_ASSIGNED here, because this routine is used */ 06217 /* by equivalence processing and should not have that flag set. */ 06218 06219 ATD_OFFSET_IDX(attr_idx) = offset.idx; 06220 ATD_OFFSET_FLD(attr_idx) = offset.fld; 06221 06222 if (SB_PAD_BLK(ATD_STOR_BLK_IDX(attr_idx))) { 06223 calculate_pad(&pad, &storage_size, attr_idx); 06224 06225 if (!size_offset_binary_calc(&offset, 06226 &storage_size, 06227 Plus_Opr, 06228 &storage_size)) { 06229 AT_DCL_ERR(attr_idx) = TRUE; 06230 } 06231 06232 if (!size_offset_binary_calc(&pad, 06233 &storage_size, 06234 Plus_Opr, 06235 &storage_size)) { 06236 AT_DCL_ERR(attr_idx) = TRUE; 06237 } 06238 } 06239 else { 06240 06241 if (!size_offset_binary_calc(&offset, 06242 &storage_size, 06243 Plus_Opr, 06244 &storage_size)) { 06245 AT_DCL_ERR(attr_idx) = TRUE; 06246 } 06247 } 06248 06249 if (storage_size.fld == NO_Tbl_Idx) { 06250 storage_size.fld = CN_Tbl_Idx; 06251 storage_size.idx = ntr_const_tbl(storage_size.type_idx, 06252 FALSE, 06253 storage_size.constant); 06254 } 06255 06256 SB_LEN_FLD(ATD_STOR_BLK_IDX(attr_idx)) = storage_size.fld; 06257 SB_LEN_IDX(ATD_STOR_BLK_IDX(attr_idx)) = storage_size.idx; 06258 } 06259 06260 TRACE (Func_Exit, "assign_offset", NULL); 06261 06262 return; 06263 06264 } /* assign_offset */ 06265 06266 /******************************************************************************\ 06267 |* *| 06268 |* Description: *| 06269 |* Allocate storage. *| 06270 |* *| 06271 |* Input parameters: *| 06272 |* storage_size : *| 06273 |* attr_idx : *| 06274 |* *| 06275 |* Output parameters: *| 06276 |* pad : *| 06277 |* *| 06278 |* Returns: *| 06279 |* NOTHING *| 06280 |* *| 06281 \******************************************************************************/ 06282 06283 static void calculate_pad(size_offset_type *pad, 06284 size_offset_type *storage_size, 06285 int attr_idx) 06286 06287 { 06288 size_offset_type constant; 06289 size_offset_type min_result; 06290 int sb_idx; 06291 size_offset_type temp_1; 06292 size_offset_type temp_2; 06293 size_offset_type wd_storage_size; 06294 06295 06296 TRACE (Func_Entry, "calculate_pad", NULL); 06297 06298 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 06299 06300 if (! SB_PAD_AMOUNT_SET(sb_idx)) { 06301 06302 /* Storage size must be in words to calculate pad. */ 06303 06304 wd_storage_size = (*storage_size); 06305 06306 BITS_TO_WORDS(wd_storage_size, TARGET_BITS_PER_WORD); 06307 06308 /* If the user has not specified a pad amount use the following */ 06309 /* formula to calculate the pad amount: */ 06310 /* */ 06311 /* (MIN(256,(MIN(1, size/1K) * (((((256 * size) / 4K) + 7) / 8) * 8)) */ 06312 /* + (MIN(1, size/128) * 8) */ 06313 /* + MOD(( 8 - mod(size, 8)), 8) */ 06314 06315 /* t$1 = (size/1024) */ 06316 06317 constant.fld = NO_Tbl_Idx; 06318 constant.type_idx = CG_INTEGER_DEFAULT_TYPE; 06319 06320 C_TO_F_INT(constant.constant, 1024, CG_INTEGER_DEFAULT_TYPE); 06321 06322 if (! size_offset_binary_calc(&wd_storage_size, 06323 &constant, 06324 Div_Opr, 06325 &temp_1)) { 06326 goto ERROR; /* (size/1024) */ 06327 } 06328 06329 06330 /* min_result = MIN(1, t$1) */ 06331 06332 C_TO_F_INT(constant.constant, 1, CG_INTEGER_DEFAULT_TYPE); 06333 06334 if (! size_offset_min_max_calc(&constant, 06335 &temp_1, 06336 Min_Opr, 06337 &min_result)) { 06338 goto ERROR; /* MIN(1, size/1024) */ 06339 } 06340 06341 06342 /* t$1 = (size * 256) */ 06343 06344 C_TO_F_INT(constant.constant, 256, CG_INTEGER_DEFAULT_TYPE); 06345 06346 if (! size_offset_binary_calc(&wd_storage_size, 06347 &constant, 06348 Mult_Opr, 06349 &temp_1)) { 06350 goto ERROR; /* (size * 256) */ 06351 } 06352 06353 06354 /* t$2 = t$1 / 4096) */ 06355 06356 C_TO_F_INT(constant.constant, 4096, CG_INTEGER_DEFAULT_TYPE); 06357 06358 if (! size_offset_binary_calc(&temp_1, &constant, Div_Opr, &temp_2)) { 06359 goto ERROR; /* (256 * size) / 4096) */ 06360 } 06361 06362 06363 /* t$1 = t$2 + 7 */ 06364 06365 C_TO_F_INT(constant.constant, 7, CG_INTEGER_DEFAULT_TYPE); 06366 06367 if (! size_offset_binary_calc(&temp_2, &constant, Plus_Opr, &temp_1)) { 06368 goto ERROR; /* ((256 * size) / 4096) + 7) */ 06369 } 06370 06371 06372 /* t$2 = t$1 / 8 */ 06373 06374 C_TO_F_INT(constant.constant, 8, CG_INTEGER_DEFAULT_TYPE); 06375 06376 if (! size_offset_binary_calc(&temp_1, &constant, Div_Opr, &temp_2)) { 06377 goto ERROR; /* (((256 * size) / 4096) + 7) / 8 ) */ 06378 } 06379 06380 06381 /* t$1 = t$2 * 8 */ 06382 06383 if (! size_offset_binary_calc(&temp_2, &constant, Mult_Opr, &temp_1)) { 06384 goto ERROR; /* (((((256 * size) / 4096) + 7) / 8 ) * 8) */ 06385 } 06386 06387 06388 /* temp_2 = min_result * t$1 */ 06389 06390 if (!size_offset_binary_calc(&min_result, &temp_1, Mult_Opr, &temp_2)) { 06391 goto ERROR; /* (MIN(1,size/1024) * (((((256*size/4096))+7)/8)*8) */ 06392 } 06393 06394 06395 /* pad = MIN(256, temp_2) */ 06396 06397 C_TO_F_INT(constant.constant, 256, CG_INTEGER_DEFAULT_TYPE); 06398 06399 if (! size_offset_min_max_calc(&constant, &temp_2, Min_Opr, pad)) { 06400 06401 /* (MAX(256,(MIN(1,size/1024)*(((((256*size/4096))+7)/8)*8)))) */ 06402 06403 goto ERROR; 06404 } 06405 06406 06407 /* t$1 = size / 128 */ 06408 06409 C_TO_F_INT(constant.constant, 128, CG_INTEGER_DEFAULT_TYPE); 06410 06411 if (! size_offset_binary_calc(&wd_storage_size, 06412 &constant, 06413 Div_Opr, 06414 &temp_1)) { 06415 goto ERROR; /* size/128 */ 06416 } 06417 06418 06419 /* min_result = MIN(1, t$1) */ 06420 06421 C_TO_F_INT(constant.constant, 1, CG_INTEGER_DEFAULT_TYPE); 06422 06423 if (! size_offset_min_max_calc(&constant, 06424 &temp_1, 06425 Min_Opr, 06426 &min_result)) { 06427 goto ERROR; /* MIN(1, size/128) */ 06428 } 06429 06430 06431 /* t$1 = min_result * 8 */ 06432 06433 C_TO_F_INT(constant.constant, 8, CG_INTEGER_DEFAULT_TYPE); 06434 06435 if (! size_offset_binary_calc(&min_result, 06436 &constant, 06437 Mult_Opr, 06438 &temp_1)) { 06439 goto ERROR; /* MIN(1, size/128) * 8 */ 06440 } 06441 06442 06443 /* pad = pad + t$1 */ 06444 06445 if (! size_offset_binary_calc(pad, &temp_1, Plus_Opr, pad)) { 06446 goto ERROR; /* first term + second term */ 06447 } 06448 06449 06450 /* t$1 = MOD(size, 8) */ 06451 06452 C_TO_F_INT(constant.constant, 8, CG_INTEGER_DEFAULT_TYPE); 06453 06454 if (! size_offset_binary_calc(&wd_storage_size, 06455 &constant, 06456 Mod_Opr, 06457 &temp_1)) { 06458 goto ERROR; /* mod(size, 8) */ 06459 } 06460 06461 06462 /* t$2 = 8 - t$1 */ 06463 06464 if (! size_offset_binary_calc(&constant, &temp_1, Minus_Opr, &temp_2)) { 06465 goto ERROR; /* (8 - mod(size, 8)) */ 06466 } 06467 06468 06469 /* t$1 = MOD(t$2, 8) */ 06470 06471 if (! size_offset_binary_calc(&temp_2, &constant, Mod_Opr, &temp_1)) { 06472 goto ERROR; /* mod((8 - mod(size, 8)), 8) */ 06473 } 06474 06475 06476 /* pad = pad + t$1 */ 06477 06478 if (! size_offset_binary_calc(pad, &temp_1, Plus_Opr, pad)) { 06479 goto ERROR; /* Add third term to accumulated first two terms. */ 06480 } 06481 } 06482 else { 06483 (*pad).fld = NO_Tbl_Idx; 06484 (*pad).type_idx = CG_INTEGER_DEFAULT_TYPE; 06485 C_TO_F_INT((*pad).constant, 06486 SB_PAD_AMOUNT(sb_idx), 06487 CG_INTEGER_DEFAULT_TYPE); 06488 } 06489 06490 constant.fld = NO_Tbl_Idx; 06491 constant.type_idx = CG_INTEGER_DEFAULT_TYPE; 06492 C_TO_F_INT(constant.constant, TARGET_BITS_PER_WORD, CG_INTEGER_DEFAULT_TYPE); 06493 06494 if (!size_offset_binary_calc(pad, &constant, Mult_Opr, pad)) { 06495 goto ERROR; 06496 } 06497 06498 goto DONE; 06499 06500 ERROR: 06501 (*pad).fld = CN_Tbl_Idx; 06502 (*pad).idx = CN_INTEGER_ZERO_IDX; 06503 06504 DONE: 06505 06506 TRACE (Func_Exit, "calculate_pad", NULL); 06507 06508 return; 06509 06510 } /* calculate_pad */ 06511 06512 /******************************************************************************\ 06513 |* *| 06514 |* Description: *| 06515 |* Allocate storage. *| 06516 |* *| 06517 |* Input parameters: *| 06518 |* NONE *| 06519 |* *| 06520 |* Output parameters: *| 06521 |* NONE *| 06522 |* *| 06523 |* Returns: *| 06524 |* NOTHING *| 06525 |* *| 06526 \******************************************************************************/ 06527 boolean srch_global_name_tbl(char *name_str, 06528 int name_len, 06529 int *name_idx) 06530 06531 { 06532 boolean found; 06533 int idx; 06534 long tst_val; 06535 06536 06537 TRACE (Func_Entry, "srch_global_name_tbl", name_str); 06538 06539 tst_val = srch_name_tbl(name_str, 06540 name_len, 06541 &idx, 06542 global_name_tbl, 06543 str_pool, 06544 1, 06545 global_name_tbl_idx); 06546 *name_idx = idx; 06547 06548 if (tst_val != 0) { 06549 found = FALSE; 06550 TRACE (Func_Exit, "srch_global_name_tbl", NULL); 06551 } 06552 else { 06553 found = TRUE; 06554 TRACE (Func_Exit, "srch_global_name_tbl", 06555 &str_pool[GN_NAME_IDX(idx)].name_char); 06556 } 06557 return (found); 06558 06559 } /* srch_global_name_tbl */ 06560 06561 /******************************************************************************\ 06562 |* *| 06563 |* Description: *| 06564 |* *| 06565 |* Input parameters: *| 06566 |* attr_idx NULL if this is a common block, otherwise attr entry *| 06567 |* of global program unit to enter. *| 06568 |* sb_idx NULL if this is a common block inserted during *| 06569 |* commandline processing. The caller is expected to *| 06570 |* get name and length inserted correctly. Otherwise if *| 06571 |* this is a common block, this is the sb_idx for the blk*| 06572 |* name_idx string table index where entry is to be inserted *| 06573 |* *| 06574 |* Output parameters: *| 06575 |* NONE *| 06576 |* *| 06577 |* Returns: *| 06578 |* NONE *| 06579 |* *| 06580 \******************************************************************************/ 06581 06582 void ntr_global_name_tbl(int attr_idx, 06583 int sb_idx, 06584 int name_idx) 06585 06586 06587 { 06588 int ga_idx; 06589 register int i; 06590 register long *id; 06591 register int length; 06592 06593 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 06594 register long *global_tbl_base; 06595 # endif 06596 06597 06598 TRACE (Func_Entry, "ntr_global_name_tbl", NULL); 06599 06600 TBL_REALLOC_CK(global_name_tbl, 1); 06601 06602 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 06603 global_tbl_base = (long *) global_name_tbl; 06604 06605 for (i = global_name_tbl_idx; i >= name_idx; i--) { 06606 global_tbl_base[i] = global_tbl_base[i-1]; 06607 } 06608 06609 # else 06610 for (i = global_name_tbl_idx; i >= name_idx; i--) { 06611 global_name_tbl[i] = global_name_tbl[i-1]; 06612 } 06613 # endif 06614 06615 CLEAR_TBL_NTRY(global_name_tbl, name_idx); 06616 06617 if (sb_idx != NULL_IDX) { 06618 id = SB_NAME_LONG(sb_idx); 06619 length = SB_NAME_LEN(sb_idx); 06620 GN_NAME_IDX(name_idx) = str_pool_idx + 1; 06621 GN_NAME_LEN(name_idx) = length; 06622 length = WORD_LEN(length); 06623 06624 /* add identifier to string pool */ 06625 06626 TBL_REALLOC_CK (str_pool, length); 06627 06628 for (i = 0; i < length; i++) { 06629 str_pool[GN_NAME_IDX(name_idx) + i].name_long = id[i]; 06630 } 06631 06632 ga_idx = ntr_common_in_global_attr_tbl(sb_idx, name_idx); 06633 06634 GN_ATTR_IDX(name_idx) = ga_idx; 06635 } 06636 else if (attr_idx != NULL_IDX) { 06637 ga_idx = ntr_global_attr_tbl(attr_idx, NULL_IDX); 06638 GN_ATTR_IDX(name_idx) = ga_idx; 06639 GN_NAME_IDX(name_idx) = GA_NAME_IDX(ga_idx); 06640 GN_NAME_LEN(name_idx) = GA_NAME_LEN(ga_idx); 06641 06642 fill_in_global_attr_ntry(ga_idx, attr_idx, NULL_IDX); 06643 06644 } 06645 06646 TRACE (Func_Exit, "ntr_global_name_tbl", NULL); 06647 06648 return; 06649 06650 } /* ntr_global_name_tbl */ 06651 06652 /******************************************************************************\ 06653 |* *| 06654 |* Description: *| 06655 |* Fills in the variant part of a global attr entry. Assumes that *| 06656 |* ntr_global_attr_tbl or some other mechanism has been used to set up *| 06657 |* the common fields in this global attr entry. *| 06658 |* *| 06659 |* NOTE: ntr_global_attr_tbl and fill_in_global_attr_ntry are two *| 06660 |* separate routines, because there are not linked lists for *| 06661 |* components or dargs in the global attr table. They are *| 06662 |* assumed to be consecutive, so we need to create space for *| 06663 |* the correct number of components or dargs and then fill them *| 06664 |* in later. *| 06665 |* *| 06666 |* Input parameters: *| 06667 |* ga_idx -> global attr entry that needs to be filled in. *| 06668 |* attr_idx -> attr entry of attr to enter in global attr table. *| 06669 |* ga_pgm_idx -> If this is a darg or func result, this is its pgm unit. *| 06670 |* *| 06671 |* Output parameters: *| 06672 |* NONE *| 06673 |* *| 06674 |* Returns: *| 06675 |* NONE *| 06676 |* *| 06677 \******************************************************************************/ 06678 06679 void fill_in_global_attr_ntry(int ga_idx, 06680 int attr_idx, 06681 int ga_pgm_idx) 06682 06683 { 06684 int cn_idx; 06685 int first_sn_idx; 06686 int ga_darg_idx; 06687 int i; 06688 int module_idx; 06689 int name_idx; 06690 int new_idx; 06691 int num_dargs; 06692 int rslt_idx; 06693 int sn_idx; 06694 06695 06696 TRACE (Func_Entry, "fill_in_global_attr_ntry", NULL); 06697 06698 module_idx = AT_MODULE_IDX(attr_idx); 06699 06700 if (module_idx != NULL_IDX) { 06701 06702 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(module_idx), 06703 AT_NAME_LEN(module_idx), 06704 &name_idx)) { 06705 06706 /* Found - Make sure it is a module and not something else */ 06707 06708 /* It should be in here already - KAY - internal ??? */ 06709 06710 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 06711 GA_MODULE_IDX(ga_idx) = GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)); 06712 } 06713 else { 06714 GA_MODULE_IDX(ga_idx) = GN_ATTR_IDX(name_idx); 06715 } 06716 } 06717 else { 06718 ntr_global_name_tbl(module_idx, NULL_IDX, name_idx); 06719 GA_MODULE_IDX(ga_idx) = GN_ATTR_IDX(name_idx); 06720 } 06721 } 06722 06723 switch (AT_OBJ_CLASS(attr_idx)) { 06724 case Data_Obj: 06725 06726 GAD_CLASS(ga_idx) = ATD_CLASS(attr_idx); 06727 GAD_POINTER(ga_idx) = ATD_POINTER(attr_idx); 06728 GAD_TARGET(ga_idx) = ATD_TARGET(attr_idx); 06729 06730 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 06731 06732 /* We actually only need an array entry if this is a component or */ 06733 /* if this is a member of the common block. Those are the only */ 06734 /* two places where we need to check the lower and upper bounds. */ 06735 06736 if (ATD_CLASS(attr_idx) == Struct_Component || 06737 ATD_IN_COMMON(attr_idx)) { 06738 new_idx = ntr_global_bounds_tbl(ATD_ARRAY_IDX(attr_idx)); 06739 GAD_ARRAY_IDX(ga_idx) = new_idx; 06740 } 06741 GAD_RANK(ga_idx) = BD_RANK(ATD_ARRAY_IDX(attr_idx)); 06742 GAD_ASSUMED_SHAPE_ARRAY(ga_idx) = 06743 (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape); 06744 } 06745 06746 switch (ATD_CLASS(attr_idx)) { 06747 case Dummy_Argument: 06748 GAD_INTENT(ga_idx) = ATD_INTENT(attr_idx); 06749 new_idx = ntr_global_type_tbl(ATD_TYPE_IDX(attr_idx)); 06750 GAD_TYPE_IDX(ga_idx) = new_idx; 06751 06752 if (GAD_ASSUMED_SHAPE_ARRAY(ga_idx) || 06753 GA_OPTIONAL(ga_idx) || 06754 GAD_POINTER(ga_idx) || 06755 GAD_TARGET(ga_idx)) { 06756 GAP_NEEDS_EXPL_ITRFC(ga_pgm_idx) = TRUE; 06757 } 06758 break; 06759 06760 case Function_Result: 06761 new_idx = ntr_global_type_tbl(ATD_TYPE_IDX(attr_idx)); 06762 GAD_TYPE_IDX(ga_idx) = new_idx; 06763 06764 if (GAD_RANK(ga_idx) != 0 || 06765 GAD_POINTER(ga_idx) || 06766 (GT_TYPE(GAD_TYPE_IDX(ga_idx)) == Character && 06767 GT_CHAR_CLASS(GAD_TYPE_IDX(ga_idx)) == Var_Len_Char)) { 06768 GAP_NEEDS_EXPL_ITRFC(ga_pgm_idx) = TRUE; 06769 } 06770 break; 06771 06772 case CRI__Pointee: 06773 new_idx = ntr_global_type_tbl(ATD_TYPE_IDX(attr_idx)); 06774 GAD_TYPE_IDX(ga_idx) = new_idx; 06775 break; 06776 06777 case Struct_Component: 06778 06779 if (ATD_POINTER(attr_idx) && 06780 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Derived_Type && 06781 attr_idx == TYP_IDX(ATD_TYPE_IDX(attr_idx))) { 06782 06783 /* Pointing to itself - type must be set in self before call here */ 06784 06785 GAD_TYPE_IDX(ga_idx) = ATT_GLOBAL_TYPE_IDX(attr_idx); 06786 } 06787 else { 06788 new_idx = ntr_global_type_tbl(ATD_TYPE_IDX(attr_idx)); 06789 GAD_TYPE_IDX(ga_idx) = new_idx; 06790 } 06791 break; 06792 06793 case Variable: 06794 new_idx = ntr_global_type_tbl(ATD_TYPE_IDX(attr_idx)); 06795 GAD_TYPE_IDX(ga_idx) = new_idx; 06796 break; 06797 06798 default: 06799 new_idx = ntr_global_type_tbl(ATD_TYPE_IDX(attr_idx)); 06800 GAD_TYPE_IDX(ga_idx) = new_idx; 06801 break; 06802 } 06803 break; 06804 06805 case Pgm_Unit: 06806 06807 GAP_PGM_UNIT(ga_idx) = ATP_PGM_UNIT(attr_idx); 06808 GAP_ELEMENTAL(ga_idx) = ATP_ELEMENTAL(attr_idx); 06809 GAP_NOSIDE_EFFECTS(ga_idx) = ATP_NOSIDE_EFFECTS(attr_idx); 06810 GAP_PURE(ga_idx) = ATP_PURE(attr_idx); 06811 GAP_RECURSIVE(ga_idx) = ATP_RECURSIVE(attr_idx); 06812 GAP_VFUNCTION(ga_idx) = ATP_VFUNCTION(attr_idx); 06813 ATP_GLOBAL_ATTR_IDX(attr_idx) = ga_idx; 06814 06815 if (GAP_ELEMENTAL(ga_idx)) { 06816 GAP_NEEDS_EXPL_ITRFC(ga_idx) = TRUE; 06817 } 06818 06819 # if 0 06820 if (attr_idx == SCP_ATTR_IDX(curr_scp_idx) || 06821 (ATP_ALT_ENTRY(attr_idx) && ATP_SCP_ALIVE(attr_idx))) { 06822 } /* remove this bracket */ 06823 # endif 06824 if (ATP_EXPL_ITRFC(attr_idx)) { 06825 GA_DEFINED(ga_idx) = TRUE; 06826 06827 if (SCP_IS_INTERFACE(curr_scp_idx)) { 06828 GAP_IN_INTERFACE_BLK(ga_idx) = TRUE; 06829 } 06830 else { 06831 GAP_PGM_UNIT_DEFINED(ga_idx) = TRUE; 06832 } 06833 } 06834 else if (AT_REFERENCED(attr_idx) > Not_Referenced) { 06835 GA_REFERENCED(ga_idx) = TRUE; 06836 } 06837 else { /* Declared via EXTERNAL, VFUNCTION, NOSIDEFFECTS ect.. */ 06838 } 06839 06840 if (ATP_PGM_UNIT(attr_idx) == Function || 06841 ATP_PGM_UNIT(attr_idx) == Subroutine) { 06842 06843 /* If there is an extra darg - never put it in here. We've got the */ 06844 /* function result information. That would be duplicating plus we */ 06845 /* ensure we've always got the same thing when we do compares. */ 06846 06847 if (ATP_EXTRA_DARG(attr_idx) && ATP_EXPL_ITRFC(attr_idx)) { 06848 first_sn_idx = ATP_FIRST_IDX(attr_idx) + 1; 06849 num_dargs = ATP_NUM_DARGS(attr_idx) - 1; 06850 } 06851 else { 06852 first_sn_idx = ATP_FIRST_IDX(attr_idx); 06853 num_dargs = ATP_NUM_DARGS(attr_idx); 06854 } 06855 06856 GAP_NUM_DARGS(ga_idx) = num_dargs; 06857 06858 if (num_dargs > 0) { 06859 ga_darg_idx = global_attr_tbl_idx + 1; 06860 GAP_FIRST_IDX(ga_idx) = ga_darg_idx; 06861 sn_idx = first_sn_idx; 06862 06863 /* Reserve space for the dummy arguments so they are in */ 06864 /* consecutive order. Then return and fill them in. */ 06865 06866 for (i = 0; i < num_dargs; i++ ) { 06867 ntr_global_attr_tbl(SN_ATTR_IDX(sn_idx), NULL_IDX); 06868 sn_idx++; 06869 } 06870 06871 sn_idx = first_sn_idx; 06872 06873 for (i = 0; i < num_dargs; i++) { 06874 fill_in_global_attr_ntry(ga_darg_idx, 06875 SN_ATTR_IDX(sn_idx), 06876 ga_idx); 06877 if (SN_LINE_NUM(sn_idx) != 0) { 06878 GA_DEF_LINE(ga_darg_idx) = SN_LINE_NUM(sn_idx); 06879 GA_DEF_COLUMN(ga_darg_idx) = SN_COLUMN_NUM(sn_idx); 06880 } 06881 ga_darg_idx++; 06882 sn_idx++; 06883 } 06884 } 06885 06886 if (ATP_RSLT_IDX(attr_idx) != NULL_IDX) { 06887 rslt_idx = ntr_global_attr_tbl(ATP_RSLT_IDX(attr_idx), NULL_IDX); 06888 fill_in_global_attr_ntry(rslt_idx, ATP_RSLT_IDX(attr_idx), ga_idx); 06889 GAP_RSLT_IDX(ga_idx) = rslt_idx; 06890 } 06891 06892 } 06893 break; 06894 06895 case Derived_Type: 06896 GAT_NUM_CPNTS(ga_idx) = ATT_NUM_CPNTS(attr_idx); 06897 GAT_PRIVATE_CPNT(ga_idx) = ATT_PRIVATE_CPNT(attr_idx); 06898 GAT_SEQUENCE_SET(ga_idx) = ATT_SEQUENCE_SET(attr_idx); 06899 cn_idx = ATT_STRUCT_BIT_LEN_IDX(attr_idx); 06900 GAT_STRUCT_LIN_TYPE(ga_idx) = TYP_LINEAR(CN_TYPE_IDX(cn_idx)); 06901 06902 for (i = 0; i < num_host_wds[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]; i++) { 06903 GAT_STRUCT_BIT_LEN(ga_idx)[i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + i); 06904 } 06905 06906 break; 06907 } 06908 06909 TRACE (Func_Exit, "fill_in_global_attr_ntry", NULL); 06910 06911 return; 06912 06913 } /* fill_in_global_attr_ntry */ 06914 06915 /******************************************************************************\ 06916 |* *| 06917 |* Description: *| 06918 |* Enters an attr entry into the global attr table. This just sets up *| 06919 |* the common global attr fields, such as line number and names. *| 06920 |* *| 06921 |* Input parameters: *| 06922 |* attr_idx attr entry of attr to enter in global attr table. *| 06923 |* name_idx This is used to get the string pool idx for the name. *| 06924 |* *| 06925 |* Output parameters: *| 06926 |* NONE *| 06927 |* *| 06928 |* Returns: *| 06929 |* ga_idx New global attr tbl index. *| 06930 |* *| 06931 \******************************************************************************/ 06932 06933 int ntr_global_attr_tbl(int attr_idx, 06934 int name_idx) 06935 06936 { 06937 int ga_idx; 06938 int i; 06939 long *id; 06940 int length; 06941 06942 06943 TRACE (Func_Entry, "ntr_global_attr_tbl", NULL); 06944 06945 TBL_REALLOC_CK(global_attr_tbl, 1); 06946 CLEAR_TBL_NTRY(global_attr_tbl, global_attr_tbl_idx); 06947 ga_idx = global_attr_tbl_idx; 06948 06949 if (name_idx == NULL_IDX) { 06950 06951 if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit && 06952 ATP_PGM_UNIT(attr_idx) == Module && 06953 ATP_MODULE_STR_IDX(attr_idx) != NULL_IDX) { 06954 GN_NAME_IDX(ga_idx) = ATP_MODULE_STR_IDX(attr_idx); 06955 GA_NAME_LEN(ga_idx) = AT_NAME_LEN(attr_idx); 06956 } 06957 else { 06958 id = AT_OBJ_NAME_LONG(attr_idx); 06959 length = AT_NAME_LEN(attr_idx); 06960 GA_NAME_IDX(ga_idx) = str_pool_idx + 1; 06961 GA_NAME_LEN(ga_idx) = length; 06962 length = WORD_LEN(length); 06963 06964 /* add identifier to string pool */ 06965 06966 TBL_REALLOC_CK (str_pool, length); 06967 06968 for (i = 0; i < length; i++) { 06969 str_pool[GA_NAME_IDX(ga_idx) + i].name_long = id[i]; 06970 } 06971 } 06972 } 06973 else { 06974 GA_NAME_IDX(ga_idx) = GN_NAME_IDX(name_idx); 06975 GA_NAME_LEN(ga_idx) = GN_NAME_LEN(name_idx);; 06976 } 06977 06978 if (AT_ORIG_NAME_IDX(attr_idx) == AT_NAME_IDX(attr_idx)) { 06979 GA_ORIG_NAME_IDX(ga_idx) = GA_NAME_IDX(ga_idx); 06980 GA_ORIG_NAME_LEN(ga_idx) = GA_NAME_LEN(ga_idx); 06981 } 06982 else if (AT_ORIG_NAME_IDX(attr_idx) != NULL_IDX) { 06983 id = AT_ORIG_NAME_LONG(attr_idx); 06984 length = AT_ORIG_NAME_LEN(attr_idx); 06985 GA_ORIG_NAME_IDX(ga_idx) = str_pool_idx + 1; 06986 GA_ORIG_NAME_LEN(ga_idx) = length; 06987 length = WORD_LEN(length); 06988 06989 /* add identifier to string pool */ 06990 06991 TBL_REALLOC_CK (str_pool, length); 06992 06993 for (i = 0; i < length; i++) { 06994 str_pool[GA_ORIG_NAME_IDX(ga_idx) + i].name_long = id[i]; 06995 } 06996 } 06997 06998 GA_DEF_LINE(ga_idx) = AT_DEF_LINE(attr_idx); 06999 GA_DEF_COLUMN(ga_idx) = AT_DEF_COLUMN(attr_idx); 07000 GA_OBJ_CLASS(ga_idx) = AT_OBJ_CLASS(attr_idx); 07001 GA_OPTIONAL(ga_idx) = AT_OPTIONAL(attr_idx); 07002 GA_COMPILER_GEND(ga_idx) = AT_COMPILER_GEND(attr_idx); 07003 GA_USE_ASSOCIATED(ga_idx) = AT_USE_ASSOCIATED(attr_idx); 07004 07005 TRACE (Func_Exit, "ntr_global_attr_tbl", NULL); 07006 07007 return(ga_idx); 07008 07009 } /* ntr_global_attr_tbl */ 07010 07011 /******************************************************************************\ 07012 |* *| 07013 |* Description: *| 07014 |* *| 07015 |* Input parameters: *| 07016 |* *| 07017 |* Output parameters: *| 07018 |* NONE *| 07019 |* *| 07020 |* Returns: *| 07021 |* NONE *| 07022 |* *| 07023 \******************************************************************************/ 07024 07025 int ntr_common_in_global_attr_tbl(int sb_idx, 07026 int name_idx) 07027 07028 { 07029 int attr_idx; 07030 int ga_idx; 07031 int new_idx; 07032 int prev_idx; 07033 07034 07035 TRACE (Func_Entry, "ntr_common_in_global_attr_tbl", NULL); 07036 07037 TBL_REALLOC_CK(global_attr_tbl, 1); 07038 CLEAR_TBL_NTRY(global_attr_tbl, global_attr_tbl_idx); 07039 ga_idx = global_attr_tbl_idx; 07040 GA_NAME_IDX(ga_idx) = GN_NAME_IDX(name_idx); 07041 GA_NAME_LEN(ga_idx) = GN_NAME_LEN(name_idx); 07042 GA_DEF_LINE(ga_idx) = SB_DEF_LINE(sb_idx); 07043 GA_DEF_COLUMN(ga_idx) = SB_DEF_COLUMN(sb_idx); 07044 GA_OBJ_CLASS(ga_idx) = Common_Block; 07045 GA_USE_ASSOCIATED(ga_idx) = SB_USE_ASSOCIATED(sb_idx); 07046 GAC_AUXILIARY(ga_idx) = SB_AUXILIARY(sb_idx); 07047 GAC_TASK_COMMON(ga_idx) = SB_BLK_TYPE(sb_idx) == Task_Common; 07048 GAC_EQUIVALENCED(ga_idx) = SB_EQUIVALENCED(sb_idx); 07049 GAC_ALIGN_SYMBOL(ga_idx) = SB_ALIGN_SYMBOL(sb_idx); 07050 GAC_FILL_SYMBOL(ga_idx) = SB_FILL_SYMBOL(sb_idx); 07051 GAC_SECTION_GP(ga_idx) = SB_SECTION_GP(sb_idx); 07052 GAC_SECTION_NON_GP(ga_idx) = SB_SECTION_NON_GP(sb_idx); 07053 GAC_CACHE_ALIGN(ga_idx) = SB_CACHE_ALIGN(sb_idx); 07054 07055 /* Need to keep the common entries. */ 07056 07057 attr_idx = SB_FIRST_ATTR_IDX(sb_idx); 07058 prev_idx = NULL_IDX; 07059 07060 while (attr_idx != NULL_IDX) { 07061 new_idx = ntr_global_attr_tbl(attr_idx, NULL_IDX); 07062 fill_in_global_attr_ntry(new_idx, attr_idx, NULL_IDX); 07063 07064 if (prev_idx != NULL_IDX) { 07065 GAD_NEXT_IDX(prev_idx) = new_idx; 07066 } 07067 else { 07068 GAC_FIRST_MEMBER_IDX(ga_idx) = new_idx; 07069 } 07070 prev_idx = new_idx; 07071 attr_idx = ATD_NEXT_MEMBER_IDX(attr_idx); 07072 } 07073 07074 if (SB_MODULE_IDX(sb_idx) != NULL_IDX) { 07075 07076 if (srch_global_name_tbl(AT_OBJ_NAME_PTR(SB_MODULE_IDX(sb_idx)), 07077 AT_NAME_LEN(SB_MODULE_IDX(sb_idx)), 07078 &name_idx)) { 07079 07080 /* Found - Make sure it is a module and not something else */ 07081 07082 /* It should be in here already - KAY - internal ??? */ 07083 07084 if (GA_OBJ_CLASS(GN_ATTR_IDX(name_idx)) == Common_Block) { 07085 GA_MODULE_IDX(ga_idx) = GAC_PGM_UNIT_IDX(GN_ATTR_IDX(name_idx)); 07086 } 07087 else { 07088 GA_MODULE_IDX(ga_idx) = GN_ATTR_IDX(name_idx); 07089 } 07090 } 07091 else { 07092 ntr_global_name_tbl(SB_MODULE_IDX(sb_idx), NULL_IDX, name_idx); 07093 GA_MODULE_IDX(ga_idx) = GN_ATTR_IDX(name_idx); 07094 } 07095 } 07096 07097 TRACE (Func_Exit, "ntr_common_in_global_attr_tbl", NULL); 07098 07099 return(ga_idx); 07100 07101 } /* ntr_common_in_global_attr_tbl */ 07102 07103 /******************************************************************************\ 07104 |* *| 07105 |* Description: *| 07106 |* This routine adds new types to the global type table. It attempts *| 07107 |* to share them all. If you are entering Typeless, pass Err_Res *| 07108 |* for the lin_type, and this routine will set it correctly.) *| 07109 |* *| 07110 |* Input parameters: *| 07111 |* NONE *| 07112 |* *| 07113 |* Output parameters: *| 07114 |* NONE *| 07115 |* *| 07116 |* Returns: *| 07117 |* NONE *| 07118 |* *| 07119 \******************************************************************************/ 07120 int ntr_global_type_tbl(int type_idx) 07121 07122 { 07123 int attr_idx; 07124 int cn_idx; 07125 boolean found; 07126 int ga_idx; 07127 int ga_cpnt_idx; 07128 int i; 07129 int new_type_idx; 07130 long *null_base; 07131 int sn_idx; 07132 long *type_tbl_base; 07133 07134 07135 TRACE (Func_Entry, "ntr_global_type_tbl", NULL); 07136 07137 if (TYP_TYPE(type_idx) == Character) { 07138 GT_TYPE(TYP_WORK_IDX) = TYP_TYPE(type_idx); 07139 GT_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx); 07140 GT_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx); 07141 GT_LINEAR_TYPE(TYP_WORK_IDX) = TYP_LINEAR(type_idx); 07142 GT_CHAR_CLASS(TYP_WORK_IDX) = TYP_CHAR_CLASS(type_idx); 07143 GT_STRUCT_IDX(TYP_WORK_IDX) = TYP_IDX(type_idx); 07144 07145 if (GT_CHAR_CLASS(TYP_WORK_IDX) == Const_Len_Char) { 07146 cn_idx = GT_STRUCT_IDX(TYP_WORK_IDX); 07147 GT_LENGTH_LIN_TYPE(TYP_WORK_IDX) = TYP_LINEAR(CN_TYPE_IDX(cn_idx)); 07148 07149 for (i = 0; i < num_host_wds[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]; i++) { 07150 GT_LENGTH(TYP_WORK_IDX)[i] = CP_CONSTANT(CN_POOL_IDX(cn_idx) + i); 07151 } 07152 } 07153 GT_STRUCT_IDX(TYP_WORK_IDX) = NULL_IDX; 07154 } 07155 else if (TYP_TYPE(type_idx) == Structure) { 07156 07157 if (ATT_GLOBAL_TYPE_IDX(TYP_IDX(type_idx)) != NULL_IDX) { 07158 07159 /* This derived type exists already. Just return the index. */ 07160 07161 new_type_idx = ATT_GLOBAL_TYPE_IDX(TYP_IDX(type_idx)); 07162 goto EXIT; 07163 } 07164 07165 GT_TYPE(TYP_WORK_IDX) = TYP_TYPE(type_idx); 07166 GT_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx); 07167 GT_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx); 07168 GT_LINEAR_TYPE(TYP_WORK_IDX) = TYP_LINEAR(type_idx); 07169 GT_CHAR_CLASS(TYP_WORK_IDX) = TYP_CHAR_CLASS(type_idx); 07170 GT_STRUCT_IDX(TYP_WORK_IDX) = TYP_IDX(type_idx); 07171 07172 attr_idx = GT_STRUCT_IDX(TYP_WORK_IDX); 07173 ga_idx = ntr_global_attr_tbl(attr_idx, NULL_IDX); 07174 07175 TBL_REALLOC_CK(global_type_tbl, 1); 07176 new_type_idx = global_type_tbl_idx; 07177 global_type_tbl[new_type_idx] = global_type_tbl[TYP_WORK_IDX]; 07178 GT_STRUCT_IDX(new_type_idx) = ga_idx; 07179 ATT_GLOBAL_TYPE_IDX(attr_idx) = new_type_idx; 07180 07181 fill_in_global_attr_ntry(ga_idx, attr_idx, NULL_IDX); 07182 07183 ga_cpnt_idx = global_attr_tbl_idx + 1; 07184 GAT_FIRST_CPNT_IDX(ga_idx) = ga_cpnt_idx; 07185 07186 sn_idx = ATT_FIRST_CPNT_IDX(attr_idx); 07187 07188 /* Make space for components, then fill in to handle */ 07189 /* case of derived type pointing to itself. */ 07190 07191 for (i = 0; i < ATT_NUM_CPNTS(attr_idx); i++ ) { 07192 ntr_global_attr_tbl(SN_ATTR_IDX(sn_idx), NULL_IDX); 07193 sn_idx = SN_SIBLING_LINK(sn_idx); 07194 } 07195 07196 sn_idx = ATT_FIRST_CPNT_IDX(attr_idx); 07197 07198 for (i = 0; i < ATT_NUM_CPNTS(attr_idx); i++ ) { 07199 fill_in_global_attr_ntry(ga_cpnt_idx, SN_ATTR_IDX(sn_idx), NULL_IDX); 07200 sn_idx = SN_SIBLING_LINK(sn_idx); 07201 ga_cpnt_idx++; 07202 } 07203 07204 goto EXIT; 07205 } 07206 else { 07207 GT_TYPE(TYP_WORK_IDX) = TYP_TYPE(type_idx); 07208 GT_DCL_VALUE(TYP_WORK_IDX) = TYP_DCL_VALUE(type_idx); 07209 GT_DESC(TYP_WORK_IDX) = TYP_DESC(type_idx); 07210 GT_LINEAR_TYPE(TYP_WORK_IDX) = TYP_LINEAR(type_idx); 07211 GT_CHAR_CLASS(TYP_WORK_IDX) = TYP_CHAR_CLASS(type_idx); 07212 GT_STRUCT_IDX(TYP_WORK_IDX) = TYP_IDX(type_idx); 07213 } 07214 07215 null_base = (long *) global_type_tbl; 07216 07217 for (new_type_idx = 1; new_type_idx <= global_type_tbl_idx; new_type_idx++){ 07218 found = TRUE; 07219 type_tbl_base = (long *) &(global_type_tbl[new_type_idx]); 07220 07221 for (i = 0; i < NUM_TYP_WDS; i++) { 07222 07223 if (null_base[i] != type_tbl_base[i]) { 07224 found = FALSE; 07225 } 07226 } 07227 07228 if (found) { 07229 goto EXIT; 07230 } 07231 } 07232 07233 TBL_REALLOC_CK(global_type_tbl, 1); 07234 new_type_idx = global_type_tbl_idx; 07235 global_type_tbl[new_type_idx] = global_type_tbl[TYP_WORK_IDX]; 07236 07237 EXIT: 07238 07239 TRACE (Func_Exit, "ntr_global_type_tbl", NULL); 07240 07241 return(new_type_idx); 07242 07243 } /* ntr_global_type_tbl */ 07244 07245 /******************************************************************************\ 07246 |* *| 07247 |* Description: *| 07248 |* This routine adds new bound entries to the global bounds table. It *| 07249 |* attempts to share them all. *| 07250 |* *| 07251 |* Input parameters: *| 07252 |* NONE *| 07253 |* *| 07254 |* Output parameters: *| 07255 |* NONE *| 07256 |* *| 07257 |* Returns: *| 07258 |* NONE *| 07259 |* *| 07260 \******************************************************************************/ 07261 static int ntr_global_bounds_tbl(int bd_idx) 07262 07263 { 07264 int cn_idx; 07265 int dim; 07266 boolean found; 07267 int gb_idx; 07268 long *gb_tbl_base; 07269 int i; 07270 long *new_base; 07271 int new_gb_idx; 07272 int size; 07273 int type_idx; 07274 07275 07276 TRACE (Func_Entry, "ntr_global_bounds_tbl", NULL); 07277 07278 if (BD_GLOBAL_IDX(bd_idx) != NULL_IDX) { 07279 return(BD_GLOBAL_IDX(bd_idx)); 07280 } 07281 07282 /* Only keep upper and lower bounds for constant size explicit shape arrays*/ 07283 07284 /* size = (BD_ARRAY_CLASS(bd_idx) != Explicit_Shape || */ 07285 /* BD_ARRAY_SIZE(bd_idx) != Constant_Size) ? 1 : 1+(BD_RANK(bd_idx)*3); */ 07286 size =1+(BD_RANK(bd_idx)*3); 07287 07288 gb_idx = global_bounds_tbl_idx + 1; 07289 07290 TBL_REALLOC_CK(global_bounds_tbl, size); 07291 07292 GB_RANK(gb_idx) = BD_RANK(bd_idx); 07293 GB_ARRAY_SIZE(gb_idx) = BD_ARRAY_SIZE(bd_idx); 07294 GB_ARRAY_CLASS(gb_idx) = BD_ARRAY_CLASS(bd_idx); 07295 07296 if (size > 1) { 07297 07298 for (dim = 1; dim <= BD_RANK(bd_idx); dim++) { 07299 07300 if (BD_LB_FLD(bd_idx,dim) == CN_Tbl_Idx) { 07301 cn_idx = BD_LB_IDX(bd_idx, dim); 07302 07303 for (i = 0; i < num_host_wds[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]; i++){ 07304 GB_LOWER_BOUND(gb_idx, dim)[i] = 07305 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i); 07306 } 07307 type_idx = ntr_global_type_tbl(CN_TYPE_IDX(cn_idx)); 07308 GB_LB_TYPE(gb_idx, dim) = type_idx; 07309 } 07310 07311 if (BD_UB_FLD(bd_idx,dim) == CN_Tbl_Idx) { 07312 cn_idx = BD_UB_IDX(bd_idx, dim); 07313 07314 for (i = 0; i < num_host_wds[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]; i++){ 07315 GB_UPPER_BOUND(gb_idx, dim)[i] = 07316 CP_CONSTANT(CN_POOL_IDX(cn_idx) + i); 07317 } 07318 type_idx = ntr_global_type_tbl(CN_TYPE_IDX(cn_idx)); 07319 GB_UB_TYPE(gb_idx, dim) = type_idx; 07320 } 07321 } 07322 } 07323 07324 new_base = (long *) &(global_bounds_tbl[gb_idx]); 07325 new_gb_idx = 1; 07326 07327 while (new_gb_idx <= (gb_idx - 1)) { 07328 found = TRUE; 07329 gb_tbl_base = (long *) &(global_bounds_tbl[new_gb_idx]); 07330 07331 /* Check header information */ 07332 07333 for (i = 0; i < NUM_GB_WDS; i++) { 07334 07335 if (new_base[i] != gb_tbl_base[i]) { 07336 found = FALSE; 07337 } 07338 } 07339 07340 if (found && (size > 1)) { /* Matched header. Now check dimensions */ 07341 07342 for (i = 0; i < (GB_RANK(gb_idx) * 3); i++) { 07343 07344 if (new_base[i] != gb_tbl_base[i]) { 07345 found = FALSE; 07346 } 07347 } 07348 } 07349 07350 if (found) { 07351 global_bounds_tbl_idx = gb_idx - 1; /* Reset */ 07352 gb_idx = new_gb_idx; 07353 goto EXIT; 07354 } 07355 new_gb_idx += NUM_GB_WDS; 07356 07357 if (GB_ARRAY_SIZE(new_gb_idx) == Constant_Size && 07358 GB_ARRAY_CLASS(new_gb_idx) == Explicit_Shape) { 07359 new_gb_idx += (3 * GB_RANK(new_gb_idx)); 07360 } 07361 } 07362 07363 EXIT: 07364 BD_GLOBAL_IDX(bd_idx) = gb_idx; 07365 07366 TRACE (Func_Exit, "ntr_global_bounds_tbl", NULL); 07367 07368 return(gb_idx); 07369 07370 } /* ntr_global_bounds_tbl */ 07371 07372 /******************************************************************************\ 07373 |* *| 07374 |* Description: *| 07375 |* *| 07376 |* Input parameters: *| 07377 |* NONE *| 07378 |* *| 07379 |* Output parameters: *| 07380 |* NONE *| 07381 |* *| 07382 |* Returns: *| 07383 |* new ir idx *| 07384 |* *| 07385 \******************************************************************************/ 07386 int ntr_ir_tbl(void) 07387 07388 { 07389 int ir_idx; 07390 07391 07392 TRACE (Func_Entry, "ntr_ir_tbl", NULL); 07393 07394 if (IR_NEXT_IDX(NULL_IDX) != NULL_IDX) { 07395 ir_idx = IR_NEXT_IDX(NULL_IDX); 07396 IR_NEXT_IDX(NULL_IDX) = IR_NEXT_IDX(ir_idx); 07397 } 07398 else { 07399 TBL_REALLOC_CK(ir_tbl,1); 07400 ir_idx = ir_tbl_idx; 07401 } 07402 07403 CLEAR_TBL_NTRY(ir_tbl, ir_idx); 07404 07405 TRACE (Func_Exit, "ntr_ir_tbl", NULL); 07406 07407 return(ir_idx); 07408 07409 } /* ntr_ir_tbl */ 07410 07411 /******************************************************************************\ 07412 |* *| 07413 |* Description: *| 07414 |* *| 07415 |* Input parameters: *| 07416 |* NONE *| 07417 |* *| 07418 |* Output parameters: *| 07419 |* NONE *| 07420 |* *| 07421 |* Returns: *| 07422 |* new il idx *| 07423 |* *| 07424 \******************************************************************************/ 07425 int ntr_ir_list_tbl(void) 07426 07427 { 07428 int il_idx; 07429 07430 07431 TRACE (Func_Entry, "ntr_ir_list_tbl", NULL); 07432 07433 if (IL_NEXT_LIST_IDX(NULL_IDX) != NULL_IDX) { 07434 il_idx = IL_NEXT_LIST_IDX(NULL_IDX); 07435 IL_NEXT_LIST_IDX(NULL_IDX) = IL_NEXT_LIST_IDX(il_idx); 07436 } 07437 else { 07438 TBL_REALLOC_CK (ir_list_tbl,1); 07439 il_idx = ir_list_tbl_idx; 07440 } 07441 07442 CLEAR_TBL_NTRY(ir_list_tbl, il_idx); 07443 07444 TRACE (Func_Exit, "ntr_ir_list_tbl", NULL); 07445 07446 return(il_idx); 07447 07448 } /* ntr_ir_list_tbl */ 07449 07450 /******************************************************************************\ 07451 |* *| 07452 |* Description: *| 07453 |* *| 07454 |* Input parameters: *| 07455 |* NONE *| 07456 |* *| 07457 |* Output parameters: *| 07458 |* NONE *| 07459 |* *| 07460 |* Returns: *| 07461 |* new ir idx *| 07462 |* *| 07463 \******************************************************************************/ 07464 int ntr_gl_ir_tbl(void) 07465 07466 { 07467 int ir_idx; 07468 07469 07470 TRACE (Func_Entry, "ntr_gl_ir_tbl", NULL); 07471 07472 TBL_REALLOC_CK(global_ir_tbl,1); 07473 ir_idx = global_ir_tbl_idx; 07474 07475 CLEAR_TBL_NTRY(global_ir_tbl, ir_idx); 07476 07477 TRACE (Func_Exit, "ntr_gl_ir_tbl", NULL); 07478 07479 return(ir_idx); 07480 07481 } /* ntr_gl_ir_tbl */ 07482 07483 /******************************************************************************\ 07484 |* *| 07485 |* Description: *| 07486 |* *| 07487 |* Input parameters: *| 07488 |* NONE *| 07489 |* *| 07490 |* Output parameters: *| 07491 |* NONE *| 07492 |* *| 07493 |* Returns: *| 07494 |* new il idx *| 07495 |* *| 07496 \******************************************************************************/ 07497 int ntr_gl_ir_list_tbl(void) 07498 07499 { 07500 int il_idx; 07501 07502 07503 TRACE (Func_Entry, "ntr_gl_ir_list_tbl", NULL); 07504 07505 TBL_REALLOC_CK (global_ir_list_tbl,1); 07506 il_idx = global_ir_list_tbl_idx; 07507 07508 CLEAR_TBL_NTRY(global_ir_list_tbl, il_idx); 07509 07510 TRACE (Func_Exit, "ntr_gl_ir_list_tbl", NULL); 07511 07512 return(il_idx); 07513 07514 } /* ntr_gl_ir_list_tbl */ 07515 07516 /******************************************************************************\ 07517 |* *| 07518 |* Description: *| 07519 |* *| 07520 |* Input parameters: *| 07521 |* NONE *| 07522 |* *| 07523 |* Output parameters: *| 07524 |* NONE *| 07525 |* *| 07526 |* Returns: *| 07527 |* NONE *| 07528 |* *| 07529 \******************************************************************************/ 07530 int ntr_gl_sh_tbl(void) 07531 07532 { 07533 int sh_idx; 07534 07535 07536 TRACE (Func_Entry, "ntr_gl_sh_tbl", NULL); 07537 07538 TBL_REALLOC_CK(global_sh_tbl,1); 07539 sh_idx = global_sh_tbl_idx; 07540 07541 CLEAR_TBL_NTRY(global_sh_tbl, sh_idx); 07542 07543 TRACE (Func_Exit, "ntr_gl_sh_tbl", NULL); 07544 07545 return(sh_idx); 07546 07547 } /* ntr_gl_sh_tbl */ 07548 07549 /******************************************************************************\ 07550 |* *| 07551 |* Description: *| 07552 |* *| 07553 |* Input parameters: *| 07554 |* NONE *| 07555 |* *| 07556 |* Output parameters: *| 07557 |* NONE *| 07558 |* *| 07559 |* Returns: *| 07560 |* NONE *| 07561 |* *| 07562 \******************************************************************************/ 07563 void add_attr_to_local_list(int attr_idx) 07564 07565 { 07566 int al_idx; 07567 07568 07569 TRACE (Func_Entry, "add_attr_to_local_list", NULL); 07570 07571 NTR_ATTR_LIST_TBL(al_idx); 07572 AL_ATTR_IDX(al_idx) = attr_idx; 07573 07574 if (SCP_ATTR_LIST(curr_scp_idx) == NULL_IDX) { 07575 SCP_ATTR_LIST(curr_scp_idx) = al_idx; 07576 } 07577 else { 07578 AL_NEXT_IDX(SCP_ATTR_LIST_END(curr_scp_idx)) = al_idx; 07579 } 07580 07581 SCP_ATTR_LIST_END(curr_scp_idx) = al_idx; 07582 07583 TRACE (Func_Exit, "add_attr_to_local_list", NULL); 07584 07585 return; 07586 07587 } /* add_attr_to_local_list */ 07588 07589 /******************************************************************************\ 07590 |* *| 07591 |* Description: *| 07592 |* *| 07593 |* Input parameters: *| 07594 |* NONE *| 07595 |* *| 07596 |* Output parameters: *| 07597 |* NONE *| 07598 |* *| 07599 |* Returns: *| 07600 |* NONE *| 07601 |* *| 07602 \******************************************************************************/ 07603 int ntr_sh_tbl(void) 07604 07605 { 07606 int sh_idx; 07607 07608 07609 TRACE (Func_Entry, "ntr_sh_tbl", NULL); 07610 07611 if (SH_NEXT_IDX(NULL_IDX) != NULL_IDX) { 07612 sh_idx = SH_NEXT_IDX(NULL_IDX); 07613 SH_NEXT_IDX(NULL_IDX) = SH_NEXT_IDX(sh_idx); 07614 } 07615 else { 07616 TBL_REALLOC_CK(sh_tbl,1); 07617 sh_idx = sh_tbl_idx; 07618 } 07619 07620 CLEAR_TBL_NTRY(sh_tbl, sh_idx); 07621 07622 TRACE (Func_Exit, "ntr_sh_tbl", NULL); 07623 07624 return(sh_idx); 07625 07626 } /* ntr_sh_tbl */ 07627 07628 /******************************************************************************\ 07629 |* *| 07630 |* Description: *| 07631 |* *| 07632 |* Input parameters: *| 07633 |* NONE *| 07634 |* *| 07635 |* Output parameters: *| 07636 |* NONE *| 07637 |* *| 07638 |* Returns: *| 07639 |* NONE *| 07640 |* *| 07641 \******************************************************************************/ 07642 void find_opnd_line_and_column(opnd_type *opnd, 07643 int *line, 07644 int *column) 07645 07646 { 07647 opnd_type tmp_opnd; 07648 07649 TRACE (Func_Entry, "find_opnd_line_and_column", NULL); 07650 07651 switch (OPND_FLD((*opnd))) { 07652 case CN_Tbl_Idx: 07653 case AT_Tbl_Idx: 07654 case SB_Tbl_Idx: 07655 *line = OPND_LINE_NUM((*opnd)); 07656 *column = OPND_COL_NUM((*opnd)); 07657 break; 07658 07659 case IR_Tbl_Idx: 07660 *line = IR_LINE_NUM(OPND_IDX((*opnd))); 07661 *column = IR_COL_NUM(OPND_IDX((*opnd))); 07662 break; 07663 07664 case IL_Tbl_Idx: 07665 COPY_OPND(tmp_opnd, IL_OPND(OPND_IDX((*opnd)))); 07666 find_opnd_line_and_column(&tmp_opnd, line, column); 07667 break; 07668 07669 case SH_Tbl_Idx: 07670 *line = SH_GLB_LINE(OPND_IDX((*opnd))); 07671 *column = SH_COL_NUM(OPND_IDX((*opnd))); 07672 break; 07673 07674 default: 07675 *line = 0; 07676 *column = 0; 07677 break; 07678 } 07679 07680 TRACE (Func_Exit, "find_opnd_line_and_column", NULL); 07681 07682 return; 07683 07684 } /* find_opnd_line_and_column */ 07685 07686 07687 /******************************************************************************\ 07688 |* *| 07689 |* Description: *| 07690 |* srch_hidden_name_tbl searches the local name table for the specified *| 07691 |* character string. *| 07692 |* *| 07693 |* Input parameters: *| 07694 |* token token containing identifier or label to *| 07695 |* search for and length in chars of name *| 07696 |* *| 07697 |* Output parameters: *| 07698 |* name_idx local name table index where match occured *| 07699 |* or where entry should be inserted *| 07700 |* *| 07701 |* Returns: *| 07702 |* attribute table index if found *| 07703 |* NULL_IDX if not found *| 07704 |* *| 07705 \******************************************************************************/ 07706 07707 int srch_hidden_name_tbl(char *name_str, 07708 int name_len, 07709 int attr_idx, 07710 int *np_idx, 07711 int *name_idx) 07712 07713 { 07714 int first; 07715 int idx; 07716 long tst_val; 07717 07718 07719 TRACE (Func_Entry, "srch_hidden_name_tbl", name_str); 07720 07721 first = SCP_HN_FW_IDX(curr_scp_idx); 07722 07723 tst_val = srch_name_tbl(name_str, 07724 name_len, 07725 &idx, 07726 hidden_name_tbl, 07727 name_pool, 07728 first, 07729 SCP_HN_LW_IDX(curr_scp_idx)); 07730 07731 07732 *name_idx = idx; 07733 07734 if (tst_val != 0) { /* No match */ 07735 idx = NULL_IDX; 07736 *np_idx = NULL_IDX; 07737 } 07738 else { 07739 07740 /* The name exists. Find the start of this name group. */ 07741 07742 while (HN_NAME_IDX(*name_idx) == HN_NAME_IDX((*name_idx) - 1)) { 07743 (*name_idx)--; 07744 } 07745 07746 *np_idx = HN_NAME_IDX(*name_idx); 07747 07748 if (attr_idx != NULL_IDX) { 07749 first = *name_idx; 07750 07751 while (HN_ATTR_IDX(*name_idx) != attr_idx) { 07752 07753 if (HN_NAME_IDX((*name_idx)++) != *np_idx) { 07754 *name_idx = first; 07755 break; 07756 } 07757 } 07758 } 07759 idx = HN_ATTR_IDX(*name_idx); 07760 } 07761 07762 TRACE (Func_Exit, "srch_hidden_name_tbl", NULL); 07763 07764 return (idx); 07765 07766 } /* srch_hidden_name_tbl */ 07767 07768 /******************************************************************************\ 07769 |* *| 07770 |* Description: *| 07771 |* ntr_sym_tbl adds the token name to the the name pool, links it *| 07772 |* to an attribute table entry through the local name table, and *| 07773 |* reserves an attribute table entry for the identifier or label. *| 07774 |* The attribute table entry field name_idx is linked to the name in *| 07775 |* the name pool. *| 07776 |* *| 07777 |* Input parameters: *| 07778 |* token token containing identifier or label and *| 07779 |* length of name to be added to symbol table *| 07780 |* *| 07781 |* name_idx local name table index where entry is to *| 07782 |* be inserted *| 07783 |* *| 07784 |* Output parameters: *| 07785 |* NONE *| 07786 |* *| 07787 |* Returns: *| 07788 |* attribute table index of reserved entry *| 07789 |* *| 07790 \******************************************************************************/ 07791 07792 void ntr_hidden_name_tbl(int attr_idx, 07793 int np_idx, 07794 int name_idx) 07795 07796 { 07797 register int i; 07798 register int scp_idx; 07799 07800 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 07801 register long *name_tbl_base; /* name table base address */ 07802 # endif 07803 07804 07805 TRACE (Func_Entry, "ntr_hidden_name_tbl", NULL); 07806 07807 if (np_idx == NULL_IDX) { 07808 np_idx = AT_ORIG_NAME_IDX(attr_idx); 07809 07810 if (np_idx == NULL_IDX) { 07811 np_idx = AT_NAME_IDX(attr_idx); 07812 } 07813 } 07814 07815 TBL_REALLOC_CK(hidden_name_tbl, 1); 07816 07817 if ((hidden_name_tbl_idx - 1) != SCP_HN_LW_IDX(curr_scp_idx)) { 07818 07819 /* Attempting to enter name into a scope that does not reside at the */ 07820 /* end of the local name table. Make room for this entry in that scope */ 07821 /* and then adjust the other scopes name table LW and FW values. */ 07822 07823 for (scp_idx = 1; scp_idx <= scp_tbl_idx; scp_idx++) { 07824 07825 if (SCP_HN_FW_IDX(scp_idx) > SCP_HN_LW_IDX(curr_scp_idx)) { 07826 SCP_HN_FW_IDX(scp_idx) = SCP_HN_FW_IDX(scp_idx) + 1; 07827 SCP_HN_LW_IDX(scp_idx) = SCP_HN_LW_IDX(scp_idx) + 1; 07828 } 07829 } 07830 SCP_HN_LW_IDX(curr_scp_idx)++; 07831 } 07832 else { 07833 07834 /* Adding to local name table for last (most recent) scope. No */ 07835 /* adjusting of other scope local name table entries is necessary. */ 07836 07837 SCP_HN_LW_IDX(curr_scp_idx) = hidden_name_tbl_idx; 07838 } 07839 07840 /* Enter name in correct position. Link name pool and attribute table */ 07841 07842 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 07843 name_tbl_base = (long *) hidden_name_tbl; 07844 # endif 07845 07846 for (i = hidden_name_tbl_idx; i >= name_idx; i--) { 07847 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 07848 name_tbl_base [i] = name_tbl_base [i-1]; 07849 # else 07850 hidden_name_tbl [i] = hidden_name_tbl [i-1]; 07851 # endif 07852 } 07853 07854 CLEAR_TBL_NTRY(hidden_name_tbl, name_idx); 07855 HN_ATTR_IDX(name_idx) = attr_idx; 07856 HN_NAME_IDX(name_idx) = np_idx; 07857 HN_NAME_LEN(name_idx) = AT_ORIG_NAME_LEN(attr_idx); 07858 07859 TRACE (Func_Exit, "ntr_hidden_name_tbl", NULL); 07860 07861 return; 07862 07863 } /* ntr_hidden_name_tbl */ 07864 07865 /******************************************************************************\ 07866 |* *| 07867 |* Description: *| 07868 |* *| 07869 |* Input parameters: *| 07870 |* name_idx hidden name table index to remove. *| 07871 |* *| 07872 |* Output parameters: *| 07873 |* NONE *| 07874 |* *| 07875 |* Returns: *| 07876 |* NOTHING *| 07877 |* *| 07878 \******************************************************************************/ 07879 07880 void remove_hidden_name_ntry(int name_idx) 07881 07882 { 07883 register int i; 07884 07885 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 07886 register long *name_tbl_base; /* name table base address */ 07887 # endif 07888 07889 07890 TRACE (Func_Entry, "remove_hidden_name_ntry", NULL); 07891 07892 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 07893 name_tbl_base = (long *) hidden_name_tbl; 07894 # endif 07895 07896 /* Remove name */ 07897 07898 for (i = name_idx; i < SCP_HN_LW_IDX(curr_scp_idx); i++) { 07899 # if defined(_HOST64) && !defined(_WHIRL_HOST64_TARGET64) 07900 name_tbl_base [i] = name_tbl_base [i+1]; 07901 # else 07902 hidden_name_tbl [i] = hidden_name_tbl [i+1]; 07903 # endif 07904 } 07905 07906 if (hidden_name_tbl_idx == SCP_HN_LW_IDX(curr_scp_idx)) { 07907 hidden_name_tbl_idx--; 07908 } 07909 07910 SCP_HN_LW_IDX(curr_scp_idx)--; 07911 07912 TRACE (Func_Exit, "remove_hidden_name_ntry", NULL); 07913 07914 return; 07915 07916 } /* remove_hidden_name_ntry */ 07917 07918 /******************************************************************************\ 07919 |* *| 07920 |* Description: *| 07921 |* *| 07922 |* Input parameters: *| 07923 |* attr_idx Attr with needs ATD_STOR_BLK_IDX set. *| 07924 |* *| 07925 |* Output parameters: *| 07926 |* NONE *| 07927 |* *| 07928 |* Returns: *| 07929 |* NOTHING *| 07930 |* *| 07931 \******************************************************************************/ 07932 07933 void assign_storage_blk(int attr_idx) 07934 07935 { 07936 int pgm_attr_idx; 07937 boolean pointer; 07938 int sb_idx; 07939 id_str_type stor_name; 07940 07941 # if defined(_TARGET_OS_SOLARIS) 07942 size_offset_type num; 07943 size_offset_type size; 07944 # endif 07945 07946 07947 TRACE (Func_Entry, "assign_storage_blk", NULL); 07948 07949 pgm_attr_idx = SCP_ATTR_IDX(curr_scp_idx); 07950 #if 0 07951 pointer = ATD_IM_A_DOPE(attr_idx) || 07952 (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure && 07953 ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))); 07954 #endif 07955 pointer = FALSE; 07956 07957 if (ATD_AUTOMATIC(attr_idx)) { 07958 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_BASED_IDX(curr_scp_idx); 07959 } 07960 else if (ATD_DATA_INIT(attr_idx)) { 07961 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 07962 } 07963 else if (ATD_SAVED(attr_idx)) { 07964 07965 if (pointer) { 07966 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 07967 } 07968 else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 07969 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Structure) { 07970 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_IDX(curr_scp_idx); 07971 } 07972 else { 07973 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx); 07974 } 07975 } 07976 else if (ATD_SYMBOLIC_CONSTANT(attr_idx)) { 07977 07978 /* This is a placeholder so it doesn't really need storage or an offset.*/ 07979 07980 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 07981 } 07982 07983 /* The symmetric check needs to follow the save all check. */ 07984 07985 else if (ATD_SYMMETRIC(attr_idx)) { 07986 07987 if (SCP_SB_SYMMETRIC_IDX(curr_scp_idx) == NULL_IDX) { 07988 CREATE_ID(stor_name, sb_name[Sym_Blk], sb_len[Sym_Blk]); 07989 sb_idx = ntr_stor_blk_tbl(stor_name.string, sb_len[Sym_Blk], 07990 AT_DEF_LINE(attr_idx), 07991 AT_DEF_COLUMN(attr_idx), 07992 Stack); 07993 SB_SYMMETRIC(sb_idx) = TRUE; 07994 SCP_SB_SYMMETRIC_IDX(curr_scp_idx) = sb_idx; 07995 } 07996 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_SYMMETRIC_IDX(curr_scp_idx); 07997 } 07998 else if (ATD_STACK(attr_idx) || ATP_STACK_DIR(pgm_attr_idx)) { 07999 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08000 } 08001 else if (cmd_line_flags.co_array_fortran && 08002 ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX && 08003 !ATD_IM_A_DOPE(attr_idx)) { 08004 08005 /* Non dope vector Co arrays go in static storage. */ 08006 08007 if (pointer) { 08008 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_IDX(curr_scp_idx); 08009 } 08010 else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 08011 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Structure) { 08012 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_IDX(curr_scp_idx); 08013 } 08014 else { 08015 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx); 08016 } 08017 } 08018 08019 # if defined(_TARGET_OS_SOLARIS) 08020 08021 /* On solaris, all data in the main program is static data. */ 08022 /* Can be overridden by the STACK directive or AUTOMATIC. */ 08023 08024 else if (ATP_PGM_UNIT(pgm_attr_idx) == Program && 08025 (ATD_ARRAY_IDX(attr_idx) != NULL_IDX || 08026 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character || 08027 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure)) { 08028 08029 /* Could possibly be bigger than 256 bits. */ 08030 08031 size = stor_bit_size_of(attr_idx, TRUE, FALSE); 08032 C_TO_F_INT(num.constant, 256, CG_INTEGER_DEFAULT_TYPE); 08033 num.fld = NO_Tbl_Idx; 08034 num.type_idx = CG_INTEGER_DEFAULT_TYPE; 08035 08036 size_offset_logical_calc(&size, &num, Gt_Opr, &num); 08037 08038 if (THIS_IS_TRUE(num.constant, num.type_idx)) { 08039 08040 if (pointer) { 08041 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 08042 } 08043 else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 08044 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Structure) { 08045 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_IDX(curr_scp_idx); 08046 } 08047 else { 08048 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx); 08049 } 08050 } 08051 else if (SCP_DEFAULT_STORAGE(curr_scp_idx) == Stack) { 08052 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08053 } 08054 else if (pointer) { 08055 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 08056 } 08057 else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 08058 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Structure) { 08059 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_IDX(curr_scp_idx); 08060 } 08061 else { 08062 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx); 08063 } 08064 } 08065 # endif 08066 08067 else if (SCP_DEFAULT_STORAGE(curr_scp_idx) == Stack) { 08068 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STACK_IDX(curr_scp_idx); 08069 } 08070 else if (pointer) { 08071 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_INIT_IDX(curr_scp_idx); 08072 } 08073 else if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 08074 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) != Structure) { 08075 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_IDX(curr_scp_idx); 08076 } 08077 else { 08078 ATD_STOR_BLK_IDX(attr_idx) = SCP_SB_STATIC_UNINIT_IDX(curr_scp_idx); 08079 } 08080 08081 TRACE (Func_Exit, "assign_storage_blk", NULL); 08082 08083 return; 08084 08085 } /* assign_storage_blk */ 08086 08087 /******************************************************************************\ 08088 |* *| 08089 |* Description: *| 08090 |* *| 08091 |* Input parameters: *| 08092 |* bit_len -> The bit or byte length to be aligned. *| 08093 |* align_to -> This routine will align to a 32 bit boundary or a 64 bit *| 08094 |* boundary. If you want to double align on a 32 bit target *| 08095 |* then set align_to to 64. If you want to pack on a 64 bit *| 08096 |* target, then set align_to to 32. *| 08097 |* *| 08098 |* Output parameters: *| 08099 |* bit_len -> The newly aligned bit or byte length. *| 08100 |* *| 08101 |* Returns: *| 08102 |* NONE *| 08103 |* *| 08104 \******************************************************************************/ 08105 08106 void align_bit_length(size_offset_type *bit_len, 08107 int align_to) 08108 08109 { 08110 boolean arith_ok; 08111 int column; 08112 long_type *constant; 08113 int line; 08114 opnd_type opnd; 08115 long plus_val; 08116 int plus_ir_idx; 08117 int result_type; 08118 int shiftr_ir_idx; 08119 int shiftl_ir_idx; 08120 long shift_val; 08121 operator_type shiftl_opr; 08122 operator_type shiftr_opr; 08123 boolean symbolic_constant; 08124 int type_idx; 08125 long value; 08126 08127 # if !defined(_TARGET64) || !defined(_HOST64) || defined(_WHIRL_HOST64_TARGET64) 08128 long_type plus_target_val[MAX_WORDS_FOR_INTEGER]; 08129 long_type shift_target_val[MAX_WORDS_FOR_INTEGER]; 08130 # endif 08131 08132 08133 TRACE (Func_Entry, "align_bit_length", NULL); 08134 08135 switch (align_to) { 08136 case 128: 08137 plus_val = 127; 08138 shift_val = 7; 08139 break; 08140 08141 case 64: 08142 plus_val = 63; 08143 shift_val = 6; 08144 break; 08145 08146 case 32: 08147 plus_val = 31; 08148 shift_val = 5; 08149 break; 08150 08151 case 16: 08152 plus_val = 15; 08153 shift_val = 4; 08154 break; 08155 08156 case 8: 08157 plus_val = 7; 08158 shift_val = 3; 08159 break; 08160 08161 default: /* Input must be 8, 16, 32, 64 or 128 */ 08162 PRINTMSG(stmt_start_line, 1173, Internal, stmt_start_col); 08163 break; 08164 } 08165 08166 if ((*bit_len).fld == NO_Tbl_Idx || (*bit_len).fld == CN_Tbl_Idx) { 08167 08168 if ((*bit_len).fld == NO_Tbl_Idx) { 08169 result_type = (*bit_len).type_idx; 08170 constant = (*bit_len).constant; 08171 } 08172 else { 08173 result_type = CN_TYPE_IDX((*bit_len).idx); 08174 constant = &(CN_CONST((*bit_len).idx)); 08175 } 08176 08177 # if defined(_TARGET64) && defined(_HOST64) && \ 08178 !defined(_TARGET_LITTLE_ENDIAN) 08179 08180 (*bit_len).constant[0] = ((((constant[0]) + plus_val) >> shift_val) 08181 << shift_val); 08182 # else 08183 08184 # if defined(_USE_FOLD_DOT_f) 08185 shiftl_opr = Mult_Opr; 08186 shiftr_opr = Div_Opr; 08187 value = plus_val+1; 08188 # else 08189 shiftl_opr = Shiftl_Opr; 08190 shiftr_opr = Shiftr_Opr; 08191 value = shift_val; 08192 # endif 08193 08194 C_TO_F_INT(plus_target_val, plus_val, CG_INTEGER_DEFAULT_TYPE); 08195 C_TO_F_INT(shift_target_val, value, CG_INTEGER_DEFAULT_TYPE); 08196 08197 arith_ok = folder_driver((char *) constant, 08198 result_type, 08199 (char *) &plus_target_val, 08200 CG_INTEGER_DEFAULT_TYPE, 08201 (*bit_len).constant, 08202 &result_type, 08203 stmt_start_line, 08204 stmt_start_col, 08205 2, 08206 Plus_Opr); 08207 08208 08209 arith_ok |= folder_driver((char *) (*bit_len).constant, 08210 result_type, 08211 (char *) &shift_target_val, 08212 CG_INTEGER_DEFAULT_TYPE, 08213 (*bit_len).constant, 08214 &result_type, 08215 stmt_start_line, 08216 stmt_start_col, 08217 2, 08218 shiftr_opr); 08219 08220 arith_ok |= folder_driver((char *) (*bit_len).constant, 08221 result_type, 08222 (char *) &shift_target_val, 08223 CG_INTEGER_DEFAULT_TYPE, 08224 (*bit_len).constant, 08225 &result_type, 08226 stmt_start_line, 08227 stmt_start_col, 08228 2, 08229 shiftl_opr); 08230 # endif 08231 08232 /* If we overflow - folder_driver will issue the error */ 08233 08234 (*bit_len).type_idx = result_type; 08235 (*bit_len).fld = NO_Tbl_Idx; 08236 } 08237 else { /* This contains the IR for the value to be bit aligned. */ 08238 symbolic_constant = FALSE; 08239 NTR_IR_TBL(plus_ir_idx); 08240 NTR_IR_TBL(shiftr_ir_idx); 08241 NTR_IR_TBL(shiftl_ir_idx); 08242 08243 if ((*bit_len).fld == IR_Tbl_Idx) { 08244 COPY_TBL_NTRY(ir_tbl, plus_ir_idx, (*bit_len).idx); 08245 line = IR_LINE_NUM(plus_ir_idx); 08246 column = IR_COL_NUM(plus_ir_idx); 08247 } 08248 else { 08249 08250 if ((*bit_len).fld == AT_Tbl_Idx) { 08251 line = AT_DEF_LINE((*bit_len).idx); 08252 column = AT_DEF_COLUMN((*bit_len).idx); 08253 symbolic_constant = (AT_OBJ_CLASS((*bit_len).idx) == Data_Obj) && 08254 ATD_SYMBOLIC_CONSTANT((*bit_len).idx); 08255 } 08256 else { /* This case shouldn't happen - but just in case. */ 08257 line = stmt_start_line; 08258 column = stmt_start_line; 08259 } 08260 08261 IR_LINE_NUM_L(plus_ir_idx) = line; 08262 IR_LINE_NUM_R(plus_ir_idx) = line; 08263 IR_LINE_NUM(plus_ir_idx) = line; 08264 IR_COL_NUM_L(plus_ir_idx) = column; 08265 IR_COL_NUM_R(plus_ir_idx) = column; 08266 IR_COL_NUM(plus_ir_idx) = column; 08267 } 08268 08269 OPND_FLD(opnd) = (*bit_len).fld; 08270 OPND_IDX(opnd) = (*bit_len).idx; 08271 OPND_LINE_NUM(opnd) = line; 08272 OPND_COL_NUM(opnd) = column; 08273 08274 COPY_TBL_NTRY(ir_tbl, shiftr_ir_idx, plus_ir_idx); 08275 COPY_TBL_NTRY(ir_tbl, shiftl_ir_idx, plus_ir_idx); 08276 08277 if (symbolic_constant) { /* Always an attr idx. */ 08278 IR_OPR(plus_ir_idx) = Symbolic_Plus_Opr; 08279 IR_OPR(shiftr_ir_idx) = Symbolic_Shiftr_Opr; 08280 IR_OPR(shiftl_ir_idx) = Symbolic_Shiftl_Opr; 08281 type_idx = ATD_TYPE_IDX((*bit_len).idx); 08282 } 08283 else { 08284 type_idx = check_type_for_size_address(&opnd); 08285 IR_OPR(plus_ir_idx) = Plus_Opr; 08286 IR_OPR(shiftr_ir_idx) = Shiftr_Opr; 08287 IR_OPR(shiftl_ir_idx) = Shiftl_Opr; 08288 } 08289 08290 IR_TYPE_IDX(plus_ir_idx) = type_idx; 08291 IR_TYPE_IDX(shiftr_ir_idx) = type_idx; 08292 IR_TYPE_IDX(shiftl_ir_idx) = type_idx; 08293 08294 IR_FLD_L(plus_ir_idx) = OPND_FLD(opnd); 08295 IR_IDX_L(plus_ir_idx) = OPND_IDX(opnd); 08296 08297 IR_FLD_R(plus_ir_idx) = CN_Tbl_Idx; 08298 IR_IDX_R(plus_ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,plus_val); 08299 08300 IR_FLD_L(shiftr_ir_idx) = IR_Tbl_Idx; 08301 IR_IDX_L(shiftr_ir_idx) = plus_ir_idx; 08302 08303 IR_FLD_R(shiftr_ir_idx) = CN_Tbl_Idx; 08304 IR_IDX_R(shiftr_ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08305 shift_val); 08306 08307 IR_FLD_L(shiftl_ir_idx) = IR_Tbl_Idx; 08308 IR_IDX_L(shiftl_ir_idx) = shiftr_ir_idx; 08309 08310 IR_FLD_R(shiftl_ir_idx) = CN_Tbl_Idx; 08311 IR_IDX_R(shiftl_ir_idx) = IR_IDX_R(shiftr_ir_idx); 08312 08313 if (symbolic_constant) { 08314 (*bit_len).fld = AT_Tbl_Idx; 08315 (*bit_len).idx = gen_compiler_tmp(IR_LINE_NUM(shiftl_ir_idx), 08316 IR_COL_NUM(shiftl_ir_idx), 08317 Shared, TRUE); 08318 ATD_TYPE_IDX((*bit_len).idx) = SA_INTEGER_DEFAULT_TYPE; 08319 ATD_FLD((*bit_len).idx) = IR_Tbl_Idx; 08320 ATD_TMP_IDX((*bit_len).idx) = shiftl_ir_idx; 08321 ATD_SYMBOLIC_CONSTANT((*bit_len).idx) = TRUE; 08322 } 08323 else { 08324 (*bit_len).idx = shiftl_ir_idx; 08325 (*bit_len).fld = IR_Tbl_Idx; 08326 } 08327 } 08328 08329 TRACE (Func_Exit, "align_bit_length", NULL); 08330 08331 return; 08332 08333 } /* align_bit_length */ 08334 08335 /******************************************************************************\ 08336 |* *| 08337 |* Description: *| 08338 |* *| 08339 |* Input parameters: *| 08340 |* opnd -> The operand whose size to check and convert if necessary. *| 08341 |* *| 08342 |* Output parameters: *| 08343 |* opnd -> The original operand with Cvrt_Opr wrapped around if necessary*| 08344 |* *| 08345 |* Returns: *| 08346 |* type_idx -> The type index for the type of the operand now. *| 08347 |* *| 08348 \******************************************************************************/ 08349 08350 int check_type_for_size_address(opnd_type *opnd) 08351 08352 { 08353 int col; 08354 boolean cvrt; 08355 int cvrt_idx; 08356 int line; 08357 int type_idx; 08358 08359 08360 08361 TRACE (Func_Entry, "check_type_for_size_address", NULL); 08362 08363 switch (OPND_FLD((*opnd))) { 08364 case IR_Tbl_Idx: 08365 line = IR_LINE_NUM(OPND_IDX((*opnd))); 08366 col = IR_COL_NUM(OPND_IDX((*opnd))); 08367 type_idx = IR_TYPE_IDX(OPND_IDX((*opnd))); 08368 cvrt = (SA_INTEGER_DEFAULT_TYPE > TYP_LINEAR(type_idx)); 08369 break; 08370 08371 case AT_Tbl_Idx: 08372 line = OPND_LINE_NUM((*opnd)); 08373 col = OPND_COL_NUM((*opnd)); 08374 type_idx = ATD_TYPE_IDX(OPND_IDX((*opnd))); 08375 cvrt = (SA_INTEGER_DEFAULT_TYPE > TYP_LINEAR(type_idx)); 08376 break; 08377 08378 case CN_Tbl_Idx: 08379 line = OPND_LINE_NUM((*opnd)); 08380 col = OPND_COL_NUM((*opnd)); 08381 type_idx = CN_TYPE_IDX(OPND_IDX((*opnd))); 08382 cvrt = (SA_INTEGER_DEFAULT_TYPE > TYP_LINEAR(type_idx)); 08383 break; 08384 08385 default: 08386 /* BHJ - this should be an internal error here */ 08387 line = OPND_LINE_NUM((*opnd)); 08388 col = OPND_COL_NUM((*opnd)); 08389 type_idx = SA_INTEGER_DEFAULT_TYPE; 08390 cvrt = TRUE; 08391 break; 08392 } 08393 08394 if (cvrt) { 08395 NTR_IR_TBL(cvrt_idx); 08396 IR_OPR(cvrt_idx) = Cvrt_Opr; 08397 IR_TYPE_IDX(cvrt_idx) = SA_INTEGER_DEFAULT_TYPE; 08398 IR_LINE_NUM(cvrt_idx) = line; 08399 IR_COL_NUM(cvrt_idx) = col; 08400 type_idx = SA_INTEGER_DEFAULT_TYPE; 08401 08402 if (OPND_FLD((*opnd)) == IR_Tbl_Idx && 08403 IR_OPR(OPND_IDX((*opnd))) == Asg_Opr) { 08404 08405 /* Cvrt_Opr goes to the right of the Asg_Opr, not on top */ 08406 08407 COPY_OPND(IR_OPND_L(cvrt_idx), IR_OPND_R(OPND_IDX((*opnd)))); 08408 IR_FLD_R(OPND_IDX((*opnd))) = IR_Tbl_Idx; 08409 IR_IDX_R(OPND_IDX((*opnd))) = cvrt_idx; 08410 } 08411 else { 08412 COPY_OPND(IR_OPND_L(cvrt_idx), (*opnd)); 08413 OPND_FLD((*opnd)) = IR_Tbl_Idx; 08414 OPND_IDX((*opnd)) = cvrt_idx; 08415 } 08416 } 08417 08418 TRACE (Func_Exit, "check_type_for_size_address", NULL); 08419 08420 return(type_idx); 08421 08422 } /* check_type_for_size_address */ 08423 08424 /******************************************************************************\ 08425 |* *| 08426 |* Description: *| 08427 |* *| 08428 |* Input parameters: *| 08429 |* bit_len -> The bit or byte length to be aligned. *| 08430 |* plus_val -> The value to add when calculating bits or bytes to words. *| 08431 |* shift_val-> The value to shift by when calculating bits or bytes to *| 08432 |* words. *| 08433 |* *| 08434 |* Output parameters: *| 08435 |* bit_len -> The newly aligned bit or byte length. *| 08436 |* *| 08437 |* Returns: *| 08438 |* NONE *| 08439 |* *| 08440 \******************************************************************************/ 08441 08442 void bits_and_bytes_to_words(size_offset_type *bit_len, 08443 int the_plus_val, 08444 int the_shift_val) 08445 08446 { 08447 boolean arith_ok; 08448 int column; 08449 long_type *constant; 08450 int line; 08451 opnd_type opnd; 08452 int plus_ir_idx; 08453 int result_type; 08454 int shiftr_ir_idx; 08455 boolean symbolic_constant; 08456 long plus_val; 08457 long shift_val; 08458 operator_type shiftr_opr; 08459 int type_idx; 08460 long value; 08461 08462 # if !defined(_TARGET64) || !defined(_HOST64) || defined(_WHIRL_HOST64_TARGET64) 08463 long_type plus_target_val[MAX_WORDS_FOR_INTEGER]; 08464 long_type shift_target_val[MAX_WORDS_FOR_INTEGER]; 08465 # endif 08466 08467 08468 TRACE (Func_Entry, "bits_and_bytes_to_words", NULL); 08469 08470 plus_val = the_plus_val; 08471 shift_val = the_shift_val; 08472 08473 if ((*bit_len).fld == NO_Tbl_Idx || (*bit_len).fld == CN_Tbl_Idx) { 08474 08475 if ((*bit_len).fld == NO_Tbl_Idx) { 08476 result_type = (*bit_len).type_idx; 08477 constant = (*bit_len).constant; 08478 } 08479 else { 08480 result_type = CN_TYPE_IDX((*bit_len).idx); 08481 constant = &(CN_CONST((*bit_len).idx)); 08482 } 08483 08484 # if defined(_TARGET64) && defined(_HOST64) && \ 08485 !defined(_TARGET_LITTLE_ENDIAN) 08486 08487 (*bit_len).constant[0] = (((constant[0]) + plus_val) >> shift_val); 08488 # else 08489 08490 # if defined(_USE_FOLD_DOT_f) 08491 shiftr_opr = Div_Opr; 08492 value = plus_val + 1; 08493 # else 08494 shiftr_opr = Shiftr_Opr; 08495 value = shift_val; 08496 # endif 08497 08498 C_TO_F_INT(plus_target_val, plus_val, CG_INTEGER_DEFAULT_TYPE); 08499 C_TO_F_INT(shift_target_val, value, CG_INTEGER_DEFAULT_TYPE); 08500 08501 arith_ok = folder_driver((char *) constant, 08502 result_type, 08503 (char *) &plus_target_val, 08504 CG_INTEGER_DEFAULT_TYPE, 08505 (*bit_len).constant, 08506 &result_type, 08507 stmt_start_line, 08508 stmt_start_col, 08509 2, 08510 Plus_Opr); 08511 08512 08513 arith_ok != folder_driver((char *) (*bit_len).constant, 08514 result_type, 08515 (char *) &shift_target_val, 08516 CG_INTEGER_DEFAULT_TYPE, 08517 (*bit_len).constant, 08518 &result_type, 08519 stmt_start_line, 08520 stmt_start_col, 08521 2, 08522 shiftr_opr); 08523 08524 # endif 08525 08526 /* If we overflow - folder_driver will issue the error */ 08527 08528 (*bit_len).type_idx = result_type; 08529 (*bit_len).fld = NO_Tbl_Idx; 08530 } 08531 else { /* This contains the IR for the value to be bit aligned. */ 08532 symbolic_constant = FALSE; 08533 NTR_IR_TBL(plus_ir_idx); 08534 NTR_IR_TBL(shiftr_ir_idx); 08535 08536 if ((*bit_len).fld == IR_Tbl_Idx) { 08537 COPY_TBL_NTRY(ir_tbl, plus_ir_idx, (*bit_len).idx); 08538 } 08539 else { 08540 08541 if ((*bit_len).fld == AT_Tbl_Idx) { 08542 line = AT_DEF_LINE((*bit_len).idx); 08543 column = AT_DEF_COLUMN((*bit_len).idx); 08544 symbolic_constant = (AT_OBJ_CLASS((*bit_len).idx) == Data_Obj) && 08545 ATD_SYMBOLIC_CONSTANT((*bit_len).idx); 08546 } 08547 else { /* This case shouldn't happen - but just in case. */ 08548 line = stmt_start_line; 08549 column = stmt_start_col; 08550 } 08551 IR_LINE_NUM_L(plus_ir_idx) = line; 08552 IR_LINE_NUM_R(plus_ir_idx) = line; 08553 IR_LINE_NUM(plus_ir_idx) = line; 08554 IR_COL_NUM_L(plus_ir_idx) = column; 08555 IR_COL_NUM_R(plus_ir_idx) = column; 08556 IR_COL_NUM(plus_ir_idx) = column; 08557 } 08558 08559 OPND_FLD(opnd) = (*bit_len).fld; 08560 OPND_IDX(opnd) = (*bit_len).idx; 08561 OPND_LINE_NUM(opnd) = line; 08562 OPND_COL_NUM(opnd) = column; 08563 08564 COPY_TBL_NTRY(ir_tbl, shiftr_ir_idx, plus_ir_idx); 08565 08566 if (symbolic_constant) { 08567 IR_OPR(plus_ir_idx) = Symbolic_Plus_Opr; 08568 IR_OPR(shiftr_ir_idx) = Symbolic_Shiftr_Opr; 08569 type_idx = ATD_TYPE_IDX((*bit_len).idx); 08570 } 08571 else { 08572 IR_OPR(plus_ir_idx) = Plus_Opr; 08573 IR_OPR(shiftr_ir_idx) = Shiftr_Opr; 08574 type_idx = check_type_for_size_address(&opnd); 08575 } 08576 08577 IR_TYPE_IDX(plus_ir_idx) = type_idx; 08578 IR_TYPE_IDX(shiftr_ir_idx)= type_idx; 08579 08580 IR_FLD_L(plus_ir_idx) = OPND_FLD(opnd); 08581 IR_IDX_L(plus_ir_idx) = OPND_IDX(opnd); 08582 08583 IR_FLD_R(plus_ir_idx) = CN_Tbl_Idx; 08584 IR_IDX_R(plus_ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,plus_val); 08585 08586 IR_FLD_L(shiftr_ir_idx) = IR_Tbl_Idx; 08587 IR_IDX_L(shiftr_ir_idx) = plus_ir_idx; 08588 08589 IR_FLD_R(shiftr_ir_idx) = CN_Tbl_Idx; 08590 IR_IDX_R(shiftr_ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 08591 shift_val); 08592 08593 if (symbolic_constant) { 08594 (*bit_len).fld = AT_Tbl_Idx; 08595 (*bit_len).idx = gen_compiler_tmp(IR_LINE_NUM(shiftr_ir_idx), 08596 IR_COL_NUM(shiftr_ir_idx), 08597 Shared, TRUE); 08598 ATD_TYPE_IDX((*bit_len).idx) = SA_INTEGER_DEFAULT_TYPE; 08599 ATD_FLD((*bit_len).idx) = IR_Tbl_Idx; 08600 ATD_TMP_IDX((*bit_len).idx) = shiftr_ir_idx; 08601 ATD_SYMBOLIC_CONSTANT((*bit_len).idx) = TRUE; 08602 } 08603 else { 08604 (*bit_len).idx = shiftr_ir_idx; 08605 (*bit_len).fld = IR_Tbl_Idx; 08606 } 08607 } 08608 08609 TRACE (Func_Exit, "bits_and_bytes_to_words", NULL); 08610 08611 return; 08612 08613 } /* bits_and_bytes_to_words */ 08614 08615 /******************************************************************************\ 08616 |* *| 08617 |* Description: *| 08618 |* *| 08619 |* Input parameters: *| 08620 |* NONE *| 08621 |* *| 08622 |* Output parameters: *| 08623 |* NONE *| 08624 |* *| 08625 |* Returns: *| 08626 |* new attr list idx *| 08627 |* *| 08628 \******************************************************************************/ 08629 int ntr_attr_list_tbl(void) 08630 08631 { 08632 int al_idx; 08633 08634 08635 TRACE (Func_Entry, "ntr_attr_list_tbl", NULL); 08636 08637 if (AL_NEXT_IDX(NULL_IDX) != NULL_IDX) { 08638 al_idx = AL_NEXT_IDX(NULL_IDX); 08639 AL_NEXT_IDX(NULL_IDX) = AL_NEXT_IDX(al_idx); 08640 } 08641 else { 08642 TBL_REALLOC_CK(attr_list_tbl, 1); 08643 al_idx = attr_list_tbl_idx; 08644 } 08645 08646 CLEAR_TBL_NTRY(attr_list_tbl, al_idx); 08647 08648 TRACE (Func_Exit, "ntr_attr_list_tbl", NULL); 08649 08650 return(al_idx); 08651 08652 } /* ntr_attr_list_tbl */ 08653 08654 /******************************************************************************\ 08655 |* *| 08656 |* Description: *| 08657 |* *| 08658 |* Input parameters: *| 08659 |* NONE *| 08660 |* *| 08661 |* Output parameters: *| 08662 |* NONE *| 08663 |* *| 08664 |* Returns: *| 08665 |* NONE *| 08666 |* *| 08667 \******************************************************************************/ 08668 void free_attr_list(int al_idx) 08669 08670 { 08671 int free_list_start; 08672 int old_free_list_start; 08673 int prev_idx; 08674 08675 08676 TRACE (Func_Entry, "free_attr_list", NULL); 08677 08678 if (al_idx != NULL_IDX) { 08679 old_free_list_start = AL_NEXT_IDX(NULL_IDX); 08680 free_list_start = al_idx; 08681 prev_idx = NULL_IDX; 08682 08683 while (al_idx != NULL_IDX) { 08684 08685 if (AL_FREE(al_idx)) { 08686 08687 /* This is already on the free list. Do not add. */ 08688 08689 if (al_idx == free_list_start) { 08690 free_list_start = AL_NEXT_IDX(al_idx); 08691 } 08692 else { 08693 AL_NEXT_IDX(prev_idx) = AL_NEXT_IDX(al_idx); 08694 } 08695 } 08696 else { 08697 AL_FREE(al_idx) = TRUE; 08698 prev_idx = al_idx; 08699 } 08700 al_idx = AL_NEXT_IDX(al_idx); 08701 } 08702 08703 AL_NEXT_IDX(NULL_IDX) = free_list_start; 08704 AL_NEXT_IDX(prev_idx) = old_free_list_start; 08705 } 08706 08707 TRACE (Func_Exit, "free_attr_list", NULL); 08708 08709 return; 08710 08711 } /* free_attr_list */ 08712 08713 /******************************************************************************\ 08714 |* *| 08715 |* Description: *| 08716 |* *| 08717 |* Input parameters: *| 08718 |* NONE *| 08719 |* *| 08720 |* Output parameters: *| 08721 |* NONE *| 08722 |* *| 08723 |* Returns: *| 08724 |* NONE *| 08725 |* *| 08726 \******************************************************************************/ 08727 # if defined(GENERATE_WHIRL) 08728 08729 void make_external_name(int attr_idx, 08730 int name_idx, 08731 int name_len) 08732 08733 { 08734 token_type ext_token; 08735 int i; 08736 char *name_ptr; 08737 08738 08739 TRACE (Func_Entry, "make_external_name", NULL); 08740 08741 if (!AT_IS_INTRIN(attr_idx)) { 08742 name_ptr = &name_pool[name_idx].name_char; 08743 08744 if (!on_off_flags.upper_case_names) { 08745 for (i = 0; i < name_len; i++) { 08746 TOKEN_STR(ext_token)[i] = tolower(name_ptr[i]); 08747 } 08748 08749 if (!on_off_flags.remove_trailing_uscore) { 08750 TOKEN_STR(ext_token)[i++] = '_'; 08751 name_len++; 08752 } 08753 08754 TOKEN_STR(ext_token)[i] = '\0'; 08755 NTR_NAME_POOL(TOKEN_ID(ext_token).words, name_len, name_idx); 08756 } 08757 } 08758 08759 ATP_EXT_NAME_IDX(attr_idx) = name_idx; 08760 ATP_EXT_NAME_LEN(attr_idx) = name_len; 08761 08762 08763 TRACE (Func_Exit, "make_external_name", NULL); 08764 08765 return; 08766 08767 } /* make_external_name */ 08768 # endif 08769 08770 /******************************************************************************\ 08771 |* *| 08772 |* Description: *| 08773 |* Create the hidden name table for this scope. *| 08774 |* *| 08775 |* Input parameters: *| 08776 |* scp_idx -> Scope that needs hidden name table created in. *| 08777 |* *| 08778 |* Output parameters: *| 08779 |* NONE *| 08780 |* *| 08781 |* Returns: *| 08782 |* NOTHING *| 08783 |* *| 08784 \******************************************************************************/ 08785 void create_hidden_name_tbl(int scp_idx) 08786 { 08787 int hn_idx; 08788 08789 08790 TRACE (Func_Entry, "create_hidden_name_tbl", NULL); 08791 08792 /* Need to create a hidden name table for compressing out attr entries */ 08793 08794 hn_idx = hidden_name_tbl_idx + 1; 08795 08796 TBL_REALLOC_CK(hidden_name_tbl, 2); 08797 CLEAR_TBL_NTRY(hidden_name_tbl, hn_idx); 08798 08799 HN_NAME_IDX(hn_idx) = NAME_POOL_ZERO_IDX; /* Zero word */ 08800 HN_NAME_LEN(hn_idx) = HOST_BYTES_PER_WORD; 08801 SCP_HN_FW_IDX(scp_idx) = hn_idx; 08802 08803 CLEAR_TBL_NTRY(hidden_name_tbl, hidden_name_tbl_idx); 08804 HN_NAME_IDX(hidden_name_tbl_idx) = NAME_POOL_ONES_IDX; /* Ones word */ 08805 HN_NAME_LEN(hidden_name_tbl_idx) = HOST_BYTES_PER_WORD; 08806 SCP_HN_LW_IDX(scp_idx) = hidden_name_tbl_idx; 08807 08808 TRACE (Func_Exit, "create_hidden_name_tbl", NULL); 08809 08810 return; 08811 08812 } /* create_hidden_name_tbl */ 08813 08814 /******************************************************************************\ 08815 |* *| 08816 |* Description: *| 08817 |* Remove the hidden name table for this scope. *| 08818 |* *| 08819 |* Input parameters: *| 08820 |* scp_idx -> Scope that needs hidden name table create in. *| 08821 |* *| 08822 |* Output parameters: *| 08823 |* NONE *| 08824 |* *| 08825 |* Returns: *| 08826 |* NOTHING *| 08827 |* *| 08828 \******************************************************************************/ 08829 void remove_hidden_name_tbl(int scp_idx) 08830 { 08831 08832 TRACE (Func_Entry, "remove_hidden_name_tbl", NULL); 08833 08834 /* Remove hidden name table - We're done with it. It should */ 08835 /* always be at the end. This is a safety check. If for some */ 08836 /* reason it is not, everything will work, but will compile slower. */ 08837 08838 if (hidden_name_tbl_idx == SCP_HN_LW_IDX(scp_idx)) { 08839 hidden_name_tbl_idx = SCP_HN_FW_IDX(scp_idx) - 1; 08840 } 08841 08842 SCP_HN_FW_IDX(scp_idx) = NULL_IDX; 08843 SCP_HN_LW_IDX(scp_idx) = NULL_IDX; 08844 08845 TRACE (Func_Exit, "remove_hidden_name_tbl", NULL); 08846 08847 return; 08848 08849 } /* remove_hidden_name_tbl */ 08850 08851 08852 /******************************************************************************\ 08853 |* *| 08854 |* Description: *| 08855 |* This procedure is only referenced on PVP machines. It determines *| 08856 |* whether or not the bit pattern passed to it in "constant" is a valid *| 08857 |* form for a non-IEEE PVP machine. *| 08858 |* *| 08859 |* Input parameters: *| 08860 |* type_idx : the data type index for the constant *| 08861 |* constant : the constant *| 08862 |* *| 08863 |* Output parameters: *| 08864 |* NONE *| 08865 |* *| 08866 |* Returns: *| 08867 |* TRUE if the argument is "normal". *| 08868 |* *| 08869 \******************************************************************************/ 08870 08871 static boolean pvp_isnormal(int type_idx, 08872 long_type *constant) 08873 { 08874 long_type mask; 08875 boolean result; 08876 08877 08878 TRACE (Func_Entry, "pvp_isnormal", NULL); 08879 08880 mask = AR_status((AR_DATA *) constant, 08881 (const AR_TYPE *) &linear_to_arith[TYP_LINEAR(type_idx)]); 08882 08883 if (mask & AR_STAT_UNDERFLOW != 0 || mask & AR_STAT_OVERFLOW != 0) { 08884 result = FALSE; 08885 } 08886 else { 08887 result = TRUE; 08888 } 08889 08890 TRACE (Func_Exit, "pvp_isnormal", NULL); 08891 08892 return(result); 08893 08894 } /* pvp_isnormal */ 08895 08896 08897 /******************************************************************************\ 08898 |* *| 08899 |* Description: *| 08900 |* This procedure is only referenced on IEEE machines. It is the driver *| 08901 |* for the C "isnormal" macro imitation. *| 08902 |* *| 08903 |* Input parameters: *| 08904 |* type_idx : the data type index for the constant *| 08905 |* constant : the constant *| 08906 |* *| 08907 |* Output parameters: *| 08908 |* NONE *| 08909 |* *| 08910 |* Returns: *| 08911 |* TRUE (1) if the argument is "normal". *| 08912 |* *| 08913 \******************************************************************************/ 08914 08915 static boolean is_normal(int type_idx, 08916 long_type *constant) 08917 { 08918 int const_bit_len; 08919 boolean result; 08920 08921 08922 TRACE (Func_Entry, "is_normal", NULL); 08923 08924 const_bit_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 08925 08926 switch (const_bit_len) { 08927 08928 case 32: 08929 result = (is_normal_32(constant) == 1) ? TRUE : FALSE; 08930 break; 08931 08932 case 64: 08933 result = (is_normal_64(type_idx, constant) == 1) ? TRUE : FALSE; 08934 break; 08935 08936 case 128: 08937 result = (is_normal_128(type_idx, constant) == 1) ? TRUE : FALSE; 08938 } 08939 08940 TRACE (Func_Exit, "is_normal", NULL); 08941 08942 return(result); 08943 08944 } /* is_normal */ 08945 08946 08947 08948 /******************************************************************************\ 08949 |* *| 08950 |* Description: *| 08951 |* This procedure is only referenced on IEEE machines. It is the 32-bit *| 08952 |* implementation of the C "isnormal" macro. *| 08953 |* *| 08954 |* Input parameters: *| 08955 |* constant : the constant *| 08956 |* *| 08957 |* Output parameters: *| 08958 |* NONE *| 08959 |* *| 08960 |* Returns: *| 08961 |* TRUE (1) if the argument is "normal". *| 08962 |* *| 08963 \******************************************************************************/ 08964 08965 static int is_normal_32(long_type *constant) 08966 { 08967 ieee_real_4_type f; 08968 08969 08970 f.integer_form = constant[0]; 08971 08972 return( ! IEEE_32_EXPO_ALLONES(f.parts.exponent) && 08973 (f.parts.exponent & IEEE_32_EXPONENT) != 0); 08974 08975 } /* is_normal_32 */ 08976 08977 08978 08979 08980 /******************************************************************************\ 08981 |* *| 08982 |* Description: *| 08983 |* This procedure is only referenced on IEEE machines. It is the 64-bit *| 08984 |* implementation of the C "isnormal" macro. *| 08985 |* *| 08986 |* Input parameters: *| 08987 |* type_idx : the data type index for the constant *| 08988 |* constant : the constant *| 08989 |* *| 08990 |* Output parameters: *| 08991 |* NONE *| 08992 |* *| 08993 |* Returns: *| 08994 |* TRUE (1) if the argument is "normal". *| 08995 |* *| 08996 \******************************************************************************/ 08997 08998 static int is_normal_64(int type_idx, 08999 long_type *constant) 09000 { 09001 int const_word_len; 09002 ieee_real_8_type f; 09003 int i; 09004 09005 const_word_len = 09006 TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 09007 09008 for (i = 0; i < const_word_len; ++i) { 09009 f.integer_array[i] = constant[i]; 09010 } 09011 09012 return( ! IEEE_64_EXPO_ALLONES(f.parts.exponent) && 09013 (f.parts.exponent & IEEE_64_EXPONENT) != 0); 09014 09015 } /* is_normal_64 */ 09016 09017 09018 09019 09020 /******************************************************************************\ 09021 |* *| 09022 |* Description: *| 09023 |* This procedure is only referenced on IEEE machines. It is the 128-bit*| 09024 |* implementation of the C "isnormal" macro. *| 09025 |* *| 09026 |* Input parameters: *| 09027 |* type_idx : the data type index for the constant *| 09028 |* constant : the constant *| 09029 |* *| 09030 |* Output parameters: *| 09031 |* NONE *| 09032 |* *| 09033 |* Returns: *| 09034 |* TRUE (1) if the argument is "normal". *| 09035 |* *| 09036 \******************************************************************************/ 09037 09038 static int is_normal_128(int type_idx, 09039 long_type *constant) 09040 { 09041 int const_word_len; 09042 ieee_real_16_type f; 09043 int i; 09044 09045 const_word_len = 09046 TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 09047 09048 for (i = 0; i < const_word_len; ++i) { 09049 f.integer_array[i] = constant[i]; 09050 } 09051 09052 return( ! IEEE_128_EXPO_ALLONES(f.parts.exponent) && 09053 (f.parts.exponent & IEEE_128_EXPO) != 0 ); 09054 09055 } /* is_normal_128 */ 09056 09057 09058 /******************************************************************************\ 09059 |* *| 09060 |* Description: *| 09061 |* This procedure is only referenced on IEEE machines. It is the driver *| 09062 |* for the C "signbit" macro imitation. *| 09063 |* *| 09064 |* Input parameters: *| 09065 |* type_idx : the data type index for the constant *| 09066 |* constant : the constant *| 09067 |* *| 09068 |* Output parameters: *| 09069 |* NONE *| 09070 |* *| 09071 |* Returns: *| 09072 |* The sign bit. *| 09073 |* *| 09074 \******************************************************************************/ 09075 09076 static int sign_bit(int type_idx, 09077 long_type *constant) 09078 { 09079 int const_bit_len; 09080 int result; 09081 09082 09083 TRACE (Func_Entry, "sign_bit", NULL); 09084 09085 const_bit_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 09086 09087 switch (const_bit_len) { 09088 09089 case 32: 09090 result = sign_bit_32(constant); 09091 break; 09092 09093 case 64: 09094 result = sign_bit_64(constant); 09095 break; 09096 09097 case 128: 09098 result = sign_bit_128(constant); 09099 } 09100 09101 TRACE (Func_Exit, "sign_bit", NULL); 09102 09103 return(result); 09104 09105 } /* sign_bit */ 09106 09107 09108 09109 /******************************************************************************\ 09110 |* *| 09111 |* Description: *| 09112 |* This procedure is only referenced on IEEE machines. It is the 32-bit *| 09113 |* implementation of the C "signbit" macro. *| 09114 |* *| 09115 |* Input parameters: *| 09116 |* constant : the constant *| 09117 |* *| 09118 |* Output parameters: *| 09119 |* NONE *| 09120 |* *| 09121 |* Returns: *| 09122 |* The sign bit (1 or 0). *| 09123 |* *| 09124 \******************************************************************************/ 09125 09126 static int sign_bit_32(long_type *constant) 09127 { 09128 ieee_real_4_type f; 09129 09130 09131 f.integer_form = constant[0]; 09132 09133 return(f.parts.sign); 09134 09135 } /* sign_bit_32 */ 09136 09137 09138 09139 09140 /******************************************************************************\ 09141 |* *| 09142 |* Description: *| 09143 |* This procedure is only referenced on IEEE machines. It is the 64-bit *| 09144 |* implementation of the C "signbit" macro. *| 09145 |* *| 09146 |* Input parameters: *| 09147 |* constant : the constant *| 09148 |* *| 09149 |* Output parameters: *| 09150 |* NONE *| 09151 |* *| 09152 |* Returns: *| 09153 |* The sign bit (1 or 0). *| 09154 |* *| 09155 \******************************************************************************/ 09156 09157 static int sign_bit_64(long_type *constant) 09158 { 09159 ieee_real_8_type f; 09160 09161 09162 f.integer_array[0] = constant[0]; 09163 09164 return(f.parts.sign); 09165 09166 } /* sign_bit_64 */ 09167 09168 09169 09170 09171 /******************************************************************************\ 09172 |* *| 09173 |* Description: *| 09174 |* This procedure is only referenced on IEEE machines. It is the 128-bit*| 09175 |* implementation of the C "signbit" macro. *| 09176 |* *| 09177 |* Input parameters: *| 09178 |* constant : the constant *| 09179 |* *| 09180 |* Output parameters: *| 09181 |* NONE *| 09182 |* *| 09183 |* Returns: *| 09184 |* The sign bit (1 or 0). *| 09185 |* *| 09186 \******************************************************************************/ 09187 09188 static int sign_bit_128(long_type *constant) 09189 { 09190 ieee_real_16_type f; 09191 09192 09193 f.integer_array[0] = constant[0]; 09194 09195 return(f.parts.sign); 09196 09197 } /* sign_bit_128 */ 09198 09199 09200 /******************************************************************************\ 09201 |* *| 09202 |* Description: *| 09203 |* This procedure is only referenced on IEEE machines. It is the driver *| 09204 |* for the C "fpclassify" macro imitation. *| 09205 |* *| 09206 |* Input parameters: *| 09207 |* type_idx : the data type index for the constant *| 09208 |* constant : the constant *| 09209 |* *| 09210 |* Output parameters: *| 09211 |* NONE *| 09212 |* *| 09213 |* Returns: *| 09214 |* An int indicating the class of the constant. *| 09215 |* *| 09216 \******************************************************************************/ 09217 09218 static int fp_classify(int type_idx, 09219 long_type *constant) 09220 { 09221 int class; 09222 int const_bit_len; 09223 09224 09225 TRACE (Func_Entry, "fp_classify", NULL); 09226 09227 const_bit_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)]; 09228 09229 switch (const_bit_len) { 09230 09231 case 32: 09232 class = fp_classify_32(constant); 09233 break; 09234 09235 case 64: 09236 class = fp_classify_64(type_idx, constant); 09237 break; 09238 09239 case 128: 09240 class = fp_classify_128(type_idx, constant); 09241 } 09242 09243 TRACE (Func_Exit, "fp_classify", NULL); 09244 09245 return(class); 09246 09247 } /* fp_classify */ 09248 09249 09250 09251 /******************************************************************************\ 09252 |* *| 09253 |* Description: *| 09254 |* This procedure is only referenced on IEEE machines. It is the 32-bit *| 09255 |* implementation of the C "fpclassify" macro. *| 09256 |* *| 09257 |* Input parameters: *| 09258 |* constant : the constant *| 09259 |* *| 09260 |* Output parameters: *| 09261 |* NONE *| 09262 |* *| 09263 |* Returns: *| 09264 |* An int indicating the class of the constant. *| 09265 |* *| 09266 \******************************************************************************/ 09267 09268 static int fp_classify_32(long_type *constant) 09269 { 09270 09271 ieee_real_4_type f; 09272 09273 09274 f.integer_form = constant[0]; 09275 09276 if (f.parts.exponent == 0) { 09277 09278 if (f.parts.mantissa == 0) { 09279 return(FP_SGI_ZERO); 09280 } 09281 else { 09282 return(FP_SGI_SUBNORMAL); 09283 } 09284 } 09285 else if (f.parts.exponent == IEEE_32_EXPONENT) { 09286 09287 if (f.parts.mantissa == 0) { 09288 return(FP_SGI_INFINITE); 09289 } 09290 else { 09291 return(FP_SGI_NAN); 09292 } 09293 } 09294 else { 09295 return(FP_SGI_NORMAL); 09296 } 09297 09298 } /* fp_classify_32 */ 09299 09300 09301 09302 09303 /******************************************************************************\ 09304 |* *| 09305 |* Description: *| 09306 |* This procedure is only referenced on IEEE machines. It is the 64-bit *| 09307 |* implementation of the C "fpclassify" macro. *| 09308 |* *| 09309 |* Input parameters: *| 09310 |* type_idx : the data type index for the constant *| 09311 |* constant : the constant *| 09312 |* *| 09313 |* Output parameters: *| 09314 |* NONE *| 09315 |* *| 09316 |* Returns: *| 09317 |* An int indicating the class of the constant. *| 09318 |* *| 09319 \******************************************************************************/ 09320 09321 static int fp_classify_64(int type_idx, 09322 long_type *constant) 09323 { 09324 int const_word_len; 09325 ieee_real_8_type f; 09326 int i; 09327 09328 const_word_len = 09329 TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 09330 09331 for (i = 0; i < const_word_len; ++i) { 09332 f.integer_array[i] = constant[i]; 09333 } 09334 09335 if (f.parts.exponent == 0) { 09336 09337 if (f.parts.mantissa_u == 0 && f.parts.mantissa_l == 0) { 09338 return(FP_SGI_ZERO); 09339 } 09340 else { 09341 return (FP_SGI_SUBNORMAL); 09342 } 09343 } 09344 else if (f.parts.exponent == IEEE_64_EXPONENT) { 09345 09346 if (f.parts.mantissa_u == 0 && f.parts.mantissa_l == 0) { 09347 return(FP_SGI_INFINITE); 09348 } 09349 else { 09350 return(FP_SGI_NAN); 09351 } 09352 } 09353 else { 09354 return (FP_SGI_NORMAL); 09355 } 09356 09357 } /* fp_classify_64 */ 09358 09359 09360 09361 09362 /******************************************************************************\ 09363 |* *| 09364 |* Description: *| 09365 |* This procedure is only referenced on IEEE machines. It is the 128-bit*| 09366 |* implementation of the C "fpclassify" macro. *| 09367 |* *| 09368 |* Input parameters: *| 09369 |* type_idx : the data type index for the constant *| 09370 |* constant : the constant *| 09371 |* *| 09372 |* Output parameters: *| 09373 |* NONE *| 09374 |* *| 09375 |* Returns: *| 09376 |* An int indicating the class of the constant. *| 09377 |* *| 09378 \******************************************************************************/ 09379 09380 static int fp_classify_128(int type_idx, 09381 long_type *constant) 09382 { 09383 int const_word_len; 09384 ieee_real_16_type f; 09385 int i; 09386 09387 const_word_len = 09388 TARGET_BITS_TO_WORDS(storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 09389 09390 for (i = 0; i < const_word_len; ++i) { 09391 f.integer_array[i] = constant[i]; 09392 } 09393 09394 if (f.parts.exponent == 0) { 09395 09396 if (f.parts.mantissa_u1 == 0 && f.parts.mantissa_u2 == 0 && 09397 f.parts.mantissa_l1 == 0 && f.parts.mantissa_l2 == 0) { 09398 return(FP_SGI_ZERO); 09399 } 09400 else { 09401 return (FP_SGI_SUBNORMAL); 09402 } 09403 } 09404 else if (f.parts.exponent == IEEE_128_EXPO) { 09405 09406 if (f.parts.mantissa_u1 == 0 && f.parts.mantissa_u2 == 0 && 09407 f.parts.mantissa_l1 == 0 && f.parts.mantissa_l2 == 0) { 09408 return(FP_SGI_INFINITE); 09409 } 09410 else { 09411 return(FP_SGI_NAN); 09412 } 09413 } 09414 else { 09415 return (FP_SGI_NORMAL); 09416 } 09417 09418 } /* fp_classify_128 */
1.7.6.1 
