THIS FILE IS DAMAGED COMPILATION LISTING OF SEGMENT ext_code_generator Compiled by: Multics PL/I Compiler, Release 33c, of October 25, 1990 Compiled at: ACTC Technologies Inc. Compiled on: 91-12-11_2230.45_Wed_mst Options: optimize map 1 /****^ ********************************************************* 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1990 * 4* * * 5* * Copyright, (C) Honeywell Limited, 1983 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* ********************************************************* */ 11 12 13 14 /****^ HISTORY COMMENTS: 15* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 16* install(86-07-28,MR12.0-1105): 17* Fix fortran bugs 430, 449, 455, 463, and 492. 18* 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 19* install(86-07-28,MR12.0-1105): 20* Fix fortran bugs 411, 425, 473, and 476. 21* 3) change(86-10-17,Ginter), approve(86-10-17,MCR7556), audit(86-10-22,Huen), 22* install(86-11-13,MR12.0-1216): 23* Fixed fortran bugs 496 and 502. 24* 4) change(88-01-07,Huen), approve(88-01-07,MCR7825), audit(88-01-13,RWaters), 25* install(88-01-19,MR12.2-1014): 26* Fix fortran bug 504. 27* 5) change(90-04-27,Huen), approve(90-04-27,MCR8155), audit(90-05-16,Gray), 28* install(90-05-30,MR12.4-1011): 29* ft_508 : Generate correct code for index intrinsic on a substring of a 30* static character variable. 31* 6) change(91-06-27,Huen), approve(91-06-27,MCR8245), audit(91-11-25,Vu), 32* install(91-12-11,MR12.5-1004): 33* Fix fortran bug 513 to generate correct code for VLA reference if one of 34* the dimensions is greater than the maximum number that fits in a 18 bit 35* halfword (262143). 36* END HISTORY COMMENTS */ 37 38 39 /* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */ 40 ext_code_generator: 41 procedure (p1, p2); 42 43 dcl (p1, p2, shared_struc_ptr, cg_struc_ptr) pointer; 44 dcl (object_base, operand_base, polish_base, relocation_base) pointer; 45 dcl (object_max_len, operand_max_len, polish_max_len) fixed binary (19); 46 1 1 /* BEGIN fort_nodes.incl.pl1 */ 1 2 1 3 1 4 1 5 /****^ HISTORY COMMENTS: 1 6* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 1 7* install(86-07-28,MR12.0-1105): 1 8* Fix fortran bug 473. 1 9* 2) change(88-04-28,RWaters), approve(88-04-28,MCR7875), audit(88-07-13,Huen), 1 10* install(88-11-10,MR12.2-1209): 1 11* Implement SCP 6339: Allow character variable to be up to 128K-1 (131071) 1 12* character long. 1 13* END HISTORY COMMENTS */ 1 14 1 15 1 16 /* Written: June 1976 by David Levin and Richard Barnes 1 17* 1 18*Modified: 1 19* Feb 24 1977 by G. Chang for the optimizer 1 20* Sept 12, 1977 by R. Barnes for the loop optimizer 1 21* Nov 16, 1977 by D. Levin to add machine state node for loop optimizer 1 22* Oct 09 1978 by P Smee for larger common and arrays. 1 23* Dec 05 1978 by P Smee for %options statement. 1 24* Jan 17 1979 by R Barnes for machine_state.value_in_xr 1 25* May 23 1979 by P Smee to add source.line_number 1 26* July 19 1979 by R Barnes for char mode changes 1 27* Sept 17 1979 by R Barnes for register optimizer changes 1 28* Oct 3 1979 by C R Davis for new EAQ management scheme. 1 29* 29 Oct 1979 by C R Davis for machine_state.eaq.reserved. 1 30* 3 Nov 1979 by R. Barnes for pointer node and to change 1 31* machine_state.next from a fixed bin to a pointer. 1 32* 18 Dec 1979 by R. Barnes for loop_ref_count to finalize 1 33* changes for the register optimizer. 1 34* 17 Dec 1979 by C R Davis for symbol.descriptor 1 35* 22 Dec 1979 by R. Barnes to remove in_list. 1 36* 22 Jan 1980 by P E Smee to try for long char arrays. 1 37* 23 Jan 1980 by C R Davis to fix bugs with yesterday's changes. 1 38* 4 Mar 1980 by C R Davis to rename node.multi_position to 1 39* node.stack_indirect, and to add machine_state.stack_extended 1 40* and machine_state.last_dynamic_temp. 1 41* 5 Jun 1980 by M E Presser to alter arg_desc node for use 1 42* in stack-extensions and arg-descriptor generation. 1 43* 16 July 1980 by C R Davis for symbol.variable_arglist. 1 44* 8 Jan 81 by M E Presser for label.not_referencable 1 45* 17 Feb 1981 by C R Davis for new dimension node layout. 1 46* 11 March 1981 by MEP for dimension.assumed_size 1 47* 3 May 1982 by TO to add star_extent_function to subprogram node. 1 48* Mod 1 25 August 1982 by TO to add VLA_chain and LA_chain to subprogram node. 1 49* Mod 1 2 September 1982 by TO to add 5 more entries to storage_info in 1 50* the subprogram node (13-17), and to add VLA and LA bits to the 1 51* symbol node. 1 52* Mod 1 2 September 1982 by TO move fields around in nodes to get correct 1 53* 24 (really 35) bit fields and still maintain mapping between 1 54* node, temporary, and array_ref (others limit to word 6 like node.) 1 55* 19 Jun 83, HH - 145: Add 'branched_to', 'ends_do_loop' & 'loop_end' 1 56* to 'label' node. 1 57* 19 Feb 86, BW & AG - 473.a: Add 'VLA' to 'arg_desc' node. 1 58*END Modifications */ 1 59 1 60 1 61 /* GENERAL NODE TEMPLATE */ 1 62 1 63 dcl 1 node aligned based structure, 1 64 1 65 /* WORD 1 */ 1 66 1 67 2 node_type fixed bin (4) unaligned, 1 68 2 data_type fixed bin (4) unaligned unsigned, 1 69 2 operand_type fixed bin (4) unaligned, 1 70 1 71 2 addressing_bits unaligned structure, 1 72 3 is_addressable bit (1), 1 73 3 value_in, 1 74 4 eaq bit (1), 1 75 4 x bit (1), 1 76 3 allocated bit (1), 1 77 3 needs_pointer bit (1), 1 78 3 stack_indirect bit (1), 1 79 3 large_address bit (1), 1 80 3 address_in_base bit (1), 1 81 3 dont_update bit (1), /* for optimizer */ 1 82 3 not_in_storage bit (1), /* for optimizer */ 1 83 3 globally_assigned bit (1), /* for optimizer */ 1 84 1 85 2 bits unaligned structure, 1 86 3 standard_bits, 1 87 4 allocate bit (1), 1 88 4 set bit (1), 1 89 4 referenced bit (1), 1 90 4 passed_as_arg bit (1), 1 91 1 92 3 fill bit (7), /* These bits may be used by individual nodes. */ 1 93 1 94 /* WORD 2 */ 1 95 1 96 2 address aligned structure, 1 97 3 base bit (3) unaligned, /* For labels and constants, base and offset are */ 1 98 3 offset fixed bin (14) unaligned, /* combined to: fixed bin (18) unsigned unaligned. */ 1 99 3 char_num fixed bin (2) unaligned unsigned, 1 100 3 bit_num fixed bin (4) unaligned unsigned, 1 101 3 fill bit (4) unaligned, 1 102 3 inhibit bit (1) unaligned, 1 103 3 ext_base bit (1) unaligned, 1 104 3 tag bit (6) unaligned, 1 105 1 106 /* WORD 3 */ 1 107 1 108 2 units fixed bin (3) unaligned unsigned, 1 109 2 fill bit (3) unaligned, /* already used in symbol node */ 1 110 2 reloc_hold bit (6) unaligned, 1 111 2 reloc bit (6) unaligned, 1 112 2 addr_hold bit (18) unaligned, 1 113 1 114 /* WORD 4. Must not change for constant, char_constant, header, label, or symbol nodes. */ 1 115 1 116 2 next fixed bin (18) unsigned unaligned, 1 117 2 hash_chain fixed bin (18) unsigned unaligned, /* No hash chain for header nodes. */ 1 118 1 119 /* WORD 5 */ 1 120 1 121 2 pad fixed bin (18) unsigned unaligned, 1 122 2 loop_ref_count fixed bin (17) unaligned, /* Only for symbols and temporaries. */ 1 123 1 124 /* WORD 6 */ 1 125 1 126 2 location fixed bin (24) aligned; /* Only for array refs, symbols, temporaries, and headers. */ 1 127 1 128 /* ARG DESCRIPTOR NODE */ 1 129 1 130 dcl 1 arg_desc based aligned, 1 131 1 132 /* WORD 1 */ 1 133 1 134 2 node_type fixed bin (4) unaligned, 1 135 2 n_args fixed bin (12) unaligned, 1 136 2 pad bit (18) unaligned, 1 137 1 138 /* WORDS 2 - N_ARGS + 1 */ 1 139 1 140 2 arg(num_args refer(n_args)) aligned, 1 141 3 data_type fixed bin (4) unaligned unsigned, 1 142 3 must_be unaligned, 1 143 4 array bit (1) unaligned, 1 144 4 scalar bit (1) unaligned, 1 145 4 VLA bit (1) unaligned, 1 146 3 star_extents bit (1) unaligned, 1 147 3 pad bit (9) unaligned, 1 148 3 symbol fixed bin (18) unaligned; 1 149 1 150 dcl num_args fixed bin; 1 151 1 152 1 153 /* ARRAY REF NODE -- Must be same size as TEMPORARY NODE. */ 1 154 1 155 dcl 1 array_ref aligned based structure, 1 156 1 157 /* WORD 1 */ 1 158 1 159 2 node_type fixed bin (4) unaligned, 1 160 2 data_type fixed bin (4) unaligned unsigned, 1 161 2 operand_type fixed bin (4) unaligned, 1 162 1 163 2 addressing_bits unaligned structure, 1 164 3 is_addressable bit (1), 1 165 3 value_in, 1 166 4 eaq bit (1), 1 167 4 x bit (1), 1 168 3 allocated bit (1), 1 169 3 needs_pointer bit (1), 1 170 3 stack_indirect bit (1), 1 171 3 large_address bit (1), 1 172 3 address_in_base bit (1), 1 173 3 dont_update bit (1), /* for optimizer */ 1 174 3 not_in_storage bit (1), /* for optimizer */ 1 175 3 globally_assigned bit (1), /* for optimizer */ 1 176 1 177 2 bits unaligned structure, 1 178 3 standard_bits, 1 179 4 allocate bit (1), 1 180 4 set bit (1), 1 181 4 referenced bit (1), 1 182 4 passed_as_arg bit (1), 1 183 1 184 3 variable_length bit (1), 1 185 1 186 3 variable_offset bit (1), 1 187 1 188 3 invariant bit (1), /* must line up with temporary node */ 1 189 3 irreducible bit (1), /* .. */ 1 190 3 used_across_loops bit (1), /* .. */ 1 191 1 192 3 large_offset bit (1), 1 193 1 194 3 has_address bit (1), 1 195 1 196 /* WORD 2 */ 1 197 1 198 2 address aligned structure, 1 199 3 base bit (3) unaligned, 1 200 3 offset fixed bin (14) unaligned, 1 201 3 char_num fixed bin (2) unaligned unsigned, 1 202 3 bit_num fixed bin (4) unaligned unsigned, 1 203 3 fill bit (4) unaligned, 1 204 3 inhibit bit (1) unaligned, 1 205 3 ext_base bit (1) unaligned, 1 206 3 tag bit (6) unaligned, 1 207 1 208 /* WORD 3 */ 1 209 1 210 2 units fixed bin (3) unaligned unsigned, 1 211 2 fill bit (3) unaligned, 1 212 2 reloc_hold bit (6) unaligned, 1 213 2 reloc bit (6) unaligned, 1 214 2 addr_hold bit (18) unaligned, 1 215 1 216 /* WORD 4 */ 1 217 1 218 2 next fixed bin (18) unsigned unaligned, 1 219 2 loop_end_fu_pos fixed bin (17) unaligned, /* must overlay temporary.loop_end_fu_pos */ 1 220 1 221 /* WORD 5 */ 1 222 1 223 2 pad fixed bin (18) unsigned unaligned, 1 224 2 v_offset fixed bin (18) unsigned unaligned, 1 225 1 226 /* WORD 6 */ 1 227 1 228 2 location fixed bin (24) aligned, 1 229 1 230 /* WORD 7 */ 1 231 1 232 2 ref_count fixed bin (17) unaligned, /* must overlay temporary.ref_count */ 1 233 2 output_by fixed bin (18) unsigned unal, /* must overlay temporary.output_by */ 1 234 1 235 /* WORD 8 */ 1 236 1 237 2 length fixed bin (24) aligned, 1 238 1 239 /* WORD 9 */ 1 240 1 241 2 start_input_to fixed bin (18) unsigned unal, /* must overlay temporary.start_input_to */ 1 242 2 end_input_to fixed bin (18) unsigned unal, /* must overlay temporary.end_input_to */ 1 243 1 244 /* WORD 10 */ 1 245 1 246 2 ref_count_copy fixed bin (17) unaligned, /* must overlay temporary.ref_count_copy */ 1 247 2 parent fixed bin (18) unsigned unaligned, 1 248 1 249 /* WORD 11 */ 1 250 1 251 2 unused fixed bin (24) aligned; /* Pad to size of 'temporary'. */ 1 252 1 253 1 254 /* CONSTANT NODE */ 1 255 1 256 dcl 1 constant aligned based structure, 1 257 1 258 /* WORD 1 */ 1 259 1 260 2 node_type fixed bin (4) unaligned, 1 261 2 data_type fixed bin (4) unaligned unsigned, 1 262 2 operand_type fixed bin (4) unaligned, 1 263 1 264 2 addressing_bits unaligned structure, 1 265 3 is_addressable bit (1), 1 266 3 value_in, 1 267 4 eaq bit (1), 1 268 4 x bit (1), 1 269 3 allocated bit (1), 1 270 3 needs_pointer bit (1), 1 271 3 stack_indirect bit (1), 1 272 3 large_address bit (1), 1 273 3 address_in_base bit (1), 1 274 3 dont_update bit (1), /* for optimizer */ 1 275 3 not_in_storage bit (1), /* for optimizer */ 1 276 3 globally_assigned bit (1), /* for optimizer */ 1 277 1 278 2 bits unaligned structure, 1 279 3 standard_bits, 1 280 4 allocate bit (1), 1 281 4 set bit (1), 1 282 4 referenced bit (1), 1 283 4 passed_as_arg bit (1), 1 284 1 285 3 fill bit (7), 1 286 1 287 /* WORD 2 */ 1 288 1 289 2 address aligned structure, 1 290 3 location fixed bin (18) unsigned unaligned, 1 291 3 op bit (10) unaligned, 1 292 3 inhibit bit (1) unaligned, 1 293 3 ext_base bit (1) unaligned, 1 294 3 tag bit (6) unaligned, 1 295 1 296 /* WORD 3 */ 1 297 1 298 2 units fixed bin (3) unaligned unsigned, 1 299 2 fill bit (3) unaligned, 1 300 2 reloc_hold bit (6) unaligned, 1 301 2 reloc bit (6) unaligned, 1 302 2 addr_hold bit (18) unaligned, 1 303 1 304 /* WORD 4 */ 1 305 1 306 2 next_constant fixed bin (18) unsigned unaligned, 1 307 2 hash_chain fixed bin (18) unsigned unaligned, 1 308 1 309 /* WORDS 5 & 6 */ 1 310 1 311 2 value bit (72) aligned; 1 312 1 313 1 314 /* CHARACTER CONSTANT NODE */ 1 315 1 316 dcl 1 char_constant aligned based structure, 1 317 1 318 /* WORD 1 */ 1 319 1 320 2 node_type fixed bin (4) unaligned, 1 321 2 data_type fixed bin (4) unaligned unsigned, 1 322 2 operand_type fixed bin (4) unaligned, 1 323 1 324 2 addressing_bits unaligned structure, 1 325 3 is_addressable bit (1), 1 326 3 value_in, 1 327 4 eaq bit (1), 1 328 4 x bit (1), 1 329 3 allocated bit (1), 1 330 3 needs_pointer bit (1), 1 331 3 stack_indirect bit (1), 1 332 3 large_address bit (1), 1 333 3 address_in_base bit (1), 1 334 3 dont_update bit (1), /* for optimizer */ 1 335 3 not_in_storage bit (1), /* for optimizer */ 1 336 3 globally_assigned bit (1), /* for optimizer */ 1 337 1 338 2 bits unaligned structure, 1 339 3 standard_bits, 1 340 4 allocate bit (1), 1 341 4 set bit (1), 1 342 4 referenced bit (1), 1 343 4 passed_as_arg bit (1), 1 344 1 345 3 no_value_stored bit (1), 1 346 1 347 3 fill bit (6), 1 348 1 349 /* WORD 2 */ 1 350 1 351 2 address aligned structure, 1 352 3 location fixed bin (18) unsigned unaligned, 1 353 3 char_num fixed bin (2) unaligned unsigned, 1 354 3 bit_num fixed bin (4) unaligned unsigned, 1 355 3 fill bit (4) unaligned, 1 356 3 inhibit bit (1) unaligned, 1 357 3 ext_base bit (1) unaligned, 1 358 3 tag bit (6) unaligned, 1 359 1 360 /* WORD 3 */ 1 361 1 362 2 units fixed bin (3) unaligned unsigned, 1 363 2 fill bit (3) unaligned, 1 364 2 reloc_hold bit (6) unaligned, 1 365 2 reloc bit (6) unaligned, 1 366 2 addr_hold bit (18) unaligned, 1 367 1 368 /* WORD 4 */ 1 369 1 370 2 next_constant fixed bin (18) unsigned unaligned, 1 371 2 hash_chain fixed bin (18) unsigned unaligned, 1 372 1 373 /* WORDS 5 thru n */ 1 374 1 375 2 length fixed bin (18) unsigned unaligned, 1 376 2 value char(char_constant_length refer(char_constant.length)) unaligned; 1 377 1 378 dcl char_constant_length fixed bin (18) unsigned; 1 379 1 380 1 381 /* DIMENSION NODE */ 1 382 1 383 dcl 1 dimension aligned based structure, 1 384 1 385 /* WORD 1 */ 1 386 1 387 2 node_type fixed bin (4) unaligned, /* The only field in common with other nodes */ 1 388 1 389 2 number_of_dims fixed bin (3) unaligned, /* Number of dimensions */ 1 390 1 391 2 v_bound (7) unaligned, /* Variable bound info - up to 7 dims. */ 1 392 3 lower bit (1) unaligned, /* On if lower bound is variable */ 1 393 3 upper bit (1) unaligned, /* On if upper bound is variable */ 1 394 1 395 2 has_virtual_origin bit (1) unaligned, /* On if virtual_origin is valid */ 1 396 2 has_array_size bit (1) unaligned, /* On if array_size is valid */ 1 397 2 has_dim_sizes bit (1) unaligned, /* On if dim.size (*) is valid */ 1 398 1 399 2 variable_virtual_origin bit (1) unaligned, /* On if virtual_origin is variable */ 1 400 2 variable_array_size bit (1) unaligned, /* On if array_size is variable */ 1 401 2 assumed_size bit (1) unaligned, /* On if array has assumed size */ 1 402 1 403 2 fill bit (7) unaligned, 1 404 1 405 /* WORD 2 */ 1 406 1 407 2 virtual_origin fixed bin (24) aligned, 1 408 1 409 /* WORD 3 */ 1 410 1 411 2 element_count fixed bin (24) aligned, 1 412 1 413 /* WORD 4 */ 1 414 1 415 2 array_size fixed bin (24) aligned, /* Expressed in symbol.units */ 1 416 1 417 /* WORD 5 */ 1 418 1 419 2 VLA_base_addressor fixed bin (18) aligned, 1 420 1 421 /* WORDS 6 - n (max = 26) */ 1 422 1 423 2 dim (num_dims refer (dimension.number_of_dims)) aligned, 1 424 1 425 3 lower_bound fixed bin (24) aligned, /* Lower bound of this dimension */ 1 426 1 427 3 upper_bound fixed bin (24) aligned, /* Upper bound of this dimension */ 1 428 1 429 3 size fixed bin (24) aligned; /* No. of elements in this dimension */ 1 430 1 431 dcl num_dims fixed bin (3); 1 432 1 433 1 434 /* HEADER NODE */ 1 435 1 436 dcl 1 header aligned based structure, 1 437 1 438 /* WORD 1 */ 1 439 1 440 2 node_type fixed bin (4) unaligned, 1 441 2 data_type fixed bin (4) unaligned unsigned, 1 442 2 operand_type fixed bin (4) unaligned, 1 443 1 444 2 addressing_bits unaligned structure, 1 445 3 is_addressable bit (1), 1 446 3 value_in, 1 447 4 eaq bit (1), 1 448 4 x bit (1), 1 449 3 allocated bit (1), 1 450 3 needs_pointer bit (1), 1 451 3 stack_indirect bit (1), 1 452 3 large_address bit (1), 1 453 3 address_in_base bit (1), 1 454 3 dont_update bit (1), /* for optimizer */ 1 455 3 not_in_storage bit (1), /* for optimizer */ 1 456 3 globally_assigned bit (1), /* for optimizer */ 1 457 1 458 2 bits unaligned structure, 1 459 3 storage_info, 1 460 4 standard_bits, 1 461 5 allocate bit (1), 1 462 5 set bit (1), 1 463 5 referenced bit (1), 1 464 5 passed_as_arg bit (1), 1 465 4 initialed bit (1), /* On if any member has initial attribute. */ 1 466 1 467 3 alignment structure unaligned, 1 468 4 even bit (1), 1 469 4 odd bit (1), 1 470 4 character bit (1), 1 471 1 472 3 storage_class structure unaligned, 1 473 4 automatic bit (1), 1 474 4 static bit (1), 1 475 4 in_common bit (1), 1 476 1 477 /* WORD 2 */ 1 478 1 479 2 address aligned structure, 1 480 3 base bit (3) unaligned, 1 481 3 offset fixed bin (14) unaligned, 1 482 3 char_num fixed bin (2) unaligned unsigned, 1 483 3 bit_num fixed bin (4) unaligned unsigned, 1 484 3 fill bit (4) unaligned, 1 485 3 inhibit bit (1) unaligned, 1 486 3 ext_base bit (1) unaligned, 1 487 3 tag bit (6) unaligned, 1 488 1 489 /* WORD 3 */ 1 490 1 491 2 units fixed bin (3) unaligned unsigned, 1 492 2 VLA bit (1) unaligned, /* chain for VLA's */ 1 493 2 LA bit (1) unaligned, /* chain for LA's */ 1 494 2 fill bit (1) unaligned, 1 495 2 reloc_hold bit (6) unaligned, 1 496 2 reloc bit (6) unaligned, 1 497 2 addr_hold bit (18) unaligned, 1 498 1 499 /* WORD 4 */ 1 500 1 501 2 next_header fixed bin (18) unsigned unaligned, 1 502 2 first_element fixed bin (18) unsigned unaligned, 1 503 1 504 /* WORD 5 */ 1 505 1 506 2 last_element fixed bin (18) unsigned unaligned, 1 507 2 name_length fixed bin (17) unaligned, 1 508 1 509 /* WORD 6 */ 1 510 1 511 2 location fixed bin (24) aligned, 1 512 1 513 /* WORD 7 */ 1 514 1 515 2 length fixed bin (24) aligned, 1 516 1 517 /* WORD 8 */ 1 518 1 519 2 VLA_base_addressor fixed bin (18) aligned, 1 520 1 521 /* WORDS 9 - n. This field is variable in length. Its length is zero for equivalence groups. */ 1 522 1 523 2 block_name char(allocate_symbol_name refer (header.name_length)) aligned; 1 524 1 525 dcl allocate_symbol_name fixed bin; 1 526 1 527 1 528 /* LABEL NODE */ 1 529 1 530 dcl 1 label aligned based structure, 1 531 1 532 /* WORD 1 */ 1 533 1 534 2 node_type fixed bin (4) unaligned, 1 535 2 data_type fixed bin (4) unaligned unsigned, 1 536 2 operand_type fixed bin (4) unaligned, 1 537 1 538 2 addressing_bits unaligned structure, 1 539 3 is_addressable bit (1), 1 540 3 value_in, 1 541 4 eaq bit (1), 1 542 4 x bit (1), 1 543 3 allocated bit (1), 1 544 3 needs_pointer bit (1), 1 545 3 stack_indirect bit (1), 1 546 3 large_address bit (1), 1 547 3 address_in_base bit (1), 1 548 3 dont_update bit (1), /* for optimizer */ 1 549 3 not_in_storage bit (1), /* for optimizer */ 1 550 3 globally_assigned bit (1), /* for optimizer */ 1 551 1 552 2 bits unaligned structure, 1 553 3 storage_info, 1 554 4 standard_bits, 1 555 5 allocate bit (1), 1 556 5 set bit (1), 1 557 5 referenced bit (1), 1 558 5 passed_as_arg bit (1), 1 559 4 referenced_executable bit (1), 1 560 1 561 3 usage, /* Label is on a non-executable stmnt if both bits are ON. */ 1 562 4 format bit (1), 1 563 4 executable bit (1), 1 564 1 565 3 restore_prs bit (1), 1 566 3 not_referencable bit (1), 1 567 3 branched_to bit (1), 1 568 3 ends_do_loop bit (1), 1 569 1 570 /* WORD 2 */ 1 571 1 572 2 address aligned structure, 1 573 3 location fixed bin (18) unsigned unaligned, 1 574 3 op bit (10) unaligned, 1 575 3 inhibit bit (1) unaligned, 1 576 3 ext_base bit (1) unaligned, 1 577 3 tag bit (6) unaligned, 1 578 1 579 /* WORD 3 */ 1 580 1 581 2 units fixed bin (3) unaligned unsigned, 1 582 2 fill bit (3) unaligned, 1 583 2 reloc_hold bit (6) unaligned, 1 584 2 reloc bit (6) unaligned, 1 585 2 addr_hold bit (18) unaligned, 1 586 1 587 /* WORD 4 */ 1 588 1 589 2 next_label fixed bin (18) unsigned unaligned, 1 590 2 hash_chain fixed bin (18) unsigned unaligned, 1 591 1 592 /* WORD 5 */ 1 593 1 594 2 format_var fixed bin (18) unsigned unaligned, 1 595 2 name fixed bin (17) unaligned, 1 596 1 597 /* WORD 6 */ 1 598 1 599 2 statement fixed bin (18) unsigned unaligned, 1 600 2 loop_end fixed bin (18) unsigned unaligned; 1 601 1 602 1 603 /* LIBRARY NODE */ 1 604 1 605 dcl 1 library aligned based structure, 1 606 1 607 /* WORD 1 */ 1 608 1 609 2 node_type fixed bin (4) unaligned, /* The only field in common with the other nodes. */ 1 610 2 fill bit (13) unaligned, 1 611 2 next_library_node fixed bin (18) unsigned unaligned, 1 612 1 613 /* WORD 2 */ 1 614 1 615 2 character_operand fixed bin (18) unsigned aligned; 1 616 1 617 1 618 /* MACHINE_STATE NODE */ 1 619 1 620 dcl 1 machine_state aligned based structure, 1 621 1 622 /* WORD 1 */ 1 623 1 624 2 node_type fixed bin (4) unal, 1 625 2 pad bit (31) unal, 1 626 1 627 /* WORD 2 */ 1 628 1 629 2 next pointer unaligned, 1 630 1 631 /* WORDS 3-104 */ 1 632 1 633 2 ms aligned, 1 634 1 635 3 eaq (4), /* One for each of the A, Q, EAQ, and IND */ 1 636 4 name fixed bin, 1 637 4 number fixed bin, 1 638 4 variable(4) fixed bin (18), 1 639 4 reserved bit (1) aligned, 1 640 3 rounded bit (1) aligned, 1 641 3 indicators_valid fixed bin (18), 1 642 1 643 3 value_in_xr bit (1) aligned, 1 644 1 645 3 index_regs(0:7), 1 646 4 bits structure unaligned, 1 647 5 global bit (1), 1 648 5 reserved bit (1), 1 649 5 mbz bit (34), 1 650 4 type fixed bin (18), 1 651 4 variable fixed bin (18), 1 652 4 used fixed bin (18), 1 653 4 mbz fixed bin (18), 1 654 1 655 3 address_in_base bit (1) aligned, 1 656 1 657 3 base_regs(0:7), 1 658 4 bits structure unaligned, 1 659 5 global bit (1), 1 660 5 reserved bit (1), 1 661 5 mbz bit (34), 1 662 4 type fixed bin (18), 1 663 4 variable fixed bin (18), 1 664 4 used fixed bin (18), 1 665 4 offset fixed bin (18), 1 666 1 667 3 stack_extended bit (1) aligned, 1 668 3 last_dynamic_temp fixed bin (18); 1 669 1 670 /* POINTER NODE */ 1 671 1 672 dcl 1 pointer aligned based structure, 1 673 1 674 /* WORD 1 */ 1 675 1 676 2 node_type fixed bin (4) unaligned, 1 677 2 pad bit (4) unaligned, 1 678 2 code fixed bin (9) unaligned unsigned, 1 679 2 variable fixed bin (18) unaligned unsigned, 1 680 1 681 /* WORD 2 */ 1 682 1 683 2 offset fixed bin (18) unaligned unsigned, 1 684 2 count fixed bin (18) unaligned unsigned, 1 685 1 686 /* WORD 3 */ 1 687 1 688 2 hash_chain fixed bin (18) aligned; 1 689 1 690 1 691 /* SOURCE NODE */ 1 692 1 693 dcl 1 source aligned based structure, 1 694 1 695 /* WORD 1 */ 1 696 1 697 2 node_type fixed bin (4) unal, 1 698 2 pad bit (13) unal, 1 699 2 line_number fixed bin (17) unaligned, 1 700 1 701 /* WORD 2 */ 1 702 1 703 2 uid bit (36) aligned, 1 704 1 705 /* WORDS 3 & 4 */ 1 706 1 707 2 dtm fixed bin (71) unaligned, 1 708 1 709 /* WORD 5 */ 1 710 1 711 2 next fixed bin (18) unsigned unaligned, 1 712 2 initial_subprogram fixed bin (18) unsigned unaligned, 1 713 1 714 /* WORDS 6 - ? (depends on length of pathname) */ 1 715 1 716 2 pathname char(256) varying; 1 717 1 718 1 719 /* STATEMENT NODE - This node only appears in the polish. */ 1 720 1 721 dcl 1 statement aligned based structure, 1 722 1 723 /* WORD 1 */ 1 724 1 725 2 op_code fixed bin aligned, /* Always equal to "stat_op". */ 1 726 1 727 /* WORD 2 */ 1 728 1 729 2 next bit (18) unaligned, /* "0"b = no next stmnt */ 1 730 2 location bit (18) unaligned, /* (18)"1"b = no text */ 1 731 1 732 /* WORD 3 */ 1 733 1 734 2 source_id structure unaligned, 1 735 3 file fixed bin (8) unsigned, /* 0 = first file */ 1 736 3 line bit (14), 1 737 3 statement bit (5), /* 1 = first statement */ 1 738 1 739 2 length bit (9) unaligned, 1 740 1 741 /* WORD 4 */ 1 742 1 743 2 bits structure unaligned, 1 744 3 put_in_map bit (1) unaligned, 1 745 3 put_in_profile bit (1) unaligned, 1 746 3 pad bit (7) unaligned, 1 747 1 748 2 start fixed bin (26) unaligned; 1 749 1 750 1 751 /* SUBPROGRAM NODE */ 1 752 1 753 dcl 1 subprogram aligned based structure, 1 754 1 755 /* WORD 1 */ 1 756 1 757 2 node_type fixed bin (4) unaligned, /* The only field in common with the other nodes. */ 1 758 2 subprogram_type fixed bin (3) unaligned, 1 759 2 default_is unaligned, 1 760 3 auto bit (1), 1 761 3 static bit (1), 1 762 2 need_PS bit (1) unaligned, 1 763 2 need_prologue bit (1) unaligned, 1 764 2 multiple_entry bit (1) unaligned, 1 765 2 namelist_used bit (1) unaligned, 1 766 2 has_parameters bit (1) unaligned, 1 767 2 star_extent_function bit (1) unaligned, 1 768 2 fill bit (1) unaligned, 1 769 1 770 2 symbol fixed bin (18) unsigned unaligned, /* symbol node for subprogram name */ 1 771 1 772 /* WORD 2 */ 1 773 1 774 2 previous_subprogram fixed bin (18) unsigned unaligned, 1 775 2 next_subprogram fixed bin (18) unsigned unaligned, 1 776 1 777 /* WORD 3 */ 1 778 1 779 2 common_chain fixed bin (18) unsigned unaligned, 1 780 2 equiv_chain fixed bin (18) unsigned unaligned, 1 781 1 782 /* WORD 4 */ 1 783 1 784 2 first_symbol fixed bin (18) unsigned unaligned, 1 785 2 last_symbol fixed bin (18) unsigned unaligned, 1 786 1 787 /* WORD 5 */ 1 788 1 789 2 first_label fixed bin (18) unsigned unaligned, 1 790 2 last_label fixed bin (18) unsigned unaligned, 1 791 1 792 /* WORD 6 */ 1 793 1 794 2 first_polish fixed bin (18) unsigned unaligned, 1 795 2 last_polish fixed bin (18) unsigned unaligned, 1 796 1 797 /* WORD 7 */ 1 798 1 799 2 map unaligned, 1 800 3 first fixed bin (18) unsigned unaligned, 1 801 3 last fixed bin (18) unsigned unaligned, 1 802 1 803 /* WORD 8 */ 1 804 1 805 2 entry_info fixed bin (18) unsigned unaligned, 1 806 2 runtime fixed bin (18) unsigned unaligned, 1 807 1 808 /* WORD 9 */ 1 809 1 810 2 first_quad fixed bin (18) unsigned unaligned, 1 811 2 last_quad fixed bin (18) unsigned unaligned, 1 812 1 813 /* WORD 10 */ 1 814 1 815 2 options aligned like fortran_options, 1 816 1 817 /* WORDS 11 - 44 */ 1 818 1 819 2 storage_info(17) aligned, 1 820 3 first fixed bin (18) unsigned unaligned, 1 821 3 last fixed bin (18) unsigned unaligned, 1 822 3 next_loc fixed bin (18) aligned, 1 823 1 824 /* WORD 45 */ 1 825 1 826 2 loop_vector_p pointer unaligned, 1 827 1 828 /* WORD 46 */ 1 829 1 830 2 n_loops fixed bin (18) unsigned unaligned, 1 831 2 max_operators fixed bin (18) unsigned unaligned, 1 832 1 833 /* WORD 47 */ 1 834 1 835 2 VLA_chain fixed bin (18) unsigned unaligned, /* Mod 1 */ 1 836 2 LA_chain fixed bin (18) unsigned unaligned, /* Mod 1 */ 1 837 /* WORD 48 */ 1 838 1 839 2 max_sym fixed bin (18) aligned; 1 840 1 841 1 842 /* SYMBOL NODE */ 1 843 1 844 dcl 1 symbol aligned based structure, 1 845 1 846 /* WORD 1 */ 1 847 1 848 2 node_type fixed bin (4) unaligned, 1 849 2 data_type fixed bin (4) unaligned unsigned, 1 850 2 operand_type fixed bin (4) unaligned, 1 851 1 852 2 addressing_bits unaligned structure, 1 853 3 is_addressable bit (1), 1 854 3 value_in, 1 855 4 eaq bit (1), 1 856 4 x bit (1), 1 857 3 allocated bit (1), 1 858 3 needs_pointer bit (1), 1 859 3 stack_indirect bit (1), 1 860 3 large_address bit (1), 1 861 3 address_in_base bit (1), 1 862 3 dont_update bit (1), /* for optimizer */ 1 863 3 not_in_storage bit (1), /* for optimizer */ 1 864 3 globally_assigned bit (1), /* for optimizer */ 1 865 1 866 2 bits unaligned structure, 1 867 3 storage_info, 1 868 4 standard_bits, 1 869 5 allocate bit (1), 1 870 5 set bit (1), 1 871 5 referenced bit (1), 1 872 5 passed_as_arg bit (1), 1 873 4 initialed bit (1), /* Allows variable to become a constant. */ 1 874 1 875 3 variable_arglist bit (1), 1 876 3 dummy_arg bit (1), 1 877 3 variable_extents bit (1), 1 878 3 needs_descriptors bit (1), 1 879 3 put_in_symtab bit (1), 1 880 3 by_compiler bit (1), 1 881 1 882 /* WORD 2 */ 1 883 1 884 2 address aligned structure, 1 885 3 base bit (3) unaligned, 1 886 3 offset fixed bin (14) unaligned, 1 887 3 char_num fixed bin (2) unaligned unsigned, 1 888 3 bit_num fixed bin (4) unaligned unsigned, 1 889 3 fill bit (4) unaligned, 1 890 3 inhibit bit (1) unaligned, 1 891 3 ext_base bit (1) unaligned, 1 892 3 tag bit (6) unaligned, 1 893 1 894 /* WORD 3 */ 1 895 1 896 2 units fixed bin (3) unaligned unsigned, 1 897 2 aliasable bit (1) unaligned, 1 898 2 has_constant_value bit (1) unaligned, 1 899 2 new_induction_var bit (1) unaligned, 1 900 2 reloc_hold bit (6) unaligned, 1 901 2 reloc bit (6) unaligned, 1 902 2 addr_hold bit (18) unaligned, 1 903 1 904 /* WORD 4 */ 1 905 1 906 2 next_symbol fixed bin (18) unsigned unaligned, 1 907 2 hash_chain fixed bin (18) unsigned unaligned, 1 908 1 909 /* WORD 5 */ 1 910 1 911 2 ext_attributes unaligned structure, 1 912 3 VLA bit (1), /* symbol is Very large Element */ 1 913 3 LA bit (1), /* symbol is Large Element */ 1 914 3 pad bit (18-2), 1 915 1 916 2 loop_ref_count fixed bin (17) unaligned, 1 917 1 918 /* WORD 6 */ 1 919 1 920 2 location fixed bin (24) aligned, 1 921 1 922 /* WORD 7 */ 1 923 1 924 2 v_length fixed bin (18) unsigned unaligned, 1 925 2 general fixed bin (18) unsigned unaligned, 1 926 1 927 /* WORD 8 */ 1 928 1 929 2 parent fixed bin (18) unsigned unaligned, 1 930 2 next_member fixed bin (18) unsigned unaligned, 1 931 1 932 /* WORD 9 */ 1 933 1 934 2 attributes aligned structure, 1 935 3 mode_bits unaligned structure, 1 936 4 char_size fixed bin (20) unsigned, 1 937 4 mode, 1 938 5 integer bit (1), 1 939 5 real bit (1), 1 940 5 double_precision bit (1), 1 941 5 complex bit (1), 1 942 5 logical bit (1), 1 943 5 character bit (1), 1 944 5 label_value bit (1), 1 945 5 entry_value bit (1), 1 946 1 947 3 misc_attributes unaligned structure, 1 948 4 function bit (1), 1 949 4 subroutine bit (1), 1 950 4 entry_point bit (1), 1 951 4 external bit (1), 1 952 4 builtin bit (1), 1 953 4 stmnt_func bit (1), 1 954 4 namelist bit (1), 1 955 4 dimensioned bit (1), 1 956 1 957 /* WORD 10 */ 1 958 1 959 3 storage_class unaligned structure, 1 960 4 automatic bit (1), 1 961 4 static bit (1), 1 962 4 in_common bit (1), 1 963 4 equivalenced bit (1), 1 964 4 parameter bit (1), 1 965 4 constant bit (1), /* If external or entry_point. */ 1 966 4 named_constant bit (1), 1 967 1 968 3 variable bit (1) unaligned, 1 969 3 in_equiv_stmnt bit (1) unaligned, 1 970 3 star_extents bit (1) unaligned, 1 971 3 descriptor bit (1) unaligned, 1 972 2 pad bit (25) unaligned, 1 973 1 974 /* WORD 11 */ 1 975 1 976 2 dimension fixed bin (18) unsigned unaligned, /* Bounds may be added after symbol is declared. */ 1 977 2 initial fixed bin (18) unsigned unaligned, 1 978 1 979 /* WORD 12 */ 1 980 1 981 2 runtime bit (18) unaligned, 1 982 2 name_length fixed bin (17) unaligned, 1 983 1 984 /* WORD 13 */ 1 985 1 986 2 coordinate fixed bin (17) unaligned, /* used by loop optimizer */ 1 987 2 element_size fixed bin (17) unaligned, 1 988 1 989 /* WORD 14 */ 1 990 1 991 2 secondary pointer unaligned, /* used by loop optimizer */ 1 992 1 993 /* WORD 15 */ 1 994 1 995 2 offset fixed bin (24) aligned, 1 996 1 997 /* WORDS 16 - n. This field is variable in length. */ 1 998 1 999 2 name char(allocate_symbol_name refer (symbol.name_length)) aligned; 1 1000 1 1001 1 1002 1 1003 /* TEMPORARY NODE -- Must be same size as ARRAY REF NODE. */ 1 1004 1 1005 dcl 1 temporary aligned based structure, 1 1006 1 1007 /* WORD 1 */ 1 1008 1 1009 2 node_type fixed bin (4) unaligned, 1 1010 2 data_type fixed bin (4) unaligned unsigned, 1 1011 2 operand_type fixed bin (4) unaligned, 1 1012 1 1013 2 addressing_bits unaligned structure, 1 1014 3 is_addressable bit (1), 1 1015 3 value_in, 1 1016 4 eaq bit (1), 1 1017 4 x bit (1), 1 1018 3 allocated bit (1), 1 1019 3 needs_pointer bit (1), 1 1020 3 stack_indirect bit (1), 1 1021 3 large_address bit (1), 1 1022 3 address_in_base bit (1), 1 1023 3 dont_update bit (1), /* for optimizer */ 1 1024 3 not_in_storage bit (1), /* for optimizer */ 1 1025 3 globally_assigned bit (1), /* for optimizer */ 1 1026 1 1027 2 bits unaligned structure, 1 1028 3 standard_bits, 1 1029 4 allocate bit (1), 1 1030 4 set bit (1), 1 1031 4 referenced bit (1), 1 1032 4 passed_as_arg bit (1), 1 1033 1 1034 3 variable_length bit (1), 1 1035 1 1036 3 fill bit (1), /* can be used */ 1 1037 1 1038 3 invariant bit (1), /* must line up with array_ref node */ 1 1039 3 irreducible bit (1), /* .. */ 1 1040 3 used_across_loops bit (1), /* .. */ 1 1041 3 frozen_for_do bit (1), 1 1042 3 used_as_subscript bit (1), 1 1043 1 1044 /* WORD 2 */ 1 1045 1 1046 2 address aligned structure, 1 1047 3 base bit (3) unaligned, 1 1048 3 offset fixed bin (14) unaligned, 1 1049 3 char_num fixed bin (2) unaligned unsigned, 1 1050 3 bit_num fixed bin (4) unaligned unsigned, 1 1051 3 fill bit (4) unaligned, 1 1052 3 inhibit bit (1) unaligned, 1 1053 3 ext_base bit (1) unaligned, 1 1054 3 tag bit (6) unaligned, 1 1055 1 1056 /* WORD 3 */ 1 1057 1 1058 2 units fixed bin (3) unaligned unsigned, 1 1059 2 fill bit (3) unaligned, 1 1060 2 reloc_hold bit (6) unaligned, 1 1061 2 reloc bit (6) unaligned, 1 1062 2 addr_hold bit (18) unaligned, 1 1063 1 1064 /* WORD 4 */ 1 1065 1 1066 2 next fixed bin (18) unsigned unaligned, 1 1067 2 loop_end_fu_pos fixed bin (17) unaligned, /* must overlay array_ref.loop_end_fu_pos */ 1 1068 1 1069 /* WORD 5 */ 1 1070 1 1071 2 pad fixed bin (18) unsigned unaligned, 1 1072 2 loop_ref_count fixed bin (17) unaligned, 1 1073 1 1074 /* WORD 6 */ 1 1075 1 1076 2 location fixed bin (24) aligned, 1 1077 1 1078 /* WORD 7*/ 1 1079 1 1080 2 ref_count fixed bin (17) unaligned, /* must overlay array_ref.ref_count */ 1 1081 2 output_by fixed bin (18) unsigned unal, /* must overlay array_ref.output_by */ 1 1082 1 1083 /* WORD 8 */ 1 1084 1 1085 2 size fixed bin (24) aligned, /* size in words */ 1 1086 1 1087 /* WORD 9 */ 1 1088 1 1089 2 start_input_to fixed bin (18) unsigned unal, /* must overlay array_ref.start_input_to */ 1 1090 2 end_input_to fixed bin (18) unsigned unal, /* must overlay array_ref.end_input_to */ 1 1091 1 1092 /* WORD 10 */ 1 1093 1 1094 2 ref_count_copy fixed bin (17) unaligned, /* must overlay array_ref.ref_count_copy */ 1 1095 2 ms_ref_count fixed bin (17) unaligned, /* counts occurances in saved machine states */ 1 1096 1 1097 /* WORD 11 */ 1 1098 1 1099 2 length fixed bin (24) aligned; /* length in characters */ 1 1100 1 1101 /* END fort_nodes.incl.pl1 */ 47 48 2 1 /* BEGIN fort_listing_nodes.incl.pl1 */ 2 2 2 3 /* Created: 30 August 1976, David Levin 2 4* 2 5*Last Modified: 9 October 1978, Paul Smee 2 6**/ 2 7 2 8 dcl 1 cross_reference(261120) aligned structure based(cref_base), 2 9 2 symbol fixed bin (18) unsigned unaligned, 2 10 2 line_no fixed bin(17) unaligned; 2 11 2 12 dcl 1 listing_info aligned structure based(cur_listing), 2 13 2 subprogram fixed bin (18) unsigned, 2 14 2 next fixed bin (18) unsigned, 2 15 2 first_line fixed bin (18) unsigned, 2 16 2 last_line fixed bin (18) unsigned, 2 17 2 first_cref fixed bin (18) unsigned, 2 18 2 last_cref fixed bin (18) unsigned, 2 19 2 first_error fixed bin (18) unsigned, 2 20 2 last_error fixed bin (18) unsigned; 2 21 2 22 dcl listing_seg(0:261119) fixed bin based(listing_base); 2 23 2 24 dcl 1 error_text aligned structure based, 2 25 2 next fixed bin (18) unsigned, 2 26 2 length fixed bin, 2 27 2 string char(error_text_length refer(error_text.length)) aligned; 2 28 2 29 dcl error_text_length fixed bin; 2 30 2 31 dcl 1 source_list (130560) aligned structure based (source_line_base), 2 32 2 file_number fixed bin (8) unaligned, 2 33 2 line_start fixed bin (21) unsigned unaligned, 2 34 2 unused_bits bit (6) unaligned, 2 35 2 line_length fixed bin (18) unsigned unaligned, 2 36 2 line_number_in_file fixed bin (18) unsigned unaligned; 2 37 2 38 /* END fort_listing_nodes.incl.pl1 */ 49 50 3 1 /* BEGIN fort_system_constants.incl.pl1 */ 3 2 3 3 3 4 3 5 /****^ HISTORY COMMENTS: 3 6* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 3 7* install(86-07-28,MR12.0-1105): 3 8* Fix fortran bug 428. 3 9* END HISTORY COMMENTS */ 3 10 3 11 3 12 /* Created: June 1976, David Levin */ 3 13 3 14 /* Modified: 3 15* 15 Dec 85, RW - 428: Changed max_char_length from 256 to 512. 3 16* 22 Jun 84, MM - Install typeless functions support. 3 17* 17 Jun 83, HH - 383: Added 'process_param_list_op'. 3 18* 12 Jan 83, HH - Added 'form_VLA_packed_ptr_op'. 3 19* 05 Oct 82, HH - Added 'units_per_word'. 3 20* 27 Sep 82, HH - Added 'max_fixed_bin_18', 'max_fixed_bin_24' and 'sys_info$max_seg_size'. 3 21* Removed 'max_stored_value' and 'min_stored_value'. 3 22* 24 October 1981, ME Presser - added inquire_op. 3 23* 20 October 1981, C R Davis - add (read write)_internal_file_op. 3 24* 11 May 1981, Marshall Presser - added op-codes for .EQV. and .NEQV. 3 25* 28 April 1981, Marshall Presser - added default_main_entry_point_name 3 26* 11 March 1981, Marshall Presser - add min_stored_value 3 27* 8 December 1980, C R Davis - add block_if_op, else_if_op, else_op. 3 28* 15 January 1980, C R Davis - add bits_per_char. 3 29* 21 December 1979, Richard A. Barnes - add unrecoverable_errror and 3 30* max_error_level. 3 31* 3 November 1979, Richard Barnes - add pointer_node. 3 32* 17 September 1979, Richard Barnes - add load_preg_op & load_xreg_op 3 33* 13 September 1979, Paul Smee - add colon and concat token types, 3 34* change value of EOS_token, remove default_char_size. 3 35* 31 August 1979, Charlie Davis - change offset units to 3 36* be consistent with those in runtime symbols. 3 37* 13 August 1979, Richard Barnes - add cat_op & substr_op 3 38* 19 July 1979, Richard Barnes - char mode 3 39* 10 October 1978, Paul Smee - double max_stored_value and bias. 3 40* 15 June 1978, Paul Smee - add max_num_of_rands 3 41* 16 November 1977, David Levin - add machine_state_node 3 42* 12 September 1977, Richard Barnes - new ops for loop optimizer 3 43* 30 August 1977, David Levin - change bias from 65536 to 131072. 3 44* 5 July 1977, David Levin - add open_op, close_op, and iostat_op. 3 45* 28 April 1977, David Levin - add xmit_vector_op in operator list 3 46* 22 April 1977, David Levin - add max_prec_single, last_assigned_mode 3 47* 24 February 1977, Gabriel Chang for the optimizer. 3 48* 23 February 1977, David Levin to change name of count operand. 3 49* 28 October 1976, David Levin and Gabriel Chang to add 2 new ops and 3 50* 1 new node type. 3 51* 2 September 1976, David Levin - add 8 new ops and change name of 3 52* data_op. 3 53**/ 3 54 /* SYSTEM CONSTANTS */ 3 55 3 56 dcl bias init(262144) fixed bin(19) int static options(constant); 3 57 dcl gap_value init(0) fixed bin int static options(constant); 3 58 dcl max_fixed_bin_18 init(111111111111111111b) fixed bin (18) static options (constant); 3 59 dcl max_fixed_bin_24 init(111111111111111111111111b) fixed bin (24) static options (constant); 3 60 dcl max_num_of_rands init(127) fixed bin int static options(constant); 3 61 dcl sys_info$max_seg_size 3 62 fixed bin (18) ext; 3 63 3 64 dcl ( unrecoverable_error init(3), 3 65 max_error_level init(4)) 3 66 fixed bin int static options(constant); 3 67 3 68 dcl (main_program init(0), 3 69 block_data init(1), 3 70 subroutine init(2), 3 71 function init(3), 3 72 chars_per_word init(4), 3 73 chars_per_dw init(8), 3 74 bits_per_char init(9), 3 75 first_auto_loc init(64), 3 76 max_prec_single init(8)) fixed bin(9) int static options(constant); 3 77 dcl max_char_length init(512) fixed bin(10) int static options(constant); 3 78 3 79 dcl blank_common_name init("blnk*com") char(8) aligned int static options(constant); 3 80 declare default_main_entry_point_name 3 81 char (5) int static options (constant) initial ("main_"); 3 82 declare unnamed_block_data_subprg_name 3 83 char (29) int static options (constant) initial ("unnamed block data subprogram"); 3 84 3 85 /* NODE TYPES */ 3 86 3 87 dcl (fill_node init(0), 3 88 source_node init(1), 3 89 symbol_node init(2), 3 90 dimension_node init(3), 3 91 temporary_node init(4), 3 92 constant_node init(5), 3 93 label_node init(6), 3 94 header_node init(7), 3 95 char_constant_node init(8), 3 96 array_ref_node init(9), 3 97 proc_frame_node init(10), 3 98 library_node init(11), 3 99 subprogram_node init(12), 3 100 arg_desc_node init(13), 3 101 pointer_node init(14), 3 102 machine_state_node init(15)) fixed bin(4) aligned internal static options(constant); 3 103 3 104 /* DATA TYPES */ 3 105 3 106 dcl (int_mode init(1), 3 107 real_mode init(2), 3 108 dp_mode init(3), 3 109 cmpx_mode init(4), 3 110 logical_mode init(5), 3 111 char_mode init(6), 3 112 typeless_mode init(7), 3 113 last_assigned_mode init(7)) fixed bin(4) aligned internal static options(constant); 3 114 3 115 dcl data_type_size(7) init(1,1,2,2,1,0,1) fixed bin int static options(constant); 3 116 3 117 3 118 /* OPERAND TYPES */ 3 119 3 120 dcl (variable_type init(1), 3 121 constant_type init(2), 3 122 array_ref_type init(3), 3 123 temp_type init(4), 3 124 count_type init(5), 3 125 rel_constant init(6), 3 126 bif init(7), 3 127 statement_function init(8), 3 128 external init(9), 3 129 entry_type init(10), 3 130 dummy init(11), 3 131 error init(12)) fixed bin(4) aligned internal static options(constant); 3 132 3 133 3 134 /* OFFSET UNITS */ 3 135 3 136 dcl 3 137 (word_units init (0), 3 138 bit_units init (1), 3 139 char_units init (2), 3 140 halfword_units init (3)) fixed bin (3) aligned internal static options(constant); 3 141 3 142 dcl units_per_word (0:3) init (1, 36, 4, 2) fixed bin (6) static options (constant); 3 143 3 144 3 145 /* TOKEN MASKS */ 3 146 3 147 dcl 3 148 (is_operand initial("101000000"b), 3 149 is_operator initial("010000000"b), 3 150 is_constant initial("001000000"b), 3 151 is_arith_constant initial("000100000"b)) bit(9) aligned internal static options(constant); 3 152 3 153 3 154 /* TOKEN TYPES */ 3 155 3 156 dcl (no_token initial("000000000"b), 3 157 ident initial("100000000"b), 3 158 plus initial("010000001"b), 3 159 minus initial("010000010"b), 3 160 asterisk initial("010000011"b), 3 161 slash initial("010000100"b), 3 162 expon initial("010000101"b), 3 163 not initial("010000110"b), 3 164 and initial("010000111"b), 3 165 or initial("010001000"b), 3 166 eq initial("010001001"b), 3 167 ne initial("010001010"b), 3 168 lt initial("010001011"b), 3 169 gt initial("010001100"b), 3 170 le initial("010001101"b), 3 171 ge initial("010001110"b), 3 172 assign initial("010001111"b), 3 173 comma initial("010010000"b), 3 174 left_parn initial("010010001"b), 3 175 right_parn initial("010010010"b), 3 176 apostrophe initial("010010011"b), 3 177 colon initial("010010100"b), 3 178 concat initial("010010101"b), 3 179 substr_left_parn initial("010010110"b), 3 180 eqv initial("010010111"b), 3 181 neqv initial("010011000"b), 3 182 EOS_token initial("010011111"b), 3 183 char_string initial("001000001"b), 3 184 logical_const initial("001000010"b), 3 185 false initial("001000010"b), /* Must be identical to true except low order bit off. */ 3 186 true initial("001000011"b), /* Must be identical to false except low order bit on. */ 3 187 label_const initial("001000100"b), 3 188 octal_const initial("001000101"b), 3 189 dec_int initial("001100110"b), 3 190 real_const initial("001100111"b), 3 191 double_const initial("001101000"b), 3 192 complex_const initial("001101001"b)) bit(9) aligned internal static options(constant); 3 193 3 194 3 195 /* OPERATOR NAMES */ 3 196 3 197 declare 3 198 (assign_op initial(1), 3 199 add_op initial(2), 3 200 sub_op initial(3), 3 201 mult_op initial(4), 3 202 div_op initial(5), 3 203 exponentiation_op initial(6), 3 204 negate_op initial(7), 3 205 less_op initial(8), 3 206 less_or_equal_op initial(9), 3 207 equal_op initial(10), 3 208 not_equal_op initial(11), 3 209 greater_or_equal_op initial(12), 3 210 greater_op initial(13), 3 211 or_op initial(14), 3 212 and_op initial(15), 3 213 not_op initial(16), 3 214 jump_op initial(17), 3 215 jump_logical_op initial(18), 3 216 jump_arithmetic_op initial(19), 3 217 jump_computed_op initial(20), 3 218 jump_assigned_op initial(21), 3 219 assign_label_op initial(22), 3 220 read_op initial(23), 3 221 write_op initial(24), 3 222 format_op initial(25), 3 223 end_label_op initial(26), 3 224 error_label_op initial(27), 3 225 xmit_scalar_op initial(28), 3 226 xmit_array_op initial(29), 3 227 xmit_vector_op initial(30), 3 228 endfile_op initial(31), 3 229 rewind_op initial(32), 3 230 backspace_op initial(33), 3 231 margin_op initial(34), 3 232 openfile_op initial(35), 3 233 closefile_op initial(36), 3 234 record_number_op initial(37), 3 235 string_op initial(38), 3 236 string_length_op initial(39), 3 237 terminate_op initial(40), 3 238 return_op initial(41), 3 239 pause_op initial(42), 3 240 stop_op initial(43), 3 241 item_op initial(44), 3 242 exit_op initial(45), 3 243 eol_op initial(46), 3 244 do_op initial(47), 3 245 builtin_op initial(48), 3 246 sf_op initial(49), 3 247 sf_def_op initial(50), 3 248 subscript_op initial(51), 3 249 func_ref_op initial(52), 3 250 block_data_op initial(53), 3 251 increment_polish_op initial(54), 3 252 main_op initial(55), 3 253 func_op initial(56), 3 254 subr_op initial(57), 3 255 stat_op initial(58), 3 256 label_op initial(59), 3 257 call_op initial(60), 3 258 chain_op initial(61), 3 259 endunit_op initial(62), 3 260 non_executable initial(63), 3 261 no_op initial(64), 3 262 form_VLA_packed_ptr_op initial(65), 3 263 opt_subscript_op initial(66), 3 264 left_shift_op initial(67), 3 265 right_shift_op initial(68), 3 266 store_zero_op initial(69), 3 267 storage_add_op initial(70), 3 268 storage_sub_op initial(71), 3 269 neg_storage_add_op initial(72), 3 270 storage_add_one_op initial(73), 3 271 namelist_op initial(74), 3 272 open_op initial(75), 3 273 close_op initial(76), 3 274 iostat_op initial(77), 3 275 convert_to_int_op initial(78), 3 276 convert_to_real_op initial(79), 3 277 convert_to_dp_op initial(80), 3 278 convert_to_cmpx_op initial(81), 3 279 read_scalar_op initial(82), 3 280 read_array_op initial(83), 3 281 read_vector_op initial(84), 3 282 write_scalar_op initial(85), 3 283 write_array_op initial(86), 3 284 write_vector_op initial(87), 3 285 jump_true_op initial(88), 3 286 jump_false_op initial(89), 3 287 sub_index_op initial(90), 3 288 loop_end_op initial(91), 3 289 read_namelist_op initial(92), 3 290 write_namelist_op initial(93), 3 291 decode_string_op initial(94), 3 292 encode_string_op initial(95), 3 293 cat_op initial(96), 3 294 substr_op initial(97), 3 295 load_xreg_op initial(98), 3 296 load_preg_op initial(99), 3 297 block_if_op initial(100), 3 298 else_if_op initial(101), 3 299 else_op initial(102), 3 300 equiv_op initial (103), 3 301 not_equiv_op initial (104), 3 302 read_internal_file_op initial (105), 3 303 write_internal_file_op initial (106), 3 304 inquire_op initial (107), 3 305 process_param_list_op initial (108), 3 306 lhs_fld_op initial (109), 3 307 last_assigned_op initial (109)) fixed bin(18) internal static options(constant); 3 308 3 309 /* END fort_system_constants.incl.pl1 */ 51 52 53 dcl 1 shared_globals structure aligned based (shared_struc_ptr), 4 1 4 2 /* BEGIN fort_shared_vars.incl.pl1 */ 4 3 4 4 4 5 4 6 /****^ HISTORY COMMENTS: 4 7* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 4 8* install(86-07-28,MR12.0-1105): 4 9* Fix fortran bug 463. 4 10* END HISTORY COMMENTS */ 4 11 4 12 4 13 /* Created: June 1976, David Levin 4 14* 4 15* Modified: 30 Aug 76, David Levin - to add global variables for listing segment. 4 16* Modified: 22 Nov 76, Richard Barnes - to add profile_size 4 17* Modified: 24 Feb 77, Gabriel Chang - for the optimizer 4 18* Modified: 06 Oct 77, Richard Barnes - for the loop optimizer 4 19* Modified: 16 Nov 77, David Levin - add next_free_(temp array_ref). 4 20* Modified: 09 Oct 78, Paul Smee - for larger common and arrays. 4 21* Modified: 03 Apr 79, Paul Smee - add list of include file data. 4 22* Modified: 17 May 79, Paul Smee - add cur_statement_list. 4 23* Modified: 28 Jun 79, Paul Smee - add compile-time math entry arrays. 4 24* Modified: 13 Sep 79, Paul Smee - add default_char_size. 4 25* Modified: 18 Dec 79, Richard Barnes - add free and freei 4 26* Modified: 03 Mar 80, C R Davis - add must_save_stack_extent. 4 27* Modified: 15 Mar 82, T G Oke - add source (line_number, file_number). 4 28* Modified: 20 Sept 82, T G Oke - add VLA_is_256K flag 4 29* Modified: 22 Sept 82, T G Oke - add area creation info to pass to 4 30* listing generator. 4 31* Modified: 17 May 83, M Mabey - add declared_options. 4 32* Modified: 02 Aug 85, B Wong - 463: changed 'must_save_stack_extent' 4 33* to 'pad' since the variable is no longer used. 4 34**/ 4 35 4 36 2 polish_base ptr, 4 37 2 operand_base ptr, 4 38 2 object_base ptr, 4 39 2 quadruple_base ptr, 4 40 2 opt_base ptr, 4 41 2 relocation_base ptr, 4 42 4 43 2 cref_base ptr, /* base of cross reference segment */ 4 44 2 source_line_base ptr, /* base of source line offset segment */ 4 45 2 listing_base ptr, /* base of listing info segment */ 4 46 2 cur_listing ptr, /* points to listing info for the active subprogram */ 4 47 4 48 2 free(2:4) ptr, /* free chains for optimizer */ 4 49 2 freei ptr, /* .. */ 4 50 4 51 2 polish_max_len fixed bin (19), 4 52 2 operand_max_len fixed bin (19), 4 53 2 object_max_len fixed bin (19), 4 54 2 quad_max_len fixed bin (19), 4 55 2 opt_max_len fixed bin (19), 4 56 4 57 2 next_free_polish fixed bin (18), 4 58 2 next_free_operand fixed bin (18), 4 59 2 next_free_object fixed bin (18), 4 60 2 next_free_listing fixed bin (18), 4 61 2 next_free_quad fixed bin (18), 4 62 2 next_free_array_ref fixed bin (18), /* Chain for freed array_ref nodes. */ 4 63 2 next_free_temp fixed bin (18), /* Chain for freed temporary nodes. */ 4 64 2 next_free_opt fixed bin (18), 4 65 4 66 2 first_segment fixed bin, 4 67 2 number_of_source_segments fixed bin (8), 4 68 2 number_of_lines fixed bin, 4 69 2 number_of_crefs fixed bin, 4 70 2 profile_size fixed bin, 4 71 4 72 2 main_entry_point_name char (32) varying, 4 73 4 74 2 cur_statement fixed bin (18), 4 75 2 cur_statement_list fixed bin (17), 4 76 2 cur_subprogram fixed bin (18), 4 77 2 first_subprogram fixed bin (18), 4 78 2 last_subprogram fixed bin (18), 4 79 2 unnamed_block_data_subprogram 4 80 fixed bin (18), 4 81 2 first_entry_name fixed bin (18), 4 82 2 last_entry_name fixed bin (18), 4 83 4 84 2 constant_info (4) aligned structure, 4 85 3 constant_count fixed bin (17), 4 86 3 first_constant fixed bin (18), 4 87 3 last_constant fixed bin (18), 4 88 4 89 2 options aligned, 4 90 3 user_options aligned like fortran_options, 4 91 3 system_options aligned, 4 92 4 is_fast bit (1) unaligned, 4 93 4 namelist_used bit (1) unaligned, 4 94 4 compile_only bit (1) unaligned, 4 95 4 VLA_is_256K bit (1) unaligned, /* FLAG 255/256K code */ 4 96 4 pad bit (32) unaligned, 4 97 4 98 2 incl_data aligned, 4 99 3 incl_count fixed bin, 4 100 3 file_list (0:255), 4 101 4 source_node_offset fixed bin (18), 4 102 4 incl_len fixed bin (21), 4 103 4 incl_ptr unaligned ptr, 4 104 4 105 2 create_constant entry (fixed bin (4), bit (72) aligned) returns (fixed bin (18)) 4 106 variable, 4 107 2 create_char_constant entry (char (*)) returns (fixed bin (18)) 4 108 variable, 4 109 2 print_message entry options (variable) 4 110 variable, 4 111 2 get_next_temp_segment entry (ptr, fixed bin (18)) returns (ptr) 4 112 variable, 4 113 2 negate_round (6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 4 114 returns (bit (72)) variable, 4 115 2 negate_trunc (6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 4 116 returns (bit (72)) variable, 4 117 2 binop_round (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 4 118 returns (bit (72)) variable, 4 119 2 binop_trunc (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 4 120 returns (bit (72)) variable, 4 121 2 comp_parm (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 4 122 returns (bit (72)) variable, 4 123 2 conv_round (6,6) entry (bit (72), fixed bin (35)) 4 124 returns (bit (72)) variable, 4 125 2 conv_trunc (6,6) entry (bit (72), fixed bin (35)) 4 126 returns (bit (72)) variable, 4 127 2 pad bit (1) aligned, 4 128 4 129 /* The following are used by "print_message - decode_source_id" if use_source_info set. */ 4 130 4 131 2 use_source_info bit (1) aligned, 4 132 2 source_file_number fixed bin (35), 4 133 2 source_line_number fixed bin (35), 4 134 2 Area_create_first fixed bin (18), /* start of text to do creation */ 4 135 2 Area_create_last fixed bin (18), /* Last item */ 4 136 2 Area_init_first fixed bin (18), /* start of text to init areas */ 4 137 2 Area_init_last fixed bin (18), /* Last item */ 4 138 2 declared_options aligned like fortran_declared; 4 139 4 140 dcl num_of_word_constants fixed bin (17) defined (constant_info (1).constant_count); 4 141 dcl first_word_constant fixed bin (18) defined (constant_info (1).first_constant); 4 142 dcl last_word_constant fixed bin (18) defined (constant_info (1).last_constant); 4 143 4 144 dcl num_of_dw_constants fixed bin (17) defined (constant_info (2).constant_count); 4 145 dcl first_dw_constant fixed bin (18) defined (constant_info (2).first_constant); 4 146 dcl last_dw_constant fixed bin (18) defined (constant_info (2).last_constant); 4 147 4 148 dcl num_of_char_constants fixed bin (17) defined (constant_info (3).constant_count); 4 149 dcl first_char_constant fixed bin (18) defined (constant_info (3).first_constant); 4 150 dcl last_char_constant fixed bin (18) defined (constant_info (3).last_constant); 4 151 4 152 dcl num_of_block_constants fixed bin (17) defined (constant_info (4).constant_count); 4 153 dcl first_block_constant fixed bin (18) defined (constant_info (4).first_constant); 4 154 dcl last_block_constant fixed bin (18) defined (constant_info (4).last_constant); 4 155 4 156 /* END fort_shared_vars.incl.pl1 */ 54 55 5 1 /* BEGIN INCLUDE FILE fort_options.incl.pl1 */ 5 2 5 3 /****^ *********************************************************** 5 4* * * 5 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 5 6* * * 5 7* *********************************************************** */ 5 8 5 9 /****^ HISTORY COMMENTS: 5 10* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 5 11* install(86-07-28,MR12.0-1105): 5 12* Fix fortran bug 473. 5 13* 2) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 5 14* install(87-08-06,MR12.1-1069): 5 15* Implemented SCP 6315: fortran error-handling argument. 5 16* END HISTORY COMMENTS */ 5 17 5 18 5 19 /* 5 20* Modified: 12 May 87 by RWaters added debug_io 5 21* Modified: 19 February 1986 by B. Wong & A. Ginter - 473.a: Correct 5 22* comments and size of pad field in fort_declared 5 23* and pad out dfast and fast bit masks to two words. 5 24* Modified: 09 October 1985 by B. Wong - 473: add VLA_auto, VLA_static, 5 25* VLA_parm, VLC, LA_auto, and LA_static. Remove VLA and LA. 5 26* Modified: 28 March 1984 by M. Mabey - Install HFP support. 5 27* Modified: 21 September 1983 by M. Mabey - correct size of pad field in fortran_declared. 5 28* Modified: 16 May 1983 by M. Mabey - add fortran_declared 5 29* Modified: 18 December 1982 by T. Oke - Add 'long_profile'. 5 30* Modified: 22 September 1982 by T. Oke - add VLA and LA 5 31* Modified: 3 May 1982 by T. Oke - add check_multiply 5 32* Modified: 06/24/81 by S. Herbst - add do_rounding & auto_zero to fast_mask and dfast_mask 5 33* Modified: 26 February 1980 by C R Davis - add fast_mask, fix dfast_mask. 5 34* Modified: 31 January 1980 by C R Davis - add stringrange. 5 35* Modified: 13 September 1979 by Paul E. Smee--add ansi_77. 5 36* Modified: 05 December 1978 by Paul E. Smee--add do_rounding, auto_zero. 5 37* Modified: 25 January 1978 by Richard A. Barnes for the loop optimizer 5 38**/ 5 39 5 40 declare 5 41 5 42 1 fortran_options aligned based, 5 43 2 use_library bit (1) unaligned, /* (1) ON if library statements will be parsed */ 5 44 2 optimize bit (1) unaligned, /* (2) ON if optimized code is to be produced */ 5 45 2 time bit (1) unaligned, /* (3) ON for compile timing */ 5 46 2 source_format unaligned, 5 47 3 has_line_numbers bit (1) unaligned, /* (4) ON if each line begins with a line number */ 5 48 3 fold bit (1) unaligned, /* (5) ON if variable names are to be folded to lowercase */ 5 49 3 card bit (1) unaligned, /* (6) ON for card format */ 5 50 3 convert bit (1) unaligned, /* (7) ON for card format to be converted */ 5 51 2 listing unaligned, 5 52 3 source bit (1) unaligned, /* (8) ON for listing of numbered source */ 5 53 3 symbol bit (1) unaligned, /* (9) ON for listing with symbol map */ 5 54 3 map bit (1) unaligned, /* (10) ON for listing with statement map */ 5 55 3 list bit (1) unaligned, /* (11) ON for listing with assembler instructions */ 5 56 2 error_messages unaligned, 5 57 3 brief bit (1) unaligned, /* (12) ON for brief error messages */ 5 58 3 severity fixed bin (3), /* (13-16) suppresses messages below this severity */ 5 59 2 debugging unaligned, 5 60 3 subscriptrange bit (1) unaligned, /* (17) ON for subscript range checking */ 5 61 3 stringrange bit (1) unaligned, /* (18) ON for string range checking */ 5 62 3 brief_table bit (1) unaligned, /* (19) ON for statement table */ 5 63 3 table bit (1) unaligned, /* (20) ON for statement and symbol table */ 5 64 3 profile bit (1) unaligned, /* (21) ON to generate code to meter statements */ 5 65 3 check bit (1) unaligned, /* (22) ON for syntactic and semantic checking only */ 5 66 2 system_debugging unaligned, 5 67 3 stop_after_cg bit (1) unaligned, /* (23) ON if debug stop after code generator */ 5 68 3 stop_after_parse bit (1) unaligned, /* (24) ON if debug stop after parse */ 5 69 2 relocatable bit (1) unaligned, /* (25) ON if relocatable object segment generated */ 5 70 2 optimizing unaligned, 5 71 3 time_optimizer bit (1) unaligned, /* (26) ON if timings for optimizer requested */ 5 72 /* (27) ON if optimizer can loosen safety constraints */ 5 73 3 ignore_articulation_blocks bit (1) unaligned, 5 74 3 consolidate bit(1) unaligned, /* (28) ON if optimizer should run consolidation phase */ 5 75 2 do_rounding bit(1) unaligned, /* (29) ON if floating point round should be used */ 5 76 2 auto_zero bit(1) unaligned, /* (30) ON if auto storage should be zeroed when allocated */ 5 77 2 ansi_77 bit (1) unaligned, /* (31) ON if ansi77 rules are to be followed */ 5 78 2 check_multiply bit (1) unaligned, /* (32) ON if check integer multiply extent */ 5 79 2 VLA_auto bit (1) unaligned, /* (33) ON if auto VLA's being done */ 5 80 2 VLA_parm bit (1) unaligned, /* (34) ON if parm VLA's being done */ 5 81 2 VLA_static bit (1) unaligned, /* (35) ON if static VLA's being done */ 5 82 2 VLC bit (1) unaligned, /* (36) ON if VLC's being done */ 5 83 2 LA_auto bit (1) unaligned, /* (1) ON if auto LA's being done */ 5 84 2 LA_static bit (1) unaligned, /* (2) ON if static LA's being done */ 5 85 2 long_profile bit (1) unaligned, /* (3) ON to generate long_profile */ 5 86 2 static_storage bit (1) unaligned, /* (4) ON if static storage */ 5 87 2 hfp bit (1) unaligned, /* (5) ON if using hex floating point math */ 5 88 2 debug_io bit (1) unaligned, /* (6) */ 5 89 2 pad bit(30) unaligned; /* (7-36) Pad bits */ 5 90 5 91 declare 5 92 5 93 1 fortran_declared aligned based, 5 94 2 ansi66 bit(1) unaligned, /* (1) First word */ 5 95 2 ansi77 bit(1) unaligned, /* (2) */ 5 96 2 auto bit(1) unaligned, /* (3) */ 5 97 2 auto_zero bit(1) unaligned, /* (4) */ 5 98 2 brief bit(1) unaligned, /* (5) */ 5 99 2 binary_floating_point bit(1) unaligned, /* (6) */ 5 100 2 brief_table bit(1) unaligned, /* (7) */ 5 101 2 card bit(1) unaligned, /* (8) */ 5 102 2 check bit(1) unaligned, /* (9) */ 5 103 2 check_multiply bit(1) unaligned, /* (10) */ 5 104 2 consolidate bit(1) unaligned, /* (11) */ 5 105 2 debug bit(1) unaligned, /* (12) */ 5 106 2 debug_cg bit(1) unaligned, /* (13) */ 5 107 2 debug_io bit(1) unaligned, /* (14) */ 5 108 2 default_full bit(1) unaligned, /* (15) */ 5 109 2 default_safe bit(1) unaligned, /* (16) */ 5 110 2 fold bit(1) unaligned, /* (17) */ 5 111 2 free bit(1) unaligned, /* (18) */ 5 112 2 full_optimize bit(1) unaligned, /* (19) */ 5 113 2 hexadecimal_floating_point bit(1) unaligned, 5 114 /* (20) */ 5 115 2 la_auto bit(1) unaligned, /* (21) */ 5 116 2 la_static bit(1) unaligned, /* (22) */ 5 117 2 large_array bit(1) unaligned, /* (23) */ 5 118 2 line_numbers bit(1) unaligned, /* (24) */ 5 119 2 list bit(1) unaligned, /* (25) */ 5 120 2 long bit(1) unaligned, /* (26) */ 5 121 2 long_profile bit(1) unaligned, /* (27) */ 5 122 2 map bit(1) unaligned, /* (28) */ 5 123 2 no_auto_zero bit(1) unaligned, /* (29) */ 5 124 2 no_check bit(1) unaligned, /* (30) */ 5 125 2 no_fold bit(1) unaligned, /* (31) */ 5 126 2 no_large_array bit(1) unaligned, /* (32) */ 5 127 2 no_line_numbers bit(1) unaligned, /* (33) */ 5 128 2 no_map bit(1) unaligned, /* (34) */ 5 129 2 no_optimize bit(1) unaligned, /* (35) */ 5 130 2 no_check_multiply bit(1) unaligned, /* (36) */ 5 131 2 no_debug_io bit(1) unal, /* (1) Second Word */ 5 132 2 no_stringrange bit(1) unaligned, /* (2) */ 5 133 2 no_subscriptrange bit(1) unaligned, /* (3) */ 5 134 2 no_table bit(1) unaligned, /* (4) */ 5 135 2 no_very_large_array bit(1) unaligned, /* (5) */ 5 136 2 no_vla_parm bit(1) unaligned, /* (6) */ 5 137 2 no_version bit(1) unaligned, /* (7) */ 5 138 2 non_relocatable bit(1) unaligned, /* (8) */ 5 139 2 optimize bit(1) unaligned, /* (9) */ 5 140 2 profile bit(1) unaligned, /* (10) */ 5 141 2 relocatable bit(1) unaligned, /* (11) */ 5 142 2 round bit(1) unaligned, /* (12) */ 5 143 2 safe_optimize bit(1) unaligned, /* (13) */ 5 144 2 severity fixed bin(3) unaligned, /* (14-16) */ 5 145 2 static bit(1) unaligned, /* (17) */ 5 146 2 stringrange bit(1) unaligned, /* (18) */ 5 147 2 subscriptrange bit(1) unaligned, /* (19) */ 5 148 2 table bit(1) unaligned, /* (20) */ 5 149 2 time bit(1) unaligned, /* (21) */ 5 150 2 time_ot bit(1) unaligned, /* (22) */ 5 151 2 top_down bit(1) unaligned, /* (23) */ 5 152 2 truncate bit(1) unaligned, /* (24) */ 5 153 2 version bit(1) unaligned, /* (25) */ 5 154 2 very_large_array bit(1) unaligned, /* (26) */ 5 155 2 very_large_common bit(1) unaligned, /* (27) */ 5 156 2 vla_auto bit(1) unaligned, /* (28) */ 5 157 2 vla_parm bit(1) unaligned, /* (29) */ 5 158 2 vla_static bit(1) unaligned, /* (30) */ 5 159 2 pad bit(6) unaligned; /* (31-36) */ 5 160 5 161 5 162 declare /* Options used by DFAST */ 5 163 5 164 dfast_mask bit (72) internal static options (constant) initial ("100110000000000010100000000011"b); 5 165 /* use_library, has_line_numbers, fold, subscriptrange, brief_table */ 5 166 5 167 5 168 declare /* Options used by FAST */ 5 169 5 170 fast_mask bit (72) internal static options (constant) initial ("000100000000000010100000000011"b); 5 171 /* has_line_numbers, subscriptrange, brief_table */ 5 172 5 173 /* END INCLUDE FILE fort_options.incl.pl1 */ 56 57 58 dcl 1 cg_globals structure aligned based (cg_struc_ptr), 6 1 6 2 /* BEGIN fort_cg_vars.incl.pl1 */ 6 3 6 4 /* Created: June 1976 6 5* 6 6* Modified: 6 7* 9 December 1976, David Levin - change version_name to ext static 6 8* 10 September 1976, David Levin - to add date time compiled, user id, options,version, and compiler name 6 9* 6 June 1978, Richard Barnes - for loop optimizer 6 10* 9 Oct 1978, Paul E. Smee - changes for larger common and arrays. 6 11* 30 Nov 1978, Paul E. Smee - add fort_version_info$version_number*/ 6 12 6 13 2 num_of_lib_names fixed bin(17), 6 14 2 first_lib_name fixed bin (18) unsigned, 6 15 2 last_lib_name fixed bin (18) unsigned, 6 16 6 17 2 error_level fixed bin(17), 6 18 6 19 2 message_structure structure aligned, 6 20 3 message_number fixed bin (18), 6 21 3 number_of_operands fixed bin, 6 22 3 operands(3), 6 23 4 is_string bit(1) aligned, 6 24 4 operand_index fixed bin (18), 6 25 4 string_length fixed bin, 6 26 4 string_ptr ptr, 6 27 6 28 2 print_message_op entry variable, 6 29 2 create_constant_block entry(ptr,fixed bin) returns(fixed bin (18) unsigned) 6 30 variable, 6 31 2 date_time_compiled fixed bin(71), 6 32 2 objectname char(32) varying, 6 33 2 vuser_id char(32) varying, 6 34 2 options_string char(256) varying; 6 35 6 36 dcl fort_version_info$version_name char(132) varying ext static; 6 37 dcl fort_version_info$version_number char(16) ext static; 6 38 6 39 dcl compiler_name char(8) int static options(constant) init("fortran2"); 6 40 6 41 /* END fort_cg_vars.incl.pl1 */ 59 60 61 dcl 1 symtab_parameters structure aligned, 7 1 /* BEGIN INCLUDE FILE fort_symtab_parms.incl.pl1 7 2* 7 3* Read only parameters passed to fort_symbol_table which describe the 7 4* partially built object segment. 7 5* 7 6*Written: 23 August 1979 by C R Davis 7 7**/ 7 8 7 9 2 link_base_ptr pointer, 7 10 2 link_reloc_base_ptr pointer, 7 11 2 def_reloc_base_ptr pointer, 7 12 2 current_text_offset fixed binary (18), 7 13 2 current_def_offset fixed binary (18), 7 14 2 current_link_offset fixed binary (18), 7 15 2 final_text_offset fixed binary (18), 7 16 2 profile_offset fixed binary (18), 7 17 2 star_symbol_link fixed binary (18), 7 18 2 first_namelist_symbol fixed binary (18); 7 19 7 20 /* END INCLUDE FILE fort_symtab_parms.incl.pl1 */ 62 8 1 /* BEGIN INCLUDE FILE ... long_profile.incl.pl1 */ 8 2 /* coded December 1, 1976 by Richard A. Barnes */ 8 3 8 4 dcl 1 long_profile_header based aligned, 8 5 2 last_vcpu fixed bin(71), /* last virtual cpu reading */ 8 6 2 last_pf fixed bin, /* last page faults reading */ 8 7 2 last_offset fixed bin, /* offset of last profile entry metered */ 8 8 2 nentries fixed bin, /* number of profile entries */ 8 9 2 dummy like long_profile_entry aligned, /* dummy profile entry */ 8 10 2 control like long_profile_entry aligned; /* control profile entry for overhead calc */ 8 11 8 12 dcl 1 long_profile_entry based aligned, 8 13 2 map bit(18) unaligned, /* rel ptr to statement map entry */ 8 14 2 skip bit(18) unaligned, 8 15 2 count fixed bin, /* number of times stmt encountered */ 8 16 2 vcpu fixed bin, /* total execution time for this statement */ 8 17 2 pf fixed bin; /* total page faults for this statement */ 8 18 8 19 dcl (dummy_entry_offset init(5), /* offset in long_profile_header of dummy */ 8 20 control_entry_offset init(9)) /* offset in long_profile_header of control */ 8 21 fixed bin int static options(constant); 8 22 8 23 /* END INCLUDE FILE ... long_profile.incl.pl1 */ 63 64 65 dcl fort_make_symbol_section entry (ptr, ptr, ptr, fixed bin (18), fixed bin (18)); 66 67 68 shared_struc_ptr = p1; 69 cg_struc_ptr = p2; 70 object_max_len = shared_globals.object_max_len; 71 operand_max_len = shared_globals.operand_max_len; 72 polish_max_len = shared_globals.polish_max_len; 73 74 75 object_base = shared_globals.object_base; 76 operand_base = shared_globals.operand_base; 77 polish_base = shared_globals.polish_base; 78 relocation_base = shared_globals.relocation_base; 79 80 81 call code_generator; 82 9 1 /* BEGIN fort_utilities.incl.pl1 */ 9 2 9 3 /* Created: October 1977, Richard Barnes 9 4* 9 5* Modified: 9 6* 22 May 1978, DSL - add create_constant. 9 7* 09 Oct 1978, PES - make create_(constant node) return fixed bin(18) unsigned. 9 8* 13 Dec 1978, PES - Get create_node from include file, rather than copy. 9 9**/ 9 10 10 1 /* BEGIN fort_create_node.incl.pl1 */ 10 2 10 3 /* Created: October 1977, Richard Barnes 10 4* 10 5* Modified: 10 6* 22 May 1978, DSL - add create_constant. 10 7* 09 Oct 1978, PES - make create_(constant node) return fixed bin(18) unsigned. 10 8* 13 Dec 1978, PES - changes for large common and arrays. 10 9**/ 10 10 create_node: proc(type,length) returns(fixed bin (18)); 10 11 10 12 dcl length fixed bin; 10 13 dcl offset fixed bin(18); 10 14 dcl type fixed bin(4); 10 15 dcl storage(length) fixed bin aligned based; 10 16 dcl x(0:operand_max_len-1) fixed bin(35) aligned based(operand_base); 10 17 dcl (addr,char,ltrim,unspec) builtin; 10 18 10 19 10 20 if (length + next_free_operand) < operand_max_len 10 21 then do; 10 22 offset = next_free_operand; 10 23 next_free_operand = next_free_operand + length; 10 24 unspec(addr(x(offset)) -> storage) = "0"b; 10 25 addr(x(offset)) -> node.node_type = type; 10 26 return(offset); 10 27 end; 10 28 else do; 10 29 call print_message(407, "operand region", ltrim(char(operand_max_len))); /* FATAL */ 10 30 end; 10 31 10 32 end create_node; 10 33 10 34 /* END fort_create_node.incl.pl1 */ 9 11 9 12 9 13 create_constant: proc(data_type,value) returns(fixed bin (18)); 9 14 9 15 dcl (data_type,a_data_type) fixed bin(4); /* data type of constant */ 9 16 dcl (value,a_value) bit(72) aligned; /* value of constant */ 9 17 9 18 dcl addr builtin; 9 19 dcl binary builtin; 9 20 dcl bool builtin; 9 21 dcl char builtin; 9 22 dcl data_size fixed bin(17); 9 23 dcl decimal builtin; 9 24 dcl hash_index fixed bin; 9 25 dcl hash_table(0:hash_table_size-1) fixed bin(35) aligned based(operand_base); 9 26 dcl hash_table_size fixed bin int static options(constant) init(211); 9 27 dcl hbound builtin; 9 28 dcl ltrim builtin; 9 29 dcl mod builtin; 9 30 dcl mod_2_sum bit(36) aligned; 9 31 dcl node_offset fixed bin; 9 32 dcl node_ptr pointer; 9 33 dcl size builtin; 9 34 dcl v_array(2) bit(36) aligned based(addr(a_value)); 9 35 dcl x(0:operand_max_len-1) fixed bin(35) aligned based(operand_base); 9 36 11 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 11 2 11 3 /* This include file defines the relocation bits as bit (6) entities. See 11 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 11 5 11 6 dcl ( rc_a initial("000000"b), /* absolute */ 11 7 rc_t initial("010000"b), /* text */ 11 8 rc_nt initial("010001"b), /* negative text */ 11 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 11 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 11 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 11 12 rc_dp initial("010101"b), /* def section */ 11 13 rc_s initial("010110"b), /* symbol segment */ 11 14 rc_ns initial("010111"b), /* negative symbol */ 11 15 rc_is18 initial("011000"b), /* internal static 18 */ 11 16 rc_is15 initial("011001"b), /* internal static 15 */ 11 17 rc_lb initial("011000"b), /* link block */ 11 18 rc_nlb initial("011001"b), /* negative link block */ 11 19 rc_sr initial("011010"b), /* self relative */ 11 20 rc_e initial("011111"b)) /* escape */ 11 21 bit(6) int static options(constant); 11 22 11 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 9 37 9 38 9 39 9 40 a_data_type = data_type; 9 41 a_value = value; 9 42 9 43 if a_data_type = char_mode | a_data_type <= 0 | a_data_type > hbound(data_type_size,1) 9 44 then do; 9 45 call print_message(452, ltrim(char(decimal(a_data_type,12)))); /* cannot create the node */ 9 46 end; 9 47 else data_size = data_type_size(a_data_type); 9 48 9 49 if data_size = 1 9 50 then do; 9 51 mod_2_sum = v_array(1); 9 52 v_array(2) = "0"b; 9 53 end; 9 54 else mod_2_sum = bool(v_array(1),v_array(2),"0110"b); 9 55 9 56 9 57 hash_index = mod(binary(mod_2_sum,35),hash_table_size); 9 58 9 59 /* Search the hash table for the constant. */ 9 60 9 61 node_offset = hash_table(hash_index); 9 62 do while(node_offset > 0); /* search the entire bucket */ 9 63 node_ptr = addr(x(node_offset)); 9 64 9 65 if node_ptr -> constant.value = a_value /* must be same value */ 9 66 then if node_ptr -> node.data_type = a_data_type /* and same data type */ 9 67 then return(node_offset); 9 68 9 69 node_offset = node_ptr -> node.hash_chain; /* NB - pointer remains pointing at last item in bucket */ 9 70 end; 9 71 9 72 /* a new constant node must be created */ 9 73 9 74 node_offset = create_node(constant_node, size(constant)); 9 75 9 76 if hash_table(hash_index) = 0 /* Is this the first item in the bucket? */ 9 77 then hash_table(hash_index) = node_offset; /* yes */ 9 78 else node_ptr -> node.hash_chain = node_offset; /* no, add it to the end */ 9 79 9 80 node_ptr = addr(x(node_offset)); 9 81 node_ptr -> constant.data_type = a_data_type; 9 82 node_ptr -> constant.operand_type = constant_type; 9 83 node_ptr -> constant.is_addressable = "1"b; 9 84 node_ptr -> constant.reloc = rc_t; 9 85 node_ptr -> constant.value = a_value; 9 86 9 87 constant_info(data_size).constant_count = constant_info(data_size).constant_count + 1; 9 88 9 89 if constant_info(data_size).first_constant = 0 /* Is this the first item of this size? */ 9 90 then constant_info(data_size).first_constant = node_offset; /* yes */ 9 91 else addr(x(constant_info(data_size).last_constant)) -> constant.next_constant = node_offset; /* no, add it */ 9 92 9 93 constant_info(data_size).last_constant = node_offset; 9 94 9 95 return(node_offset); 9 96 9 97 end create_constant; 9 98 9 99 /* END fort_utilities.incl.pl1 */ 83 84 85 code_generator: 86 procedure (); 87 88 /****^ Written: 1 February 1976 by Richard A. Barnes 89* 90*Modified: 31 Mar 90, SH - 508: Avoid inserting an instruction in the middle of 91* the scm arg sequence for Index intrinsic when pr 4 is valid. 92* Also remove "restore_prs", "lock_base", "lock_index". 93*Modified: 13 Dec 87, SH - 504: Change the relocation factor for the VLA common 94* block members from "internal_static_15" to "absolute". 95*Modified: 16 Oct 86, AG - 502a: Change make_symbol_descriptor so it always 96* generates correctly formatted char (*) descriptors. Change 97* make_entry_descriptor so it never "adjusts" incorrectly formatted 98* char (*) descriptors. Change get_param_char_size so that it always 99* expects correctly formatted char (*) descriptors. 100*Modified: 22 Sep 86, AG - 502: Set descriptor size field to "1"b only for 101* character *(*) variables in make_entry_descriptor. 102*Modified: 22 Sep 86, AG - 496a: Oops -- forgot that array symbols can 103* be accessed directly in "call" statements. Explicitly check 104* for symbol.dimensioned when restoring symbol.address.offset. 105*Modified: 04 Sep 86, AG - 496: For non-array symbols in very large common, 106* use symbol.addr_hold instead of symbol.address.offset to hold the 107* offset in the linkage section of the pointer to the symbol. Too 108* much code counts on symbol.address.offset holding the offset from 109* the pointer of the symbol (always 0). Also made create_storage_entry 110* save info in a_name about symbols used in create_entry structures. 111*Modified: 08 Jul 86, AG - 449.a: Use "anq/stq" instructions rather than "orsq" 112* to update length field in character* (*) dummy arg descriptors. 113*Modified: 19 Feb 86, BW & AG - 473.a: Flag error if passing VLA type arguments 114* to non-VLA type arguments in the same compilation unit. 115*Modified: 11 Dec 85, SH - 425: Passing hollerith (i.e. character) constant 116* data types as arguments to other data types will no longer 117* produce error 401 (inconsistent argument types). 118*Modified: 07 Nov 85, SH & MM - 476: Reduce severity of a compile time 119* subscript error (422) from severity 3 to a warning. 120*Modified: 29 Oct 85, BW - 411: Make sure common block units are the same when 121* comparing maximum lengths. 122*Modified: 08 Aug 85, BW - 430: Prevent emission of deallocation code for auto- 123* matic LA's and VLA's when they don't exist in the compilation unit. 124*Modified: 02 Aug 85, BW - 463: Remove code for action (56) since the macros 125* no longer require this action after the bug fix. 126*Modified: 21 May 85, BW - 455: Ensure auto ptrs to parameters are allocated 127* on even word boundaries. 128*Modified: 24 Apr 85, MM - 449: Create the routine 'make_entry_descriptor' as 129* 'make_symbol_descriptor' can't be used by the code that makes 130* entrys. 131*Modified: 22 Jan 85, MM - 447: Fix base_man_load_any_pr to set the bit 132* address_in_base for VLA elements and allow the base_regs 133* structure to retain the knowledge that it points to a VLA element. 134*Modified: 19 Oct 84, MM - 443: Fix list_init_ array initialization. 135*Modified: 22 Aug 84, HH - 439: 'make_symbol_descriptor' sets lower bound to 136* -2**35 if lower bound is constant but upper bound is not. 137*Modified: 22 Jun 84, MM - Install typeless functions support. 138*Modified: 09 Apr 84, MM - 417: character elements are incorrectly assumed to 139* be word aligned in ansi77 mode if lower bound of array is 0. 140*Modified: 04 Apr 84, HH - 416: 'add' and 'sub' need to support -ve constants. 141*Modified: 28 Mar 84, MM - Install HFP support. 142*Modified: 13 Mar 84, HH - 415: Incorrect relocation information generated for 143* entry point declarations. 144*Modified: 26 Jan 84, TO: 414 - Fix bug in char(*) sizing introduced by entry 145* definition code. We need to emit an extra constant word for char(*) 146* descriptors, rather than mangle the real word that ORQ will refer to. 147*Modified: 19 Sep 83, RG & MM - 242/370: To look up entry-defined arg_desc if one exists. 148*Modified: 27 Jul 83, HH - 371: 'mult' needs to support -ve constants. 149*Modified: 17 June 83, HH - 383: Simplify input to 'check_parameters'. 150*Modified: 8 June 83, TO: 382 - Fix size of entry_info (builtin(8)) to 151* correspond to reality (it is 7 words long). 152* Update documentation of builtin (8). 153*Modified: 8 June 83, TO: 381 - Fix register reservation mask for shorten_stack 154* renamed from reserve_pr1_mask (which reserved pr0 instead) to 155* shorten_stack_mask which reserves pr1, x1. 156*Modified: 14 April 83, RG: 377 - Fix bug in flush_ref which used aliasable 157* instead of in_equiv_stmnt. 158*Modified: 14 April 83, TO - fix 'make_create_entry' to correctly address 159* 'create_entry.next' when setting 't' relocation. 160*Modified: 5 April 83, TO - fix 'check_parameters' to ensure parameter is 161* a symbol and not a return constant. 162*Modified: 5 April 83, TO - fix list_template_init of common bugs. 163*Modified: 5 April 83, TO - fix 'allocate', 'free' bug in VLA common 164* cleanup, have cleanup done by common cleanup routine. Chain headers 165* were being free'd twice, and cleanup during processing was 166* inconsistent. 167*Modified: 31 March 1983, TO: 374 - Fix bug in large_address array_ref in 168* finish_subscript, make_substring in which the constant offset of the 169* array_ref backs up before the 16K bound, leaving array_ref base wrong 170* and large_address flag off preventing re-calc of base in 171* m_a_check_large_address. 172*Modified: 31 Jan 83, TO & HH: Install LA/VLA support. 173*Modified: 10 January 1982, TO - Add 'emit_entry_def (simple (56)) operation 174* from macros to create an entry definition entry. Added code to 175* gen_entry_defs to copy text position of definition to table. Added 176* code to 'check_parameters' (simple (15)) to fill in descriptors. 177*Modified: 3 January 1982, TO - Add 'force_even' operation from macros to 178* emit 'nop' to align to an even word boundary to permit DO-loop 179* optimization. 180*Modified: 31 December 1982, TO: 367 - Cause allocation of named constants if 181* we want a symbol_table. 182*Modified: 17 December 1982, TO - Add '-long_profile' support. 183*Modified: 17 Nov 82, HH - 361: Incorrect code was generated for an ASSIGN 184* to a format which the parser had made into a named constant if 185* there was no reference to the format before the ASSIGN, because 186* the code supporting the 'get_format_var' macro did not call 187* 'use_input' to replace named constants by their value. Rather 188* than have 'get_format_var' use 'use_input', we have opted for 189* the more general fix of moving the code for 'get_format_var' 190* into 'use_input'. 'use_input' was renamed to 'effective_operand' 191* because of its enhanced function. 192*Modified: 30 Sep 1982, TO - 364: Fix 'finish_subscript' bug - first loop did 193* a 'mult' even if we did not have 'vsum', this took an uninitialized 194* value. Also put a constant creation into 'load_vsum' if called 195* without a vsum created. 196*Modified: 05 August 1982, HH - Fix bug 357: Pad char constants with spaces 197* rather than NULs. 198*Modified: 23 July 1982, TO - fix named constant bug in emit_c_a_var where refs 199* to the text section are not seen and fixed up. 200*Modified: 20 May 1982, TO - Fix bug in check_arg_list where 'n' rather than 201* 'num_args' is set to 'a -> arg_desc.n_args ' in limiting the scan 202* of the arg_desc list. This would permit a scan longer than the list. 203*Modified: 18 May 1982, TO - Fix descriptor bug where char*(*) multiplier is 204* only calculated for last dimension, leaving an unprobable, and at 205* times (dims>2) unrunnable binary. 206*Modified: 17 May 1982, TO - Fix probe bug where char*(*) multiplier calculated 207* for descriptor in bits is used for probe runtime_symbol in chars. 208* This causes an extended descriptor to be allocated in the stack and 209* the intermediate character multiplier to be stored in the extended 210* area to be picked up by runtime_symbol.bound(n).multiplier. 211*Modified: 13 May 1982, TO - Fix substr of named_constant, with fix to substr, 212* and emit_eis, have emit_eis do correct text reference. 213*Modified: 9 May 1982, TO - Fix (if unless)_negative to know about other than 214* integer. 215*Modified: 7 May 1982, TO - Fix use of EAQ register and use_ind. 216* previously use_ind used and reset A, but didn't consider those things 217* in EAQ, which subsiquently got lost and not stored. 218*Modified: 3 May 1982, TO - Allocate char_star_function return_value. 219*Modified: 3 May 1982, TO - Add action (74) (if unless)_char_star_function. 220*Modified: 3 May 1982, TO - Add action (75) (if unless)_check_multiply. 221*Modified: 28 April 1982, TO - fix navytest3 bug. Cause flush_ref to remove 222* ALL equivalenced refs in this chain. 223*Modified: 19 April 1982, TO - Implement NAMED CONSTANTS. 224*Modified: 14 April 1982, TO - Implement extended information for stack and 225* linkage overflow message (error 414). 226*Modified: 12 April 1982, TO - fix bug 344, stack indirect through ITP in 227* set_itp_addr. 228*Modified: 4 September 1981, CRD - Change reset_regs to call flush_xr. 229*Modified: 27 July 1981, CRD - Implement get_format_var macro. 230*Modified: 2 June 1981, CRD - Implement push_sf_arg_count macro. 231*Modified: 21 May 1981, CRD - Reorganize subscript range checking. 232*Modified: 12 May 1981, CRD - Add equiv_op, not_equiv_op. 233*Modified: 23 April 1981, CRD - Fix bug 319. 234*Modified: 20 April 1981, CRD - Fix bug 316. 235*Modified: 19 March 1981, CRD - Fix bug 311. 236*Modified: 13 March 1981, CRD - Implement assumed size arrays. 237*Modified: 27 February 1981, CRD - Implement array lower bounds ^= 1. 238*Modified: 8 January 1981, CRD - Fix bug 303. 239*Modified: 9 December 1980, CRD - Changed upper bound of 240* operator_table array to 102 for block_if, else_if, and 241* else operators. 242*Modified: 20 November 1980, CRD - Fix bug in which star extent arrays 243* did not have their virtual_origin and array_size symbols 244* set properly unless the first dimension was variable. 245* Also fixed bug in which an attempt to use an ITP argument 246* list was made when passing descriptors. 247*Modified: 10 October 1980, CRD - Fixed bug in use_eaq which caused 248* temporaries to be stored into the wrong address when more 249* than one item was in the register. 250*Modified: 6 October 1980, CRD - Changes mandated by audit. Also 251* move symbol names of instructions in the single_inst table 252* to the include file fort_single_inst_names.incl.pl1. 253*Modified: 26 September 1980, CRD - Add pointer register 1 to the pool 254* of registers available for addressing, etc. 255*Modified: 24 September 1980, CRD - Change desc_ptr_in_base to be a 256* simple macro (desc_ptr_in_pr3), and add arg_ptr_in_pr1. 257*Modified: 1 September 1980, CRD - Use array_ref.has_address instead 258* of ext_base, to correspond with optimizing CG. 259*Modified: 15 August 1980, CRD - Fix large address bug in 260* continue_cat. 261*Modified: 13 August 1980, CRD - Fix error handling in make_substring. 262*Modified: 12 August 1980, CRD - Fix bug in (if unless)_ansi77. 263*Modified: 16 July 1980, CRD - Add (if unless)_variable_arglist macro. 264*Modified: 15 July 1980, CRD - Changes for generating descriptors 265* on calls - copy needs_descriptors bit from entry_point 266* symbol to external symbol in assign_storage, and add 267* set_needs_descriptors macro. 268*Modified: 27 June 1980, CRD - Fix bug in push_length macro - it was 269* not bumping the ref count of temporaries. 270*Modified: 23 June 1980, CRD - Add (if unless)_ansi77. 271*Modified: 15 May 1980, CRD - Fix bug in make_substring: if variable 272* length temporary already existed, increment its ref count; 273* and make sure the variable length of an array_ref is never 274* another array_ref. 275*Modified: 8 April 1980, CRD - Add code to recycle temporary nodes 276* from one subprogram to another; centralize subprogram 277* initialization in start_subprogram. 278*Modified: 4 April 1980, CRD - Fix bug intorduced by new EAQ mgt. 279* Changed load to call use_ind in all cases except when 280* loading into the indicators. 281*Modified: 7 March 1980, CRD - Implement concatenation. Changes 282* node.multi_position to node.stack_indirect. 283*Modified: 7 February 1980, CRD - Add char1_to_int, int_to_char1 284* macros, fix text_ref to work with char constants, and 285* change the return macro to convert counts to integers. 286*Modified: 5 February 1980, CRD - Add (if unless)_aligned macro, and 287* change text_ref to handle direct EIS operands. 288*Modified: 29 January 1980, CRD - Add support for substrings. 289*Modified: 24 January 1980, CRD - Add support for Fortran entries 290* which require descriptors. 291*Modified: 17 January 1980, CRD - split make_descriptor into two 292* routines: make_descriptor and make_symbol_descriptor. 293*Modified: 17 December 1979, CRD - completion of changes for 294* variable length character strings. 295*Modified: 12 December 1979, CRD - phase 1 of changes to allow 296* variable length character strings (make_descriptor). 297*Modified: 11 December 1979, CRD - change subscripting code to agree 298* with new large address scheme, and fix it to load large 299* offsets correctly. 300*Modified: 7 December 1979, CRD - change over to large address scheme 301* used in the optimizing side (pointer registers instead of 302* index registers). 303*Modified: 6 December 1979, CRD - invent emit_temp_store to avoid 304* recursion in eaq_man_load_a_or_q. 305*Modified: 6 November 1979, CRD - change eaq register management and 306* addressing to handle large character offsets. 307*Modified: 24 September 1979, CRD - added code to finish_subscript to 308* handle 77 char mode (character offsets, large offsets). 309*Modified: 20 September 1979, CRD - added code in base_man_load_pr 310* to load addresses of unaligned character strings. 311*Modified: 19 September 1979, CRD - change register reservation to 312* use the logic planned for the register optimizer. 313*Modified: 12 September 1979, CRD - change large address scheme to 314* use full 32K addressing capability of 15 bit offset. 315*Modified: 31 August 1979, CRD - make changes to storage allocator 316* for ANSI 77 character mode. 317*Modified: 28 August 1979, CRD - fix bug 233 (%options round and 318* %options truncate in the same compilation don't work). 319*Modified: 24 August 1979, CRD - fix bug 232, in which descriptors 320* are copied onto the stack incorrectly due to the data_type 321* field of symbols created by the CG not being set. 322*Modified: 23 August 1979, CRD - move code to build runtime symbol 323* table to separate external procedure, fort_make_symbol_table. 324*Modified: 25 July 1979, CRD - rearrange opcodes of some more simple 325* macro instructions. 326*Modified: 24 July 1979, CRD - fix bug 229, in which the parent chain 327* in the runtime symbol table was being built incorrectly. 328*Modified: 23 July 1979, CRD - to compress opcodes for certain pairs 329* of if/unless macro instructions. 330*Modified: 23 July 1979, CRD - to rearrange opcodes for macros which 331* take no arguments or operands to occupy the left half of 332* the instruction word. 333*Modified: 16 July 1979, CRD - to fix bug 225 to make subscripts in the Q work 334* properly. 335*Modified: 17 January 1979, RAB - to speed up reg management by using 336* machine_state.value_in_xr 337*Modified: 6 December 1978, PES - for %options and %global 338*Modified: 4 December 1978, RAB - for option to initialize auto storage to zero 339*Modified: 30 November 1978, PES - Key rounding off of fortran_options. 340*Modified: 18 November 1978, RAB - Centralize control of rounding 341* by use of eaq.rounded. 342*Modified: 25 October 1978, PES - Changes for large common and arrays. 343*Modified: 11 October 1978, RAB - Fix bug 184 in which bad code is 344* produced if an increment causes an address to cross 345* a 16K boundary. Also checks were put in for invalid fields. 346*Modified: 12 Sept 1978, PES - Move PS from static to automatic storage, to fix 347* bug 182 in which fortran_io_ fails in the event of a segment loop, 348* e.g. a subr in segment calls a subr in segment , which in 349* turn calls another subr in segment . 350*Modified: 06 Sept 1978, PES -Fix bug in which a register may not be reloaded 351* before being used as an index, even if the value has been changed in 352* storage. 353*Modified: 27 July 1978, PES - Fix bug in setting of symbol.simple for 354* parameters. 355*Modified: 23 June 1978, DSL - Add emit_c_a_const so that all procs remain quick 356* procs; set symbol.element_size for descriptors (formerly done by 357* storage allocator). 358*Modified: 19 June 1978, DSL - Changes dictated by audit. 359*Modified: 12 June 1978, DSL - Modify for loop optimizer. This includes the 360* renaming of node.subs_in_q to node.dont_update. All nodes were 361* changed. Also, removed all code in storage allocator that assigns a 362* data type or a storage class. 363*Modified: 23 May 1978, DSL - Prepare for loop optimizing code generator; add 364* load_for_test to fix bug 159 in which indicator state is not set 365* correctly. Mark some code as purely version I optimizer, i.e., 366* obsolete. Change action 105 from "also_in_reg" to "compare". 367*Modified: 18 April 1978, DSL - to fix bug 149 in which incorrect code is 368* generated for arrays with large addresses. Also fixed bug 142 in 369* which save_xr protect_indicators destroys the machine state. 370*Modified: 4 January 1978, DSL - Allocate double word character constants on 371* double word boundaries. 372*Modified: 20 December 1977, DSL - Clean up previous fix; add new macros, 373* load_for_test, set_in_storage, pad_char_const_to_word, 374* pad_char_const_to_dw, dt_jump1; fix store macro to allow no_round 375* option. 376*Modified: 4 November 1977, DSL - Use maximum length when allocating common 377* blocks. 378*Modified: 31 October 1977, RAB - Fix bug 129 where large virtual origins get 379* bad code. Also, implement DL modification for negative constants. 380*Modified: 6 October 1977, DSL - Fix bug in subscripting code for the following: 381* array i(3,3),j(3); i(j(l), l) = m(l) 382*Modified: 30 August 1977, DSL - coordinated change with listing generator to 383* mark entry "data" words; base_man_load_pr_value fails to set reloc 384* info and symbol info; multiply macro does not check for product > 385* bias. Fix "load" to set proper ref count for complex vars. 386* NOTE -- in this compilation the value of bias changed from 65536 to 387* 131072. 388*Modified: 21 July 1977, DSL - fix bug in itp list reloc info. 389*Modified: 14 July 1977 by DSL - 1) add new builtin, ps_area_ptr, for open and 390* close; 2) add new macro load_pr_value, to load a pr with the contents 391* of a location; 3) give relocation info for automatic storage template 392* (bug fix). 393*Modified: 5 July 1977 by DSL - 1) fort_system_constants.incl.pl1 change; 394* 2) print message for multiple initialization of a single common 395* block. 3) Change if_ind and unless_ind to always work even if the 396* eaq appears empty, fixing 108. THIS CONFLICTS WITH PUBLISHED 397* DOCUMENTATION !!! 398*Modified: 26 May 1977 by DSL to always generate ERROR operand if an error 399* occurs in a function frame; THIS CHANGE EXACTLY CONFLICTS WITH THE 400* ORIGINAL DOCUMENTATION OF THE MACRO LANGUAGE. Refer to code for 401* action 66 (error) for complete details. 402*Modified: 3 May 1977 by RAB for store macro 403*Modified: 28 April 1977 by DSL - for new fort_system_constants.incl.pl1 404*Modified: 28 March 1977 by DSL for new stmnt label handling; interface with new 405* node formats; recompile because of PL/I bug 1599 (in compile_link for 406* A$B common names). 407*Modified: Feb 1977 by GDC for the optimizer 408*Modified: 31 Jan 1977 by DSL to allow type-3 links for common block names of 409* the form a$. 410*Modified: 9 Dec 1976 by DSL to reference fort_version_info$version_name 411*Modified: 7 Dec 1976 by RAB to fix bugs in make_symbol_table 412*Modified: 22 Nov 1976 by RAB to add -profile 413*Modified: November 1976 by David Levin to add make_symbol_table 414*Modified: 19 Oct 1976 by RAB for ok_lists and runtime symbol table hooks 415*Modified: 14 Oct 1976 by RAB for relocation bits 416*Modified: 7 Oct 1976 by RAB for optional descriptors 417*Modified: 30 Sept 1976 by RAB for object listings and local object, operand, 418* and polish bases 419*Modified: 5 July 1976 by RAB for addrs >= 16K 420* 421*END Modifications */ 422 423 dcl cleanup_body_address fixed bin (18) unsigned; 424 dcl alloc_auto_cleanup bit (1) aligned; 425 426 dcl (c, lib_pt, p) ptr; 427 428 dcl (n, text_pos, link_pos, def_pos, sym_pos, begin_links, linkrel, defrel, symrel, lib_pos, last_pos, profile_start, 429 profile_pos) fixed bin (18); 430 431 dcl (begin_external_list, end_external_list) fixed bin (18); 432 433 dcl begin_forward_refs fixed bin (18); 434 435 dcl (first_namelist, last_namelist) fixed bin (18); 436 dcl (first_header, last_header) ptr init (null ()); /* header chain */ 437 438 dcl (link_base, def_base, lib_list_ptr, a_base, parm_desc_ptrsp) ptr; 439 dcl (link_reloc_base, def_reloc_base, lib_reloc_ptr) ptr; 440 441 dcl (generate_long_profile, generate_profile, generate_symtab, assembly_list, do_rounding, init_auto_to_zero) 442 bit (1) aligned; 443 444 dcl builtins (0:11) fixed bin (18); /* format: off */ 445 /* builtins are: 446* 0: zero integer zero constant 447* 1: one integer one constant 448* 2: ps symbol for fortran I/O arglist 449* 3: auto_template Initialization template for auto storage 450* 4: auto_overlay array reference overlay of automatic storage 451* 5: null_ptr initialized to a null pointer value 452* 6: null value of 0 as a null 453* 7: two integer two constant 454* 8: entry_info place to store quick proc info 455* word 0 - Return address pointer (ITS). 456* word 2 - Argument pointer (ITS). 457* word 4 - Descriptor pointer (ITS). 458* word 6 - Permanent Stack extension value (18-bit offset, 1 word). 459* 9: star_symbol <*symbol>|0 460* 10: ps_area_ptr symbol for ps.buffer_p 461* 11: desc_overlay symbol for accessing a descriptor 462**/ 463 /* format: on */ 464 465 dcl image (amt) fixed bin (18) aligned based; 466 dcl char_image char (4 * amt) aligned based; 467 dcl (zero_def, last_def, seg_def) bit (18) aligned; 468 dcl def_pool (20) fixed bin (18); 469 470 dcl (amt, con, i, j, lib) fixed bin (18); 471 472 dcl rands (0:operand_max_len - 1) fixed bin (18) aligned based (operand_base); 473 474 dcl polish (0:polish_max_len - 1) fixed bin (18) aligned based (polish_base); 475 476 dcl a_name (0:261119 - 2 * (number_of_lines + 1)) fixed bin (18) aligned based (a_base); 477 478 dcl 1 external_list based (polish_base) aligned, 479 2 ext_ref (0:polish_max_len - 1) ptr unal; 480 481 dcl last_auto_loc fixed bin (18); 482 dcl linkage_pad fixed bin (18); /* linkage pad of LA and VLA pointers */ 483 dcl first_auto_var_loc fixed bin (18); 484 dcl free_temps (3) fixed bin (18); 485 dcl auto_template fixed bin (18); 486 487 dcl 1 text_halfs (0:262143) aligned based (object_base), 488 2 left fixed bin (17) unal, 489 2 right fixed bin (17) unal; 490 491 dcl 1 reloc_halfs (0:262143) aligned based (relocation_base), 492 2 left bit (18) unal, 493 2 right bit (18) unal; 494 495 dcl reloc (0:3) bit (36) aligned based; 496 497 dcl 1 forward_refs (0:next_free_polish - 1) based (polish_base) aligned, 498 2 instruction fixed bin (17) unal, 499 2 operand fixed bin (18) unsigned unal; 500 501 dcl vsegname char (32) varying defined (objectname); 502 503 dcl 1 saved_lib_list aligned based (lib_list_ptr), 504 2 nlibs fixed bin (18), 505 2 names (n refer (nlibs)), 506 3 offset bit (18) unal, 507 3 lng fixed bin (17) unal; 508 509 dcl 1 saved_lib_reloc_list aligned based (lib_reloc_ptr), 510 2 mlibs fixed bin (18), 511 2 names (n), 512 3 reloc bit (18) unal, 513 3 pad bit (18) unal; 514 515 dcl 1 parm_desc_ptrs aligned based (parm_desc_ptrsp), 516 2 n_args fixed bin (18) unaligned unsigned, 517 2 descriptor_relp (0 refer (parm_desc_ptrs.n_args)) fixed bin (18) unsigned unaligned; 518 519 520 dcl segname char (32) aligned; 521 522 dcl bases (0:7) bit (3) aligned internal static options (constant) 523 initial ("0"b3, "4"b3, "1"b3, "2"b3, "3"b3, "5"b3, "7"b3, "6"b3); 524 525 dcl ( 526 ap defined (bases (0)), 527 ab defined (bases (2)), 528 bp defined (bases (3)), 529 bb defined (bases (4)), 530 lp defined (bases (1)), 531 lb defined (bases (5)), 532 sp defined (bases (7)), 533 sb defined (bases (6)) 534 ) bit (3) aligned; 535 536 dcl which_base (0:7) fixed binary (3) internal static options (constant) initial (0, 2, 3, 4, 1, 5, 7, 6); 537 538 dcl ( 539 DU_mod initial ("03"b3), 540 DL_mod initial ("07"b3), 541 AL_mod initial ("05"b3), 542 AU_mod initial ("01"b3), 543 QL_mod initial ("06"b3), 544 QU_mod initial ("02"b3), 545 X0_mod initial ("10"b3), 546 X1_mod initial ("11"b3), 547 RI_mod initial ("20"b3), 548 ITP_mod initial ("41"b3), 549 FT2_mod initial ("46"b3) 550 ) bit (6) aligned internal static options (constant); 551 552 dcl 01 descriptor_type_word (0:1, 7) aligned, 553 02 flag bit (1) unaligned init ((14) ("1"b)), 554 02 type fixed bin (6) unsigned unaligned 555 init (ft_integer_dtype, ft_real_dtype, ft_double_dtype, ft_complex_dtype, ft_logical_dtype, ft_char_dtype, 556 ft_external_dtype, ft_integer_dtype, ft_hex_real_dtype, ft_hex_double_dtype, ft_hex_complex_dtype, 557 ft_logical_dtype, ft_char_dtype, ft_external_dtype), 558 02 packed bit (1) unaligned init ((14) ("0"b)), 559 02 number_dims fixed bin (3) unaligned init ((14) 0), 560 02 size fixed bin (23) unaligned init ((2) (35, 27, 63, 27, 1, 0, 0)); 561 dcl fptype fixed bin (1) init (bin (shared_globals.hfp, 1)); 562 563 dcl ext_base_on bit (36) aligned internal static options (constant) initial ("000000000100"b3); 564 565 dcl max_address_offset fixed bin (14) static options (constant) init (16383); 566 dcl max_stack_size fixed bin (18) int static init (62000) options (constant); 567 dcl max_linkage_size fixed binary (18) internal static options (constant) initial (131071); 568 569 dcl (abs, addr, addrel, bin, binary, bit, byte, char, cleanup, copy, 570 currentsize, divide, fixed, hbound, index, ltrim, max, min, mod, null, 571 ptr, rank, rel, reverse, size, string, substr, unspec, verify) builtin; 572 12 1 /* BEGIN INCLUDE FILE linkdcl.incl.pl1 --- last modified 15 Nov 1971 by C Garman */ 12 2 12 3 /* Last Modified (Date and Reason): 12 4* 6/75 by M.Weaver to add virgin_linkage_header declaration 12 5* 6/75 by S.Webber to comment existing structures better 12 6* 9/77 by M. Weaver to add run_depth to link 12 7* 2/83 by M. Weaver to add linkage header flags and change run_depth precision 12 8**/ 12 9 12 10 /* format: style3 */ 12 11 dcl 1 link based aligned, /* link pair in linkage section */ 12 12 2 head_ptr bit (18) unal, /* rel pointer to beginning of linkage section */ 12 13 2 ringno bit (3) unal, 12 14 2 mbz bit (6) unal, 12 15 2 run_depth fixed bin (2) unal, /* run unit depth, filled when link is snapped */ 12 16 2 ft2 bit (6) unal, /* fault tag. 46(8) if not snapped, 43(8) if snapped */ 12 17 2 exp_ptr bit (18) unal, /* pointer (rel to defs) of expression word */ 12 18 2 mbz2 bit (12) unal, 12 19 2 modifier bit (6) unal; /* modifier to be left in snapped link */ 12 20 12 21 dcl 1 exp_word based aligned, /* expression word in link definition */ 12 22 2 type_ptr bit (18) unal, /* pointer (rel to defs) of type pair structure */ 12 23 2 exp bit (18) unal; /* constant expression to be added in when snapping link */ 12 24 12 25 dcl 1 type_pair based aligned, /* type pair in link definition */ 12 26 2 type bit (18) unal, /* type of link. may be 1,2,3,4,5, or 6 */ 12 27 2 trap_ptr bit (18) unal, /* pointer (rel to defs) to the trap word */ 12 28 2 seg_ptr bit (18) unal, /* pointer to ACC reference name for segment referenced */ 12 29 2 ext_ptr bit (18) unal; /* pointer (rel to defs) of ACC segdef name */ 12 30 12 31 dcl 1 header based aligned, /* linkage block header */ 12 32 2 def_ptr ptr, /* pointer to definition section */ 12 33 2 symbol_ptr ptr unal, /* pointer to symbol section in object segment */ 12 34 2 original_linkage_ptr 12 35 ptr unal, /* pointer to linkage section in object segment */ 12 36 2 unused bit (72), 12 37 2 stats, 12 38 3 begin_links bit (18) unal, /* offset (rel to this section) of first link */ 12 39 3 block_length bit (18) unal, /* number of words in this linkage section */ 12 40 3 segment_number 12 41 bit (18) unal, /* text segment number associated with this section */ 12 42 3 static_length bit (18) unal; /* number of words of static for this segment */ 12 43 12 44 dcl 1 linkage_header_flags 12 45 aligned based, /* overlay of def_ptr for flags */ 12 46 2 pad1 bit (28) unaligned, /* flags are in first word */ 12 47 2 static_vlas bit (1) unaligned, /* static section "owns" some LA/VLA segments */ 12 48 2 perprocess_static 12 49 bit (1) unaligned, /* 1 copy of static section is used by all tasks/run units */ 12 50 2 pad2 bit (6) unaligned; 12 51 12 52 dcl 1 virgin_linkage_header 12 53 aligned based, /* template for linkage header in object segment */ 12 54 2 pad bit (30) unaligned, /* is filled in by linker */ 12 55 2 defs_in_link bit (6) unaligned, /* =o20 if defs in linkage (nonstandard) */ 12 56 2 def_offset bit (18) unaligned, /* offset of definition section */ 12 57 2 first_ref_relp bit (18) unaligned, /* offset of trap-at-first-reference offset array */ 12 58 2 filled_in_later bit (144), 12 59 2 link_begin bit (18) unaligned, /* offset of first link */ 12 60 2 linkage_section_lng 12 61 bit (18) unaligned, /* length of linkage section */ 12 62 2 segno_pad bit (18) unaligned, /* will be segment number of copied linkage */ 12 63 2 static_length bit (18) unaligned; /* length of static section */ 12 64 12 65 12 66 dcl 1 trap_word based aligned, /* trap word in link definition */ 12 67 2 call_ptr bit (18) unal, /* pointer (rel to link) of link to trap procedure */ 12 68 2 arg_ptr bit (18) unal; /* pointer (rel to link) of link to arg info for trap proc */ 12 69 12 70 dcl 1 name based aligned, /* storage of ASCII names in definitions */ 12 71 2 nchars bit (9) unaligned, /* number of characters in name */ 12 72 2 char_string char (31) unaligned; /* 31-character name */ 12 73 12 74 /* END INCLUDE FILE linkdcl.incl.pl1 */ 573 13 1 /* BEGIN INCLUDE FILE ... object_map.incl.pl1 */ 13 2 /* coded February 8, 1972 by Michael J. Spier */ 13 3 /* Last modified on 05/20/72 at 13:29:38 by R F Mabee. */ 13 4 /* Made to agree with Spier's document on 20 May 1972 by R F Mabee. */ 13 5 /* modified on 6 May 1972 by R F Mabee to add map_ptr at end of object map. */ 13 6 /* modified May, 1972 by M. Weaver */ 13 7 /* modified 5/75 by E. Wiatrowski and 6/75 by M. Weaver */ 13 8 /* modified 5/77 by M. Weaver to add perprocess_static bit */ 13 9 13 10 declare 1 object_map aligned based, /* Structure describing standard object map */ 13 11 13 12 2 decl_vers fixed bin, /* Version number of current structure format */ 13 13 2 identifier char (8) aligned, /* Must be the constant "obj_map" */ 13 14 2 text_offset bit (18) unaligned, /* Offset relative to base of object segment of base of text section */ 13 15 2 text_length bit (18) unaligned, /* Length in words of text section */ 13 16 2 definition_offset bit (18) unaligned, /* Offset relative to base of object seg of base of definition section */ 13 17 2 definition_length bit (18) unaligned, /* Length in words of definition section */ 13 18 2 linkage_offset bit (18) unaligned, /* Offset relative to base of object seg of base of linkage section */ 13 19 2 linkage_length bit (18) unaligned, /* Length in words of linkage section */ 13 20 2 static_offset bit (18) unaligned, /* Offset relative to base of obj seg of static section */ 13 21 2 static_length bit (18) unaligned, /* Length in words of static section */ 13 22 2 symbol_offset bit (18) unaligned, /* Offset relative to base of object seg of base of symbol section */ 13 23 2 symbol_length bit (18) unaligned, /* Length in words of symbol section */ 13 24 2 break_map_offset bit (18) unaligned, /* Offset relative to base of object seg of base of break map */ 13 25 2 break_map_length bit (18) unaligned, /* Length in words of break map */ 13 26 2 entry_bound bit (18) unaligned, /* Offset in text of last gate entry */ 13 27 2 text_link_offset bit (18) unaligned, /* Offset of first text-embedded link */ 13 28 2 format aligned, /* Word containing bit flags about object type */ 13 29 3 bound bit (1) unaligned, /* On if segment is bound */ 13 30 3 relocatable bit (1) unaligned, /* On if segment has relocation info in its first symbol block */ 13 31 3 procedure bit (1) unaligned, /* On if segment is an executable object program */ 13 32 3 standard bit (1) unaligned, /* On if segment is in standard format (more than just standard map) */ 13 33 3 separate_static bit(1) unaligned, /* On if static is a separate section from linkage */ 13 34 3 links_in_text bit (1) unaligned, /* On if there are text-embedded links */ 13 35 3 perprocess_static bit (1) unaligned, /* On if static is not to be per run unit */ 13 36 3 unused bit (29) unaligned; /* Reserved */ 13 37 13 38 declare map_ptr bit(18) aligned based; /* Last word of the segment. It points to the base of the object map. */ 13 39 13 40 declare object_map_version_2 fixed bin static init(2); 13 41 13 42 /* END INCLUDE FILE ... object_map.incl.pl1 */ 574 14 1 /* BEGIN INCLUDE FILE relbts.incl.pl1 */ 14 2 14 3 /* This include file defines the relocation bits as bit (18) entities. See 14 4* also relocation_bits.incl.pl1 and reloc_lower.incl.pl1. */ 14 5 14 6 dcl ( rc_a initial("0"b), /* absolute */ 14 7 rc_t initial("000000000000010000"b), /* text */ 14 8 rc_nt initial("000000000000010001"b), /* negative text */ 14 9 rc_lp18 initial("000000000000010010"b), /* linkage, 18 bit */ 14 10 rc_nlp18 initial("000000000000010011"b), /* negative link, 18 bit */ 14 11 rc_lp15 initial("000000000000010100"b), /* linkage, 15 bit */ 14 12 rc_dp initial("000000000000010101"b), /* def section */ 14 13 rc_s initial("000000000000010110"b), /* symbol segment */ 14 14 rc_ns initial("000000000000010111"b), /* negative symbol */ 14 15 rc_is18 initial("000000000000011000"b), /* internal static 18 */ 14 16 rc_is15 initial("000000000000011001"b), /* internal static 15 */ 14 17 rc_lb initial("000000000000011000"b), /* link block */ 14 18 rc_nlb initial("000000000000011001"b), /* negative link block */ 14 19 rc_sr initial("000000000000011010"b), /* self relative */ 14 20 rc_e initial("000000000000011111"b)) /* escape */ 14 21 bit(18) internal static options(constant); 14 22 14 23 dcl ( rc_dp_dp initial("000000000000010101000000000000010101"b), /* def section, def section */ 14 24 rc_a_dp initial("000000000000000000000000000000010101"b)) /* absolute, def section */ 14 25 bit(36) internal static options(constant); 14 26 14 27 /* END INCLUDE FILE relbts.incl.pl1 */ 575 15 1 /* BEGIN INCLUDE FILE reloc_lower.incl.pl1 */ 15 2 15 3 /* See relocation_bits.incl.pl1 and relbts.incl.pl1 for other declarations of 15 4* relocation information. */ 15 5 15 6 dcl ( rc_a_lp18 init("000000000000000000000000000000010010"b), 15 7 rc_a_is18 init("000000000000000000000000000000011000"b), 15 8 rc_a_t init("000000000000000000000000000000010000"b)) 15 9 bit(36) aligned int static options(constant); 15 10 15 11 /* END INCLUDE FILE reloc_lower.incl.pl1 */ 576 16 1 /* BEGIN INCLUDE FILE its.incl.pl1 16 2* modified 27 July 79 by JRDavis to add its_unsigned 16 3* Internal format of ITS pointer, including ring-number field for follow-on processor */ 16 4 16 5 dcl 1 its based aligned, /* declaration for ITS type pointer */ 16 6 2 pad1 bit (3) unaligned, 16 7 2 segno bit (15) unaligned, /* segment number within the pointer */ 16 8 2 ringno bit (3) unaligned, /* ring number within the pointer */ 16 9 2 pad2 bit (9) unaligned, 16 10 2 its_mod bit (6) unaligned, /* should be 43(8) */ 16 11 16 12 2 offset bit (18) unaligned, /* word offset within the addressed segment */ 16 13 2 pad3 bit (3) unaligned, 16 14 2 bit_offset bit (6) unaligned, /* bit offset within the word */ 16 15 2 pad4 bit (3) unaligned, 16 16 2 mod bit (6) unaligned; /* further modification */ 16 17 16 18 dcl 1 itp based aligned, /* declaration for ITP type pointer */ 16 19 2 pr_no bit (3) unaligned, /* number of pointer register to use */ 16 20 2 pad1 bit (27) unaligned, 16 21 2 itp_mod bit (6) unaligned, /* should be 41(8) */ 16 22 16 23 2 offset bit (18) unaligned, /* word offset from pointer register word offset */ 16 24 2 pad2 bit (3) unaligned, 16 25 2 bit_offset bit (6) unaligned, /* bit offset relative to new word offset */ 16 26 2 pad3 bit (3) unaligned, 16 27 2 mod bit (6) unaligned; /* further modification */ 16 28 16 29 16 30 dcl 1 its_unsigned based aligned, /* just like its, but with unsigned binary */ 16 31 2 pad1 bit (3) unaligned, 16 32 2 segno fixed bin (15) unsigned unaligned, 16 33 2 ringno fixed bin (3) unsigned unaligned, 16 34 2 pad2 bit (9) unaligned, 16 35 2 its_mod bit (6) unaligned, 16 36 16 37 2 offset fixed bin (18) unsigned unaligned, 16 38 2 pad3 bit (3) unaligned, 16 39 2 bit_offset fixed bin (6) unsigned unaligned, 16 40 2 pad4 bit (3) unaligned, 16 41 2 mod bit (6) unaligned; 16 42 16 43 dcl 1 itp_unsigned based aligned, /* just like itp, but with unsigned binary where appropriate */ 16 44 2 pr_no fixed bin (3) unsigned unaligned, 16 45 2 pad1 bit (27) unaligned, 16 46 2 itp_mod bit (6) unaligned, 16 47 16 48 2 offset fixed bin (18) unsigned unaligned, 16 49 2 pad2 bit (3) unaligned, 16 50 2 bit_offset fixed bin (6) unsigned unaligned, 16 51 2 pad3 bit (3) unaligned, 16 52 2 mod bit (6) unaligned; 16 53 16 54 16 55 dcl ITS_MODIFIER bit (6) unaligned internal static options (constant) init ("43"b3); 16 56 dcl ITP_MODIFIER bit (6) unaligned internal static options (constant) init ("41"b3); 16 57 16 58 /* END INCLUDE FILE its.incl.pl1 */ 577 17 1 /* BEGIN INCLUDE FILE profile_entry.incl.pl1 */ 17 2 17 3 dcl 1 profile_entry aligned based, 17 4 2 map bit(18) unaligned, 17 5 2 skip bit(18) unaligned, 17 6 2 count fixed bin; 17 7 17 8 /* END INCLUDE FILE profile_entry.incl.pl1 */ 578 18 1 /* BEGIN include file fortran_storage.incl.pl1 */ 18 2 18 3 /* Created 82-09-21 by T. Oke (UNCA) */ 18 4 18 5 /* Modification History: 18 6* 18 7*Modified: 1 October 1982, TO - add pointer_count and pointer entries. 18 8*Modified: 9 November 1982, TO - Move pointer_count, add common_link. 18 9**/ 18 10 18 11 /* Definitions of the structures controlling the creation of and initialization 18 12* lists for fortran_storage_driver. */ 18 13 18 14 /* For VLA entries there may be a number of pointers, each of which points to a 18 15* single VLA entity within the VLA. Each such pointer supplies an offset and 18 16* is stored by 'fortran_storage_'. 18 17* 18 18* For VLA COMMON, there is a pointer to the link in the linkage section. The 18 19* unsnapped link (which is in the template linkage section) supplies an offset 18 20* to find the expression_word in the definition section, which offsets to the 18 21* type_pair, which supplies the initialization information. */ 18 22 18 23 dcl 1 create_entry based, /* creation list entry */ 18 24 2 location fixed bin (18) unsigned unaligned, /* location of base */ 18 25 2 flags unaligned structure, 18 26 3 auto bit (1) unaligned, /* automatic storage entry */ 18 27 3 static bit (1) unaligned, /* static storage entry */ 18 28 3 common bit (1) unaligned, /* common storage entry */ 18 29 3 LA bit (1) unaligned, /* Large Array (255K) */ 18 30 3 VLA bit (1) unaligned, /* Very Large Array (>255K) */ 18 31 3 K256 bit (1) unaligned, /* alloc 256K segs */ 18 32 3 init bit (1) unaligned, /* initialized */ 18 33 3 pad bit (2) unaligned, /* FUTURE EXPANSION */ 18 34 3 pointer_count fixed bin (9) unsigned unaligned, /* number of pointers to fill in */ 18 35 2 length fixed bin (24) aligned, /* number of words required */ 18 36 2 next fixed bin (18) unsigned unaligned, /* offset to next create entry */ 18 37 2 name_length fixed bin (17) unaligned, /* size of block name field */ 18 38 2 common_link fixed bin (18) unsigned unaligned, /* location of link if COMMON */ 18 39 18 40 2 block_name char (0 refer (create_entry.name_length)), 18 41 2 pointer_offsets (0 refer (create_entry.pointer_count)) aligned, 18 42 3 pad bit (12) unaligned, 18 43 3 offset fixed bin (24) unsigned unaligned; 18 44 18 45 /* Pointers will be created for each VLA sub-entity, so the pointer_count field 18 46* indicates how many pointers follow the block_name. */ 18 47 18 48 18 49 18 50 18 51 /* Initialization data. The length and datum are bit items, to permit a wide 18 52* range of inputs. 18 53* 18 54* 1. A 'repeat' of '0' signifies skipping of 'length' bits. 18 55* 2. A 'length' of '0' signifies the last item of the list. 18 56* 18 57* COMMON, VLA's, and LA's, are presumed to start at the base pointer of their 18 58* particular storage section. */ 18 59 18 60 18 61 dcl 1 create_init_entry based, 18 62 2 length fixed bin (35) aligned, /* size of datum */ 18 63 2 pad bit (6) unaligned, /* FUTURE EXPANSION */ 18 64 2 repeat fixed bin (30) unsigned unaligned, /* number of times to repeat datum */ 18 65 2 datum bit (0 refer (create_init_entry.length)); 18 66 18 67 18 68 /* END include file fortran_storage.incl.pl1 */ 579 19 1 /* BEGIN INCLUDE FILE ... std_descriptor_types.incl.pl1 */ 19 2 19 3 19 4 /****^ HISTORY COMMENTS: 19 5* 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), 19 6* audit(86-09-11,Martinson), install(86-11-12,MR12.0-1208): 19 7* Added pascal_string_type_dtype descriptor type. Its number is 87. 19 8* Objects of this type are PASCAL string types. 19 9* 2) change(88-09-20,WAAnderson), approve(88-09-20,MCR7952), 19 10* audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184): 19 11* Added the new C types. 19 12* END HISTORY COMMENTS */ 19 13 19 14 /* This include file defines mnemonic names for the Multics 19 15* standard descriptor types, using both pl1 and cobol terminology. 19 16* PG 780613 19 17* JRD 790530 19 18* JRD 791016 19 19* MBW 810731 19 20* TGO 830614 Add hex types. 19 21* Modified June 83 JMAthane to add PASCAL data types 19 22* TGO 840120 Add float dec extended and generic, float binary generic 19 23**/ 19 24 19 25 dcl (real_fix_bin_1_dtype init (1), 19 26 real_fix_bin_2_dtype init (2), 19 27 real_flt_bin_1_dtype init (3), 19 28 real_flt_bin_2_dtype init (4), 19 29 cplx_fix_bin_1_dtype init (5), 19 30 cplx_fix_bin_2_dtype init (6), 19 31 cplx_flt_bin_1_dtype init (7), 19 32 cplx_flt_bin_2_dtype init (8), 19 33 real_fix_dec_9bit_ls_dtype init (9), 19 34 real_flt_dec_9bit_dtype init (10), 19 35 cplx_fix_dec_9bit_ls_dtype init (11), 19 36 cplx_flt_dec_9bit_dtype init (12), 19 37 pointer_dtype init (13), 19 38 offset_dtype init (14), 19 39 label_dtype init (15), 19 40 entry_dtype init (16), 19 41 structure_dtype init (17), 19 42 area_dtype init (18), 19 43 bit_dtype init (19), 19 44 varying_bit_dtype init (20), 19 45 char_dtype init (21), 19 46 varying_char_dtype init (22), 19 47 file_dtype init (23), 19 48 real_fix_dec_9bit_ls_overp_dtype init (29), 19 49 real_fix_dec_9bit_ts_overp_dtype init (30), 19 50 real_fix_bin_1_uns_dtype init (33), 19 51 real_fix_bin_2_uns_dtype init (34), 19 52 real_fix_dec_9bit_uns_dtype init (35), 19 53 real_fix_dec_9bit_ts_dtype init (36), 19 54 real_fix_dec_4bit_uns_dtype init (38), /* digit-aligned */ 19 55 real_fix_dec_4bit_ts_dtype init (39), /* byte-aligned */ 19 56 real_fix_dec_4bit_bytealigned_uns_dtype init (40), /* COBOL */ 19 57 real_fix_dec_4bit_ls_dtype init (41), /* digit-aligned */ 19 58 real_flt_dec_4bit_dtype init (42), /* digit-aligned */ 19 59 real_fix_dec_4bit_bytealigned_ls_dtype init (43), 19 60 real_flt_dec_4bit_bytealigned_dtype init (44), 19 61 cplx_fix_dec_4bit_bytealigned_ls_dtype init (45), 19 62 cplx_flt_dec_4bit_bytealigned_dtype init (46), 19 63 real_flt_hex_1_dtype init (47), 19 64 real_flt_hex_2_dtype init (48), 19 65 cplx_flt_hex_1_dtype init (49), 19 66 cplx_flt_hex_2_dtype init (50), 19 67 c_typeref_dtype init (54), 19 68 c_enum_dtype init (55), 19 69 c_enum_const_dtype init (56), 19 70 c_union_dtype init (57), 19 71 algol68_straight_dtype init (59), 19 72 algol68_format_dtype init (60), 19 73 algol68_array_descriptor_dtype init (61), 19 74 algol68_union_dtype init (62), 19 75 19 76 cobol_comp_6_dtype init (1), 19 77 cobol_comp_7_dtype init (1), 19 78 cobol_display_ls_dtype init (9), 19 79 cobol_structure_dtype init (17), 19 80 cobol_char_string_dtype init (21), 19 81 cobol_display_ls_overp_dtype init (29), 19 82 cobol_display_ts_overp_dtype init (30), 19 83 cobol_display_uns_dtype init (35), 19 84 cobol_display_ts_dtype init (36), 19 85 cobol_comp_8_uns_dtype init (38), /* digit aligned */ 19 86 cobol_comp_5_ts_dtype init (39), /* byte aligned */ 19 87 cobol_comp_5_uns_dtype init (40), 19 88 cobol_comp_8_ls_dtype init (41), /* digit aligned */ 19 89 real_flt_dec_extended_dtype init (81), /* 9-bit exponent */ 19 90 cplx_flt_dec_extended_dtype init (82), /* 9-bit exponent */ 19 91 real_flt_dec_generic_dtype init (83), /* generic float decimal */ 19 92 cplx_flt_dec_generic_dtype init (84), 19 93 real_flt_bin_generic_dtype init (85), /* generic float binary */ 19 94 cplx_flt_bin_generic_dtype init (86)) fixed bin internal static options (constant); 19 95 19 96 dcl (ft_integer_dtype init (1), 19 97 ft_real_dtype init (3), 19 98 ft_double_dtype init (4), 19 99 ft_complex_dtype init (7), 19 100 ft_complex_double_dtype init (8), 19 101 ft_external_dtype init (16), 19 102 ft_logical_dtype init (19), 19 103 ft_char_dtype init (21), 19 104 ft_hex_real_dtype init (47), 19 105 ft_hex_double_dtype init (48), 19 106 ft_hex_complex_dtype init (49), 19 107 ft_hex_complex_double_dtype init (50) 19 108 ) fixed bin internal static options (constant); 19 109 19 110 dcl (algol68_short_int_dtype init (1), 19 111 algol68_int_dtype init (1), 19 112 algol68_long_int_dtype init (2), 19 113 algol68_real_dtype init (3), 19 114 algol68_long_real_dtype init (4), 19 115 algol68_compl_dtype init (7), 19 116 algol68_long_compl_dtype init (8), 19 117 algol68_bits_dtype init (19), 19 118 algol68_bool_dtype init (19), 19 119 algol68_char_dtype init (21), 19 120 algol68_byte_dtype init (21), 19 121 algol68_struct_struct_char_dtype init (22), 19 122 algol68_struct_struct_bool_dtype init (20) 19 123 ) fixed bin internal static options (constant); 19 124 19 125 dcl (label_constant_runtime_dtype init (24), 19 126 int_entry_runtime_dtype init (25), 19 127 ext_entry_runtime_dtype init (26), 19 128 ext_procedure_runtime_dtype init (27), 19 129 picture_runtime_dtype init (63) 19 130 ) fixed bin internal static options (constant); 19 131 19 132 dcl (pascal_integer_dtype init (1), 19 133 pascal_real_dtype init (4), 19 134 pascal_label_dtype init (24), 19 135 pascal_internal_procedure_dtype init (25), 19 136 pascal_exportable_procedure_dtype init (26), 19 137 pascal_imported_procedure_dtype init (27), 19 138 pascal_typed_pointer_type_dtype init (64), 19 139 pascal_char_dtype init (65), 19 140 pascal_boolean_dtype init (66), 19 141 pascal_record_file_type_dtype init (67), 19 142 pascal_record_type_dtype init (68), 19 143 pascal_set_dtype init (69), 19 144 pascal_enumerated_type_dtype init (70), 19 145 pascal_enumerated_type_element_dtype init (71), 19 146 pascal_enumerated_type_instance_dtype init (72), 19 147 pascal_user_defined_type_dtype init (73), 19 148 pascal_user_defined_type_instance_dtype init (74), 19 149 pascal_text_file_dtype init (75), 19 150 pascal_procedure_type_dtype init (76), 19 151 pascal_variable_formal_parameter_dtype init (77), 19 152 pascal_value_formal_parameter_dtype init (78), 19 153 pascal_entry_formal_parameter_dtype init (79), 19 154 pascal_parameter_procedure_dtype init (80), 19 155 pascal_string_type_dtype init (87)) fixed bin int static options (constant); 19 156 19 157 19 158 /* END INCLUDE FILE ... std_descriptor_types.incl.pl1 */ 580 581 582 /* initialize */ 583 584 cur_statement = -1; /* no active statement node */ 585 allocate_symbol_name = 0; /* no names for symbols created by code generator */ 586 unspec (def_pool) = "0"b; 587 text_pos, link_pos, def_pos, sym_pos, lib_pos, profile_start = 0; 588 first_namelist, last_namelist = 0; 589 free_temps (1), free_temps (2), free_temps (3) = 0; 590 segname = vsegname; 591 592 assembly_list = shared_globals.options.list; 593 if assembly_list 594 then a_base = addr (source_list (number_of_lines + 2)); 595 else a_base = null; 596 597 /* allocate all constants passed as arg */ 598 599 call alloc_constants (first_dw_constant, 2); 600 call alloc_constants (first_word_constant, 1); 601 call alloc_char_constants (first_char_constant); 602 603 /* allocate storage */ 604 605 begin_external_list = next_free_polish; 606 607 call assign_storage; 608 609 /* set up for interpreting */ 610 611 end_external_list, begin_forward_refs = next_free_polish; 612 613 /* interpret */ 614 615 call interpreter; 616 617 last_pos = text_pos; 618 619 /* allocate all constants that need storage */ 620 621 text_pos = text_pos + mod (text_pos, 2); 622 623 call alloc_char_constants (first_block_constant); 624 call alloc_constants (first_dw_constant, 2); 625 call alloc_constants (first_word_constant, 1); 626 call alloc_char_constants (first_char_constant); 627 628 /* resolve all forward references */ 629 630 do i = begin_forward_refs to hbound (forward_refs, 1); 631 j = forward_refs (i).instruction; 632 text_halfs (j).left = text_halfs (j).left + addr (rands (forward_refs (i).operand)) -> label.location; 633 end; 634 635 /* free up space so name_assign can use */ 636 637 next_free_polish = begin_forward_refs; 638 639 /* allocate library structure */ 640 641 if first_lib_name ^= 0 642 then do; 643 lib_pos = text_pos; 644 lib_list_ptr = addrel (object_base, lib_pos); 645 lib_reloc_ptr = addrel (relocation_base, lib_pos); 646 n = num_of_lib_names; 647 saved_lib_list.nlibs = n; 648 text_pos = text_pos + size (saved_lib_list); 649 650 i = 1; 651 do lib = first_lib_name repeat lib_pt -> library.next_library_node while (lib > 0); 652 lib_pt = addr (rands (lib)); 653 c = addr (rands (lib_pt -> library.character_operand)); 654 saved_lib_list.offset (i) = unspec (c -> char_constant.location); 655 saved_lib_list.lng (i) = c -> char_constant.length; 656 saved_lib_reloc_list.reloc (i) = rc_t; 657 i = i + 1; 658 end; 659 end; 660 661 /* initialize static */ 662 663 linkrel = divide (text_pos + 1, 2, 17, 0) * 2; 664 link_base = addrel (object_base, linkrel); 665 link_reloc_base = addrel (relocation_base, linkrel); 666 667 call initialize_static; 668 669 /* generate links */ 670 671 defrel = link_pos + linkrel; 672 def_base = addrel (object_base, defrel); 673 def_reloc_base = addrel (relocation_base, defrel); 674 675 call init_linkage; 676 call gen_linkage; 677 678 /* generate entry definitions */ 679 680 call gen_entry_defs; 681 682 /* generate library definition */ 683 684 if lib_pos ^= 0 685 then call generate_definition ("library_list_", 0, bit (lib_pos, 18)); 686 687 /* free up space for make symbol_table that is no longer used */ 688 689 next_free_polish = begin_forward_refs; 690 691 /* generate symbol section */ 692 693 symrel = divide (defrel + def_pos + 1, 2, 17, 0) * 2; 694 695 symtab_parameters.link_base_ptr = link_base; 696 symtab_parameters.link_reloc_base_ptr = link_reloc_base; 697 symtab_parameters.def_reloc_base_ptr = def_reloc_base; 698 symtab_parameters.current_text_offset = text_pos; 699 symtab_parameters.current_def_offset = def_pos; 700 symtab_parameters.current_link_offset = link_pos; 701 symtab_parameters.final_text_offset = last_pos; 702 symtab_parameters.profile_offset = profile_start; 703 symtab_parameters.star_symbol_link = builtins (9); 704 symtab_parameters.first_namelist_symbol = first_namelist; 705 706 call fort_make_symbol_section (shared_struc_ptr, cg_struc_ptr, addr (symtab_parameters), symrel, sym_pos); 707 708 709 /* finish up the object segment by filling in the 710* standard object map */ 711 712 n = divide (symrel + sym_pos + 1, 2, 17, 0) * 2; 713 p = addrel (object_base, n); 714 715 p -> object_map.decl_vers = object_map_version_2; 716 p -> object_map.identifier = "obj_map"; 717 p -> object_map.text_length = bit (text_pos, 18); 718 p -> object_map.definition_offset = bit (defrel, 18); 719 p -> object_map.definition_length = bit (def_pos, 18); 720 p -> object_map.linkage_offset = bit (linkrel, 18); 721 p -> object_map.linkage_length = bit (link_pos, 18); 722 p -> object_map.static_offset = bit (fixed (linkrel + size (virgin_linkage_header), 18), 18); 723 p -> object_map.static_length = bit (fixed (begin_links - size (virgin_linkage_header), 18), 18); 724 p -> object_map.symbol_offset = bit (symrel, 18); 725 p -> object_map.symbol_length = bit (sym_pos, 18); 726 727 p -> object_map.format.separate_static = "0"b; 728 729 p -> object_map.format.relocatable = shared_globals.options.relocatable; 730 731 p -> object_map.format.procedure, p -> object_map.format.standard = "1"b; 732 733 addrel (p, size (p -> object_map)) -> map_ptr = bit (n, 18); 734 735 /* set next_free_object and return */ 736 737 next_free_object = n + size (p -> object_map) + 1; 738 return; 739 740 get_subr_options: 741 procedure (cs); 742 743 /* Sets various global flags to correspond to the options in 744* effect for the given program unit. */ 745 746 dcl cs pointer; /* Pointer to subprogram node */ 747 748 do_rounding = cs -> subprogram.options.do_rounding; 749 generate_profile = cs -> subprogram.options.profile; 750 generate_long_profile = cs -> subprogram.options.long_profile; 751 generate_symtab = cs -> subprogram.options.table | shared_globals.options.namelist_used; 752 init_auto_to_zero = cs -> subprogram.options.auto_zero; 753 754 return; 755 756 end get_subr_options; 757 758 /**** CONSTANT ALLOCATION ****/ 759 760 alloc_constants: 761 procedure (start, amt); 762 763 /* Allocates constants in the text section */ 764 765 dcl start fixed binary (18); 766 dcl (amt, n) fixed binary; 767 768 n = amt; 769 770 do con = start repeat c -> constant.next_constant while (con > 0); 771 c = addr (rands (con)); 772 if ^c -> constant.allocated 773 then if c -> constant.allocate | c -> constant.passed_as_arg 774 then do; 775 c -> constant.location = text_pos; 776 addrel (object_base, text_pos) -> image = addr (c -> constant.value) -> image; 777 text_pos = text_pos + n; 778 c -> constant.allocated = "1"b; 779 end; 780 end; 781 782 end alloc_constants; 783 784 alloc_char_constants: 785 procedure (start); 786 787 /* Allocates character constants in the text section */ 788 789 dcl start fixed binary (18); 790 dcl relocate_itp bit (1) aligned; 791 792 relocate_itp = start = first_block_constant; 793 794 do con = start repeat c -> char_constant.next_constant while (con > 0); 795 c = addr (rands (con)); 796 if ^c -> char_constant.allocated 797 then if c -> char_constant.allocate | c -> char_constant.passed_as_arg 798 then do; 799 if c -> char_constant.length = chars_per_dw 800 /* a double word constant */ 801 then text_pos = text_pos + mod (text_pos, 2); 802 /* get even address */ 803 804 amt = divide (c -> char_constant.length + chars_per_word - 1, chars_per_word, 17, 0); 805 c -> char_constant.location = text_pos; 806 addrel (object_base, text_pos) -> char_image = c -> char_constant.value; 807 if relocate_itp 808 then call relocate_itp_list; 809 text_pos = text_pos + amt; 810 c -> char_constant.allocated = "1"b; 811 end; 812 end; 813 814 end alloc_char_constants; 815 816 relocate_itp_list: 817 procedure (); 818 819 /* Generates relocation bits for an itp argument list */ 820 821 dcl q pointer; 822 dcl rscan fixed binary (18); 823 824 do rscan = text_pos + 2 to text_pos + amt - 1 by 2; 825 q = addrel (object_base, rscan); 826 827 if q -> itp.itp_mod = ITP_mod /* ITP word */ 828 then if q -> itp.pr_no = lp 829 then reloc_halfs (rscan + 1).left = rc_is18; 830 else ; 831 else if q -> itp.itp_mod = "00"b3 /* ordinary indirect word */ 832 then reloc_halfs (rscan).left = rc_t; 833 end; 834 835 end relocate_itp_list; 836 837 assign_address_offset: 838 procedure (p, inc, size, units); 839 840 /* This procedure sets node.address.offset and node.location 841* from node.location and the offset increment inc. */ 842 843 dcl p pointer; /* Node pointer */ 844 dcl inc fixed binary (18); /* Offset increment */ 845 dcl size fixed binary (18); /* Size of datum */ 846 dcl units fixed binary (3); /* Units of size */ 847 848 call set_address_offset ((p), (p -> node.location + inc), (size), (units)); 849 850 end assign_address_offset; 851 852 set_address_offset: 853 procedure (p, off, size, units); 854 855 /* Sets p -> node.address.offset and p -> node.location to 856* the correct values for the offset off. */ 857 858 dcl p pointer; 859 dcl (off, loc, offset) fixed binary (18); 860 dcl size fixed binary (18); 861 dcl units fixed binary (3); 862 863 offset = off; 864 865 if abs (offset) + get_size_in_words ((size), (units)) - 1 >= 16384 866 then do; 867 loc = offset; 868 p -> node.large_address = "1"b; 869 p -> node.is_addressable = "0"b; 870 offset = mod (offset + 16384, 32768) - 16384; 871 p -> node.location = loc - offset; 872 end; 873 874 p -> node.address.offset = offset; 875 876 end set_address_offset; 877 878 get_size_in_words: 879 procedure (size, units) returns (fixed binary (18)); 880 881 /* Converts a size in the specified units to word units */ 882 883 dcl size fixed binary (18); 884 dcl (units, u) fixed binary (3); 885 886 dcl factor (0:3) fixed binary (18) internal static options (constant) initial (1, 36, 4, 2); 887 888 u = mod (units, 4); 889 890 if u = word_units 891 then return (size); /* For speed */ 892 893 return (divide (size + factor (u) - 1, factor (u), 18, 0)); 894 895 end get_size_in_words; 896 897 get_size_in_bits: 898 procedure (size, units) returns (fixed binary (18)); 899 900 /* Converts a size in the specified units to bits */ 901 902 dcl size fixed binary (18); 903 dcl (units, u) fixed binary (3); 904 905 dcl factor (0:3) fixed binary (18) internal static options (constant) initial (36, 1, 9, 18); 906 907 u = mod (units, 4); 908 return (size * factor (u)); 909 910 end get_size_in_bits; 911 912 assign_storage: 913 procedure (); 914 915 /* STORAGE ALLOCATOR 916* 917* subprogram.storage_info is organized into 17 buckets to aid in 918* storage allocation. The buckets are assigned as follows: 919* 920* 1 auto double init 921* 2 auto single init 922* 3 auto double 923* 4 auto single 924* 5 static double init 925* 6 static single init 926* 7 static double 927* 8 static single 928* 9 common & external constants 929* 10 parameters 930* 11 others 931* 12 not allocated 932* 13 Large Array Automatic 933* 14 Large Array Static 934* 15 Very Large Array Automatic 935* 16 Very Large Array Static 936* 17 Very Large Array Common 937* */ 938 939 dcl (cs, h, os, clp, psp, psap, s, ssp) pointer; 940 dcl (hdr, sym, i, vsize, other_sym) fixed binary (18); 941 dcl loc fixed binary (18); 942 dcl not_found bit (1) aligned; 943 dcl alloc_ps bit (1) aligned; 944 20 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 20 2 20 3 /* This include file defines the relocation bits as bit (6) entities. See 20 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 20 5 20 6 dcl ( rc_a initial("000000"b), /* absolute */ 20 7 rc_t initial("010000"b), /* text */ 20 8 rc_nt initial("010001"b), /* negative text */ 20 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 20 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 20 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 20 12 rc_dp initial("010101"b), /* def section */ 20 13 rc_s initial("010110"b), /* symbol segment */ 20 14 rc_ns initial("010111"b), /* negative symbol */ 20 15 rc_is18 initial("011000"b), /* internal static 18 */ 20 16 rc_is15 initial("011001"b), /* internal static 15 */ 20 17 rc_lb initial("011000"b), /* link block */ 20 18 rc_nlb initial("011001"b), /* negative link block */ 20 19 rc_sr initial("011010"b), /* self relative */ 20 20 rc_e initial("011111"b)) /* escape */ 20 21 bit(6) int static options(constant); 20 22 20 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 945 946 947 /* 78.06.12 The parse now sets the following fields formerly set by the storage allocator. 948* Note that these fields are only set for those variables that need them: 949* 950* symbol.data_type 951* symbol.element_size 952* symbol.auto } One of these is set but only if the symbol 953* symbol.static } is a variable without a storage class 954* */ 955 956 last_auto_loc = first_auto_loc; 957 958 /* link_pos is the current offset of linkage entries from the end of static 959* for the duration of external assignement. Then it transforms to be the 960* current address in the linkage section of relocation of static. 961* linkage_pad is the space which is occupied by the 962* LA and VLA base pointers for static variables. linkage_pad delineates a 963* section which is within static, but which is not filled with normal variables. */ 964 965 linkage_pad = 0; 966 967 Area_create_first, Area_init_first = -1; /* flag off */ 968 969 alloc_ps, alloc_auto_cleanup = "0"b; 970 971 /* setup for cleanup of VLA common processing lists */ 972 973 on cleanup call cleanup_VLA_common; 974 975 /* allocate entry points */ 976 977 do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0); 978 s = addr (rands (sym)); 979 980 s -> symbol.operand_type = entry_type; 981 s -> symbol.hash_chain = 0; 982 s -> symbol.is_addressable = "1"b; 983 s -> symbol.reloc = rc_t; 984 985 /* associate a quick entry point with a subprogram entry pt */ 986 987 if s -> symbol.name ^= main_entry_point_name 988 then s -> symbol.initial = create_rel_constant (); 989 end; 990 991 /* do allocation for each subprogram */ 992 993 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 994 cs = addr (rands (cur_subprogram)); 995 call get_subr_options (cs); 996 997 /* see if ps needed */ 998 999 alloc_ps = alloc_ps | cs -> subprogram.need_PS; 1000 1001 /* allocate labels */ 1002 1003 do sym = cs -> subprogram.first_label repeat s -> label.next_label while (sym > 0); 1004 s = addr (rands (sym)); 1005 s -> label.is_addressable = "1"b; 1006 s -> label.reloc = rc_t; 1007 end; 1008 1009 /* initialize storage info */ 1010 1011 unspec (cs -> subprogram.storage_info) = "0"b; 1012 1013 /* Allocate vars in LA chain */ 1014 1015 hdr = cs -> subprogram.LA_chain; 1016 do while (hdr > 0); 1017 h = addr (rands (hdr)); 1018 if h -> header.allocate 1019 then do; 1020 h -> header.needs_pointer = "1"b; 1021 unspec (h -> header.address) = ext_base_on; 1022 h -> header.allocated = "1"b; 1023 1024 call alloc_members; 1025 1026 h -> header.reloc = RI_mod; 1027 1028 /* Allocate the unpacked pointer storage in either static or automatic */ 1029 1030 if h -> header.static 1031 then do; 1032 i = 14; /* LA static */ 1033 if mod (linkage_pad + size (virgin_linkage_header), 2) ^= 0 1034 then linkage_pad = linkage_pad + 1; 1035 h -> header.location = linkage_pad + size (virgin_linkage_header); 1036 h -> header.base = lp; 1037 linkage_pad = linkage_pad + 2;/* assign double word */ 1038 end; 1039 else do; 1040 i = 13; /* LA auto */ 1041 if mod (last_auto_loc, 2) ^= 0 1042 then last_auto_loc = last_auto_loc + 1; 1043 /* even word aligned */ 1044 1045 h -> header.location = last_auto_loc; 1046 h -> header.base = sp; 1047 last_auto_loc = last_auto_loc + 2; 1048 end; 1049 1050 1051 call create_storage_entry (h); 1052 1053 /* relocate members of Large Arrays */ 1054 1055 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1056 s = addr (rands (sym)); 1057 call assign_address_offset (s, 0, (s -> symbol.element_size), (s -> symbol.units)); 1058 end; 1059 1060 if h -> header.initialed 1061 then call list_initialize (addrel (object_base, text_pos), hdr, text_pos); 1062 1063 /* thread the block on the LA lists */ 1064 1065 if cs -> subprogram.storage_info.last (i) = 0 1066 then cs -> subprogram.storage_info.first (i) = hdr; 1067 else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr; 1068 cs -> subprogram.storage_info.last (i) = hdr; 1069 1070 end; 1071 1072 /* on to the next header */ 1073 1074 hdr = h -> header.next_header; 1075 h -> header.next_header = 0; 1076 end; 1077 1078 /* Allocate vars in VLA chain */ 1079 /* 87.12.13 The relocation factor for VLA common block members is 1080* absolute (rc_a); whereas the relocation factor for VLA common block 1081* is internal_static_15 (rc_is15). */ 1082 1083 hdr = cs -> subprogram.VLA_chain; 1084 do while (hdr > 0); 1085 h = addr (rands (hdr)); 1086 if h -> header.allocate 1087 then do; 1088 h -> header.allocated = "1"b; 1089 h -> header.needs_pointer = "1"b; 1090 unspec (h -> header.address) = ext_base_on; 1091 h -> header.reloc = rc_a; 1092 1093 if h -> header.automatic 1094 then h -> header.address.base = sp; 1095 else h -> header.address.base = lp; 1096 1097 call alloc_members; 1098 1099 /* Allocate the base addressor. */ 1100 1101 if ^h -> header.automatic then h -> header.reloc = rc_is15; 1102 s = addr (rands (h -> header.VLA_base_addressor)); 1103 s -> symbol.is_addressable = "1"b; 1104 s -> symbol.allocated = "1"b; 1105 s -> symbol.address = h -> header.address; 1106 s -> symbol.reloc = h -> header.reloc; 1107 1108 if h -> header.in_common 1109 then do; 1110 i = 17; /* VLA common */ 1111 call note_VLA_common (h); 1112 end; 1113 else do; 1114 1115 /* Allocate the addressor storage in either static or automatic */ 1116 1117 if h -> header.static 1118 then do; 1119 i = 16; /* VLA static */ 1120 h -> header.location, h -> header.address.offset = 1121 linkage_pad + size (virgin_linkage_header); 1122 linkage_pad = linkage_pad + 1; 1123 /* space for base addressor */ 1124 end; 1125 else do; 1126 i = 15; /* VLA auto */ 1127 1128 h -> header.location, h -> header.address.offset = last_auto_loc; 1129 last_auto_loc = last_auto_loc + 1; 1130 /* space for base addressor */ 1131 end; 1132 call set_address_offset (s, (h -> header.location), 1, word_units); 1133 call create_storage_entry (h); 1134 if h -> header.initialed 1135 then call list_initialize (addrel (object_base, text_pos), hdr, text_pos); 1136 end; 1137 1138 /* thread the block on the VLA lists */ 1139 1140 if cs -> subprogram.storage_info.last (i) = 0 1141 then cs -> subprogram.storage_info.first (i) = hdr; 1142 else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr; 1143 cs -> subprogram.storage_info.last (i) = hdr; 1144 1145 end; 1146 1147 /* on to the next header */ 1148 1149 hdr = h -> header.next_header; 1150 h -> header.next_header = 0; 1151 end; 1152 1153 /* Allocate vars in common chain */ 1154 1155 hdr = cs -> subprogram.common_chain; 1156 do while (hdr > 0); 1157 h = addr (rands (hdr)); 1158 if h -> header.allocate 1159 then do; 1160 h -> header.needs_pointer = "1"b; 1161 unspec (h -> header.address) = ext_base_on; 1162 h -> header.allocated = "1"b; 1163 1164 call alloc_members; 1165 1166 h -> header.location = alloc_external (h); 1167 1168 /* thread the block on the linkage list */ 1169 1170 if cs -> subprogram.storage_info.last (9) = 0 1171 then cs -> subprogram.storage_info.first (9) = hdr; 1172 else addr (rands (cs -> subprogram.storage_info.last (9))) -> header.next_header = hdr; 1173 cs -> subprogram.storage_info.last (9) = hdr; 1174 1175 end; 1176 1177 /* on to the next header */ 1178 1179 hdr = h -> header.next_header; 1180 h -> header.next_header = 0; 1181 end; 1182 1183 /* Allocate other equivalence blocks */ 1184 1185 hdr = cs -> subprogram.equiv_chain; 1186 do while (hdr > 0); 1187 h = addr (rands (hdr)); 1188 if h -> header.allocate 1189 then do; 1190 1191 /* get subclass of equivalence group */ 1192 1193 if h -> header.even 1194 then i = 1; 1195 else i = 2; 1196 if ^h -> header.initialed 1197 then i = i + 2; 1198 if h -> header.static 1199 then i = i + 4; 1200 1201 /* allocate */ 1202 1203 if h -> header.odd 1204 then if mod (cs -> subprogram.next_loc (i), 2) = 0 1205 then cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + 1; 1206 1207 loc = cs -> subprogram.next_loc (i); 1208 cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + h -> header.length; 1209 if mod (i, 2) ^= 0 1210 then cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + mod (h -> header.length, 2); 1211 1212 1213 unspec (h -> header.address) = ext_base_on; 1214 h -> header.location = loc; 1215 if h -> header.static 1216 then do; 1217 h -> header.base = lp; 1218 h -> header.reloc = rc_is15; 1219 end; 1220 else h -> header.base = sp; 1221 h -> header.is_addressable = "1"b; 1222 h -> header.allocated = "1"b; 1223 1224 /* allocate elements of equiv chain */ 1225 1226 call alloc_members; 1227 end; 1228 1229 else i = 12; 1230 1231 /* thread the header in */ 1232 1233 if cs -> subprogram.storage_info.last (i) = 0 1234 then cs -> subprogram.storage_info.first (i) = hdr; 1235 else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr; 1236 cs -> subprogram.storage_info.last (i) = hdr; 1237 1238 hdr = h -> header.next_header; 1239 h -> header.next_header = 0; 1240 end; 1241 1242 /* Allocate non-equivalenced symbols */ 1243 1244 sym = cs -> subprogram.first_symbol; 1245 do while (sym > 0); 1246 s = addr (rands (sym)); 1247 if ^s -> symbol.allocated 1248 then do; 1249 if s -> symbol.parameter 1250 then s -> symbol.hash_chain = 0; /* Required by 'make_symbol_descriptor'. */ 1251 1252 /* Fix up request for 'PARAMETER' variables fully probe-able by allocating if 1253* we want a symbol table. */ 1254 1255 if s -> symbol.named_constant & cs -> subprogram.options.table 1256 then do; 1257 s -> symbol.allocate = "1"b; 1258 addr (rands (s -> symbol.initial)) -> node.allocate = "1"b; 1259 end; 1260 1261 if s -> symbol.allocate 1262 then do; 1263 unspec (s -> symbol.address) = "0"b; 1264 1265 s -> symbol.hash_chain = 0; 1266 1267 if s -> symbol.stmnt_func 1268 then do; 1269 s -> symbol.operand_type = statement_function; 1270 i = 11; 1271 end; 1272 else if s -> symbol.builtin 1273 then do; 1274 s -> symbol.operand_type = bif; 1275 i = 11; 1276 end; 1277 else if s -> symbol.named_constant 1278 then i = 11; 1279 else if s -> symbol.namelist 1280 then do; 1281 s -> label.location = text_pos; 1282 s -> symbol.is_addressable = "1"b; 1283 s -> symbol.reloc = rc_t; 1284 1285 vsize = divide (polish (s -> symbol.initial) + 4, 2, 17, 0); 1286 text_pos = text_pos + vsize; 1287 1288 if last_namelist = 0 1289 then first_namelist = sym; 1290 else addr (rands (last_namelist)) -> symbol.next_member = sym; 1291 last_namelist = sym; 1292 1293 i = 11; 1294 end; 1295 else if s -> symbol.parameter | s -> symbol.stack_indirect 1296 then do; 1297 i = 10; 1298 if s -> symbol.external 1299 then s -> symbol.operand_type = external; 1300 else s -> symbol.operand_type = variable_type; 1301 1302 if s -> symbol.VLA 1303 then do; 1304 1305 /* Allocate the base addressor of the VLA. */ 1306 other_sym = addr (rands (s -> symbol.dimension)) -> dimension.VLA_base_addressor; 1307 os = addr (rands (other_sym)); 1308 os -> symbol.is_addressable = "1"b; 1309 os -> symbol.allocated = "1"b; 1310 unspec (os -> symbol.address) = ext_base_on; 1311 os -> symbol.address.base = sp; 1312 os -> symbol.address.offset = last_auto_loc; 1313 if ^VLA_is_256K 1314 then last_auto_loc = last_auto_loc + 1; 1315 1316 /* Allocate the packed ptr to the VLA. */ 1317 if last_auto_loc > max_address_offset 1318 then call print_message (414, "The location of a VLA parameter base pointer", 1319 max_address_offset - bias); 1320 s -> symbol.needs_pointer = "1"b; 1321 s -> symbol.address.base = sp; 1322 s -> symbol.address.offset = last_auto_loc; 1323 last_auto_loc = last_auto_loc + 1; 1324 s -> symbol.location = s -> symbol.location * 2; 1325 end; 1326 1327 else if s -> symbol.stack_indirect 1328 then do; 1329 1330 /* multiple positions -- we need an auto 1331* ptr to point at the parameter */ 1332 1333 if mod (last_auto_loc, 2) ^= 0 1334 then last_auto_loc = last_auto_loc + 1; 1335 /* even word aligned */ 1336 s -> symbol.location = last_auto_loc; 1337 last_auto_loc = last_auto_loc + 2; 1338 if last_auto_loc > max_stack_size 1339 then call print_message (414, 1340 "in making multiple position parameter temporary the stack frame", 1341 max_stack_size - bias); 1342 end; 1343 1344 else /* the actual ptr location is twice the parameter number */ 1345 s -> symbol.location = s -> symbol.location * 2; 1346 1347 /* set up address field */ 1348 1349 s -> symbol.ext_base = "1"b; 1350 1351 if s -> symbol.dimensioned 1352 then do; 1353 s -> symbol.needs_pointer = "1"b; 1354 vsize = get_array_size (s); 1355 end; 1356 else if s -> symbol.data_type = cmpx_mode 1357 then s -> symbol.needs_pointer = "1"b; 1358 else if s -> symbol.data_type = char_mode 1359 then do; 1360 s -> symbol.needs_pointer = "1"b; 1361 if s -> symbol.variable_extents | s -> symbol.star_extents 1362 then if s -> symbol.needs_descriptors | s -> symbol.passed_as_arg 1363 | s -> symbol.put_in_symtab | shared_globals.options.table 1364 then vsize = make_symbol_descriptor (fixed (rel (s), 18)); 1365 end; 1366 else do; 1367 if ^s -> symbol.VLA 1368 then do; 1369 s -> symbol.address.offset = s -> symbol.location; 1370 s -> symbol.tag = RI_mod; 1371 /* RI */ 1372 end; 1373 else s -> symbol.tag = rc_a; 1374 /* stack */ 1375 if s -> symbol.stack_indirect 1376 then do; 1377 s -> symbol.address.base = sp; 1378 s -> symbol.is_addressable = "1"b; 1379 end; 1380 end; 1381 end; 1382 else if s -> symbol.external 1383 then do; 1384 1385 /* function or subroutine reference */ 1386 1387 s -> symbol.operand_type = external; 1388 1389 /* check if name is on subprogram in this compilation */ 1390 1391 not_found = "1"b; 1392 other_sym = first_entry_name; 1393 do while (other_sym > 0 & not_found); 1394 os = addr (rands (other_sym)); 1395 if s -> symbol.name = os -> symbol.name 1396 then not_found = "0"b; 1397 else other_sym = os -> symbol.next_symbol; 1398 end; 1399 1400 if not_found 1401 then do; 1402 s -> symbol.ext_base = "1"b; 1403 s -> symbol.base = lp; 1404 s -> symbol.location = alloc_external (s); 1405 s -> symbol.tag = RI_mod; 1406 /* RI */ 1407 s -> symbol.reloc = rc_lp15; 1408 s -> symbol.is_addressable = "1"b; 1409 end; 1410 1411 else do; 1412 s -> symbol.is_addressable = "0"b; 1413 s -> symbol.reloc = rc_t; 1414 s -> symbol.initial = other_sym; 1415 s -> symbol.needs_descriptors = os -> symbol.needs_descriptors; 1416 end; 1417 1418 i = 9; 1419 end; 1420 else do; 1421 1422 /* data type and storage class (must be auto or static) assigned by the parse */ 1423 1424 s -> symbol.operand_type = variable_type; 1425 1426 if s -> symbol.dimensioned 1427 then vsize = get_array_size (s); 1428 else vsize = get_size_in_words ((s -> symbol.element_size), (s -> symbol.units)); 1429 1430 /* get subclass */ 1431 1432 if data_type_size (s -> symbol.data_type) = 2 1433 then i = 1; 1434 else i = 2; 1435 if ^s -> symbol.initialed 1436 then i = i + 2; 1437 if s -> symbol.static 1438 then i = i + 4; 1439 1440 /* allocate */ 1441 1442 loc = cs -> subprogram.next_loc (i); 1443 cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + vsize; 1444 1445 /* set up addressing */ 1446 1447 if s -> symbol.static 1448 then do; 1449 s -> symbol.base = lp; 1450 s -> symbol.reloc = rc_is15; 1451 end; 1452 else s -> symbol.base = sp; 1453 s -> symbol.location = loc; 1454 s -> symbol.ext_base = "1"b; 1455 1456 s -> symbol.is_addressable = "1"b; 1457 end; 1458 1459 /* set allocated bit */ 1460 1461 s -> symbol.allocated = "1"b; 1462 end; 1463 1464 else i = 12; 1465 1466 /* thread symbol into new list */ 1467 1468 if cs -> subprogram.storage_info.last (i) = 0 1469 then cs -> subprogram.storage_info.first (i) = sym; 1470 else addr (rands (cs -> subprogram.storage_info.last (i))) -> symbol.next_symbol = sym; 1471 cs -> subprogram.storage_info.last (i) = sym; 1472 end; 1473 1474 sym = s -> symbol.next_symbol; 1475 s -> symbol.next_symbol = 0; 1476 end; 1477 1478 end; 1479 1480 /* Allocate <*symbol>|0 link, if necessary */ 1481 1482 if generate_symtab 1483 then do; 1484 1485 /* compile_link depends on symbol.name_length being 0 */ 1486 1487 builtins (9) = create_node (symbol_node, size (symbol)); 1488 ssp = addr (rands (builtins (9))); 1489 ssp -> symbol.operand_type = dummy; 1490 ssp -> symbol.by_compiler = "1"b; 1491 ssp -> symbol.external, ssp -> symbol.allocate, ssp -> symbol.allocated, ssp -> symbol.is_addressable, 1492 ssp -> symbol.ext_base = "1"b; 1493 ssp -> symbol.base = lp; 1494 ssp -> symbol.tag = RI_mod; /* RI */ 1495 ssp -> symbol.reloc = rc_lp15; 1496 ssp -> symbol.location = alloc_external (ssp); 1497 end; 1498 else builtins (9) = 0; 1499 1500 /* If a ps is needed, allocate it first to prevent problems with 16K boundary. 1501* ps must be in automatic storage because namelist, err=, and end= require current stack 1502* ptr to be in ps at all times, even after return from a->b->a segment flow. */ 1503 1504 if alloc_ps 1505 then do; 1506 builtins (2) = create_node (symbol_node, size (symbol)); 1507 psp = addr (rands (builtins (2))); 1508 psp -> symbol.operand_type = dummy; 1509 psp -> symbol.by_compiler = "1"b; 1510 psp -> symbol.automatic, psp -> symbol.allocate, psp -> symbol.allocated, psp -> symbol.is_addressable, 1511 psp -> symbol.ext_base = "1"b; 1512 psp -> symbol.base = sp; 1513 psp -> symbol.reloc = rc_a; 1514 last_auto_loc = divide (last_auto_loc + 1, 2, 17, 0) * 2; 1515 /* EVEN WORD NEEDED */ 1516 call assign_address_offset (psp, last_auto_loc, 48, word_units); 1517 last_auto_loc = last_auto_loc + 48; 1518 if last_auto_loc > max_stack_size 1519 then call print_message (414, "in making parameter storage for IO the stack frame", max_stack_size - bias); 1520 1521 /* Build a symbol that overlays the PS at the field buffer_p (offset 20b3). This symbol 1522* is used to load the value of this pointer by the object segment. */ 1523 1524 builtins (10) = create_node (symbol_node, size (symbol)); 1525 psap = addr (rands (builtins (10))); 1526 psap -> symbol = psp -> symbol; /* use PS symbol as template to create this one */ 1527 psap -> symbol.address.offset = psap -> symbol.address.offset + 16; 1528 /* = 20b3 */ 1529 end; 1530 1531 else builtins (2), builtins (10) = 0; 1532 1533 /* If a cleanup body is needed, allocate it. */ 1534 1535 if alloc_auto_cleanup 1536 then do; 1537 cleanup_body_address = create_node (symbol_node, size (symbol)); 1538 clp = addr (rands (cleanup_body_address)); 1539 clp -> symbol.operand_type = dummy; 1540 clp -> symbol.by_compiler = "1"b; 1541 clp -> symbol.automatic, clp -> symbol.allocate, clp -> symbol.allocated, clp -> symbol.is_addressable, 1542 clp -> symbol.ext_base = "1"b; 1543 clp -> symbol.base = sp; 1544 clp -> symbol.reloc = rc_a; 1545 last_auto_loc = divide (last_auto_loc + 1, 2, 17, 0) * 2; 1546 /* EVEN WORD NEEDED */ 1547 call assign_address_offset (clp, last_auto_loc, 8, word_units); 1548 cleanup_body_address = last_auto_loc; 1549 last_auto_loc = last_auto_loc + 8; 1550 if last_auto_loc > max_stack_size 1551 then call print_message (414, "in making cleanup body the stack frame", max_stack_size - bias); 1552 end; 1553 else cleanup_body_address = 0; 1554 1555 /* Allocate space for all VLA COMMON */ 1556 1557 call allocate_VLA_common; 1558 1559 /* All subprograms done, relocate auto & static items */ 1560 1561 link_pos = divide (size (virgin_linkage_header) + linkage_pad + 1, 2, 18, 0) * 2; 1562 first_auto_var_loc = last_auto_loc; 1563 1564 /* now relocate all other static and auto items */ 1565 1566 call relocate (1, last_auto_loc, max_stack_size, "stack frame"); 1567 call relocate (5, link_pos, max_linkage_size, "linkage section"); 1568 1569 /* allocate profile space, if -profile */ 1570 1571 if generate_profile 1572 then do; 1573 profile_start, profile_pos = link_pos; 1574 if generate_long_profile 1575 then do; 1576 profile_pos = size (long_profile_header); 1577 link_pos = link_pos + size (long_profile_header) + size (long_profile_entry) * (profile_size + 1); 1578 end; 1579 else link_pos = link_pos + size (profile_entry) * (profile_size + 1); 1580 1581 link_pos = link_pos + mod (link_pos, 2); 1582 if link_pos > max_linkage_size 1583 then call print_message (414, "when allocating PROFILE information the linkage section", 1584 char (max_linkage_size)); 1585 end; 1586 1587 /* Finally, relocate common + external refs */ 1588 1589 begin_links = link_pos; 1590 1591 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 1592 cs = addr (rands (cur_subprogram)); 1593 call get_subr_options (cs); 1594 1595 /* relocate external refs for VLA common */ 1596 1597 do hdr = cs -> subprogram.storage_info.first (17) repeat h -> node.next while (hdr > 0); 1598 h = addr (rands (hdr)); 1599 h -> node.location = h -> node.location + link_pos; 1600 end; 1601 1602 /* relocate common and external */ 1603 do hdr = cs -> subprogram.storage_info.first (9) repeat h -> node.next while (hdr > 0); 1604 h = addr (rands (hdr)); 1605 1606 if h -> node.node_type = header_node 1607 then do; 1608 h -> node.location = h -> node.location + link_pos; 1609 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1610 s = addr (rands (sym)); 1611 call assign_address_offset (s, 0, (s -> symbol.element_size), (s -> symbol.units)); 1612 end; 1613 end; 1614 1615 else do; 1616 if h -> symbol.initial = 0 1617 then call assign_address_offset (h, link_pos, 2, word_units); 1618 else h -> symbol.allocated = "0"b; 1619 end; 1620 end; 1621 1622 1623 end; 1624 1625 1626 /* Relocate the link pointer in the 'create_entry' for common. */ 1627 1628 call VLA_reloc_common_link; 1629 1630 1631 if generate_symtab 1632 then call assign_address_offset (ssp, link_pos, 2, word_units); 1633 1634 link_pos = link_pos + (next_free_polish - begin_external_list) - ((next_free_polish - begin_external_list) / 3); 1635 /* i.e., two words per link */ 1636 if link_pos > max_linkage_size 1637 then call print_message (414, 1638 "after allocating SYMTAB space for " || addr (rands (cs -> subprogram.symbol)) -> symbol.name 1639 || " the linkage section", char (max_linkage_size)); 1640 1641 return; 1642 1643 alloc_external: 1644 procedure (pt) returns (fixed binary (18)); 1645 1646 /* Searches the external_list to see if a common block or 1647* external reference has already been allocated before 1648* allocating a new link to it. 1649* 1650* The current implementation for the external list consists of 1651* three items per external variable. The first item is a pointer 1652* to a symbol node (for external entry points) or a pointer to 1653* a header node (for common blocks). The second item is only 1654* used for common blocks and specifies the (maximum) length for 1655* the common block. The third item is also only used for common 1656* block and indicates the units (words or characters of the 1657* maximum length. */ 1658 1659 dcl (p, pt) pointer; 1660 dcl loc fixed binary (18); 1661 dcl i fixed binary (18); 1662 dcl ceil builtin; 1663 dcl header_length fixed binary (24); 1664 1665 p = pt; 1666 1667 if p -> node.node_type = symbol_node 1668 then do i = begin_external_list to next_free_polish - 1 by 3; 1669 if ext_ref (i) -> node.node_type = symbol_node 1670 then if p -> symbol.name = ext_ref (i) -> symbol.name 1671 then return (ext_ref (i) -> symbol.location); 1672 end; 1673 1674 else do i = begin_external_list to next_free_polish - 1 by 3; 1675 if ext_ref (i) -> node.node_type = header_node 1676 then if p -> header.block_name = ext_ref (i) -> header.block_name 1677 then do; 1678 loc = ext_ref (i) -> header.location; 1679 1680 if p -> header.block_name = blank_common_name 1681 then do; 1682 if p -> header.units = polish (i + 2) 1683 then header_length = p -> header.length; 1684 else if polish (i + 2) = word_units 1685 then header_length = ceil (p -> header.length / 4); 1686 else header_length = p -> header.length * 4; 1687 /* change to character units */ 1688 if header_length > polish (i + 1) 1689 /* current max length */ 1690 then polish (i + 1) = header_length; 1691 /* update max length for unlabelled common */ 1692 end; 1693 else do; 1694 if p -> header.units = polish (i + 2) 1695 then header_length = p -> header.length; 1696 else if polish (i + 2) = word_units 1697 then header_length = ceil (p -> header.length / 4); 1698 else header_length = p -> header.length * 4; 1699 /* change to character units */ 1700 if header_length > polish (i + 1) 1701 /* current max length for block */ 1702 then do; 1703 polish (i + 1) = header_length; 1704 /* update length for common block */ 1705 if polish (i + 2) = word_units 1706 then call print_message (426, fixed (rel (p), 18), ltrim (char (header_length)), 1707 "words"); 1708 else call print_message (426, fixed (rel (p), 18), ltrim (char (header_length)), 1709 "characters"); 1710 end; 1711 else if header_length < polish (i + 1) 1712 /* check for different length */ 1713 then call print_message (434, fixed (rel (p), 18)); 1714 1715 if p -> header.initialed 1716 then if ext_ref (i) -> header.initialed 1717 then call print_message (432, fixed (rel (p), 18)); 1718 else ext_ref (i) = p; 1719 end; 1720 1721 return (loc); 1722 end; 1723 end; 1724 1725 /* allocate new entry in external list */ 1726 1727 if next_free_polish + 2 < polish_max_len 1728 then do; 1729 ext_ref (next_free_polish) = p; 1730 1731 if p -> node.node_type = header_node /* for common blocks, save block length */ 1732 then do; 1733 polish (next_free_polish + 1) = p -> header.length; 1734 polish (next_free_polish + 2) = p -> header.units; 1735 end; 1736 next_free_polish = next_free_polish + 3; 1737 1738 loc = link_pos; 1739 link_pos = link_pos + 2; 1740 if link_pos > max_linkage_size 1741 then call print_message (414, "linkage section", char (max_linkage_size)); 1742 1743 return (loc); 1744 end; 1745 1746 else call print_message (407, "polish region", char (polish_max_len)); 1747 1748 end alloc_external; 1749 1750 alloc_members: 1751 procedure (); 1752 1753 /* Allocates members of common blocks and equivalence groups. */ 1754 1755 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1756 s = addr (rands (sym)); 1757 substr (string (s -> symbol.storage_class), 1, 3) = string (h -> header.storage_class); 1758 unspec (s -> symbol.address) = unspec (h -> header.address); 1759 s -> symbol.reloc = h -> header.reloc; 1760 if s -> symbol.units = char_units 1761 then do; 1762 s -> symbol.location = h -> header.location + divide (s -> symbol.offset, chars_per_word, 18, 0); 1763 s -> symbol.address.char_num = mod (s -> symbol.offset, chars_per_word); 1764 end; 1765 else s -> symbol.location = h -> header.location + s -> symbol.offset; 1766 s -> symbol.operand_type = variable_type; 1767 string (s -> symbol.addressing_bits) = string (h -> header.addressing_bits); 1768 s -> symbol.hash_chain = 0; 1769 if s -> symbol.dimensioned 1770 then vsize = get_array_size (s); 1771 end; 1772 1773 end alloc_members; 1774 1775 create_storage_entry: 1776 proc (h); 1777 1778 /* Purpose: Create a creation list entry in the text section, and link it to 1779* the last such entry. Information required is taken from the chain 1780* header supplied. */ 1781 1782 1783 dcl h ptr; /* Incoming header pointer */ 1784 1785 dcl cur_pos fixed bin (18) unsigned; /* current position in text section */ 1786 dcl listp ptr; 1787 dcl i fixed bin; 1788 1789 1790 dcl (currentsize, length) builtin; 1791 1792 call make_create_entry (h); 1793 1794 if h -> header.VLA /* setup pointers */ 1795 then do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1796 s = addr (rands (sym)); 1797 if s -> symbol.offset = 0 & VLA_is_256K 1798 then call set_address_offset (s, (h -> header.location), 1, word_units); 1799 else do; 1800 listp -> create_entry.pointer_count = listp -> create_entry.pointer_count + 1; 1801 call set_address_offset (s, h -> header.location + listp -> create_entry.pointer_count, 1, 1802 word_units); 1803 listp -> create_entry.pointer_offsets (listp -> create_entry.pointer_count).offset = 1804 s -> symbol.offset; 1805 if h -> header.static 1806 then linkage_pad = linkage_pad + 1; 1807 else last_auto_loc = last_auto_loc + 1; 1808 1809 /* save the symbol name for the listing */ 1810 if assembly_list 1811 then do; 1812 cur_pos = 1813 fixed ( 1814 rel ( 1815 addr (listp -> create_entry.pointer_offsets (listp -> create_entry.pointer_count)))); 1816 a_name (cur_pos) = fixed (rel (s)); 1817 end; 1818 end; 1819 end; 1820 1821 /* increment past all information */ 1822 1823 text_pos = text_pos + currentsize (listp -> create_entry); 1824 return; 1825 1826 note_VLA_common: 1827 entry (h); 1828 1829 1830 /* Take note of common blocks in VLA common, and combine them into single 1831* composite representations for each common of every definition of that 1832* common. This means determining the maximum length, the number of unique 1833* offsets into the common (to build pointer information), and any init 1834* information. */ 1835 1836 dcl chain_head ptr; /* head of current chain */ 1837 dcl hdr ptr; /* current entry node */ 1838 dcl looping bit (1); /* scanning chain */ 1839 dcl s ptr; /* current symbol */ 1840 dcl sym fixed bin (18); /* current symbol node */ 1841 dcl this_chain ptr; /* last header of current chain */ 1842 1843 1844 /* entry for headers and symbols. */ 1845 1846 dcl 1 entry based (hdr), 1847 2 next ptr, /* next entry in header list */ 1848 2 chain ptr, /* next entry in chain */ 1849 2 node ptr, /* pointer node in rands */ 1850 2 header bit (1) unaligned, /* node is a header */ 1851 2 offset fixed bin (35) unsigned unaligned; /* symbol offset */ 1852 1853 if first_header = null () /* no list */ 1854 then goto create_header; 1855 1856 /* find header chain. */ 1857 1858 do hdr = first_header repeat entry.next while (hdr ^= null ()); 1859 if entry.node -> header.block_name = h -> header.block_name 1860 then goto add_header; /* in right chain */ 1861 end /* do hdr */; 1862 1863 /* at this point we don't have the right chain, but we do have a list */ 1864 1865 if hdr = null () 1866 then do; 1867 1868 create_header: 1869 call make_entry; 1870 if first_header = null () /* chain to list */ 1871 then first_header = hdr; 1872 else last_header -> entry.next = hdr; 1873 last_header = hdr; 1874 end; 1875 else do; /* cannot enter through the do, it is just for blocking */ 1876 1877 /* form maximum length */ 1878 1879 add_header: 1880 chain_head = hdr; 1881 if h -> header.length ^= entry.node -> header.length 1882 then do; 1883 1884 /* form maximum common block lengths */ 1885 1886 if h -> header.block_name ^= blank_common_name 1887 then if h -> header.length > entry.node -> header.length 1888 then call print_message (426, fixed (rel (h), 18), ltrim (char (h -> header.length))); 1889 else call print_message (434, fixed (rel (h), 18)); 1890 1891 if h -> header.length > entry.node -> header.length 1892 then h -> header.length = entry.node -> header.length; 1893 end; 1894 1895 1896 /* find end of headers in chain list. */ 1897 1898 do hdr = chain_head repeat entry.chain while (entry.chain -> entry.header = "1"b); 1899 end; /* leave hdr pointing at last header of chain */ 1900 1901 /* Link new entry into chain as last header in header portion of chain */ 1902 1903 this_chain = hdr; 1904 call make_entry; 1905 entry.chain = this_chain -> entry.chain; 1906 this_chain -> entry.chain = hdr; 1907 end; 1908 1909 1910 /* Add list of symbols to chain. Last header of chain is at 'hdr' */ 1911 /* This leaves a list sorted by symbol offset. */ 1912 1913 add_symbols: 1914 chain_head = hdr; 1915 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1916 s = addr (rands (sym)); 1917 1918 /* add total if chain is empty of symbols. */ 1919 1920 this_chain = chain_head; 1921 if this_chain -> entry.chain ^= null () 1922 then do; 1923 looping = "1"b; 1924 do while (looping); 1925 this_chain = this_chain -> entry.chain; 1926 if this_chain -> entry.chain = null () 1927 then looping = "0"b; 1928 else if this_chain -> entry.chain -> entry.offset > s -> symbol.offset 1929 then looping = "0"b; 1930 end; 1931 end; 1932 1933 /* hdr points at add_point to chain */ 1934 1935 call make_entry; 1936 entry.offset = s -> symbol.offset; 1937 entry.chain = this_chain -> entry.chain; 1938 entry.node = s; 1939 entry.header = "0"b; 1940 this_chain -> entry.chain = hdr; 1941 end /* do sym */; 1942 return; 1943 1944 /* Assign Storage to VLA common. */ 1945 allocate_VLA_common: 1946 entry; 1947 1948 /* Assign storage address and storage creation information. This is done 1949* by scanning the finalized lists and copying the maximum length through all 1950* headers for the multiple uses of that common, then creating a storage 1951* creation entry for the common, and then assigning a pointer location 1952* to each unique offset, and copying that pointer location into the symbols 1953* mapped into that unique offset. At the same point a storage creation 1954* pointer is created and assigned that offset. Initialization information 1955* is picked up in a separate pass through the symbols. */ 1956 1957 dcl common_length fixed bin (35); /* common_length of the common block */ 1958 dcl current_offset fixed bin (35); /* current symbol offset processing */ 1959 dcl location fixed bin (18); /* location of packed pointers */ 1960 1961 /* scan commons */ 1962 1963 do chain_head = first_header repeat chain_head while (chain_head ^= null ()); 1964 1965 /* pick up the maximum length and propagate it through the multiple copies of headers */ 1966 1967 common_length = chain_head -> entry.node -> header.length; 1968 1969 /* 'header.location' is the normal location in which the 1970* external link would be found and will be later relocated 1971* and external reference made. */ 1972 1973 /* At this point header.location is the pointer to the first PP. */ 1974 1975 /* NOTE - you will see the strange construction 'copy ("0"b, 18 - length (x)) || x' 1976* in setting 'reloc_halfs' in this code. This is because of the use to two 1977* different definitions for 'rc_t' and 'rc_lp18', one for 6-bits and the 1978* other for 18-bits. Why they have the same name I do not know, but I do know 1979* that the binder is very unhappy to receive a 6-bit relocation value left 1980* adjusted in an 18-bit field, hence the padding. If some turkey changes the 1981* definition in the future, and I get the 18-bitter, it will still work. */ 1982 1983 location, chain_head -> entry.node -> header.location = linkage_pad + size (virgin_linkage_header); 1984 linkage_pad = linkage_pad + 1; /* space for base addressor */ 1985 call make_create_entry (chain_head -> entry.node); 1986 chain_head -> entry.node -> header.location, listp -> create_entry.common_link = 1987 alloc_external (chain_head -> entry.node); 1988 reloc_halfs (text_pos + 3).left = copy ("0"b, 18 - length (rc_lp18)) || rc_lp18; 1989 call set_address_offset (addr (rands (chain_head -> entry.node -> header.VLA_base_addressor)), (location), 1990 1, word_units); 1991 1992 do hdr = chain_head -> entry.chain repeat entry.chain while (entry.header = "1"b); 1993 entry.node -> header.length = common_length; 1994 entry.node -> header.location = alloc_external (entry.node); 1995 call set_address_offset (addr (rands (entry.node -> header.VLA_base_addressor)), (location), 1, 1996 word_units); 1997 end; 1998 1999 if VLA_is_256K 2000 then current_offset = 0; /* Base addressor is a packed ptr to offset 0. */ 2001 else current_offset = -1; /* Base addressor is logical address of offset 0. */ 2002 i = 0; /* current pointer */ 2003 do hdr = hdr repeat entry.chain while (hdr ^= null ()); 2004 s = entry.node; 2005 if s -> symbol.offset ^= current_offset 2006 then i = i + 1; /* count unique pointer */ 2007 call set_address_offset (s, location + i, 1, word_units); 2008 2009 /* Save a copy of the offset information */ 2010 s -> symbol.addr_hold = substr (unspec (s -> symbol.address), 1, 18); 2011 2012 /* create a pointer for all but possibly the first unique entry */ 2013 2014 if s -> symbol.offset ^= current_offset 2015 then do; 2016 current_offset = s -> symbol.offset; 2017 listp -> create_entry.pointer_count = i; 2018 listp -> create_entry.pointer_offsets (i).offset = s -> symbol.offset; 2019 linkage_pad = linkage_pad + 1; 2020 2021 /* save the symbol name for the listing */ 2022 if assembly_list 2023 then do; 2024 cur_pos = fixed (rel (addr (listp -> create_entry.pointer_offsets (i)))); 2025 a_name (cur_pos) = fixed (rel (s)); 2026 end; 2027 end /* do */; 2028 end /* do hdr */; 2029 2030 text_pos = text_pos + currentsize (listp -> create_entry); 2031 2032 chain_head = chain_head -> entry.next; 2033 end /* do chain_head */; 2034 2035 call cleanup_VLA_common; /* Use common cleanup */ 2036 return; 2037 2038 /* Entry to relocate the link relative offset left in the create_entry for 2039* common VLA, to become a true linkage section offset. */ 2040 2041 VLA_reloc_common_link: 2042 entry; 2043 2044 2045 looping = "1"b; /* loop through list */ 2046 2047 location = Area_create_first; 2048 if Area_create_first ^= -1 2049 then do while (looping = "1"b); 2050 listp = addrel (object_base, location); 2051 if listp -> create_entry.common 2052 then listp -> create_entry.common_link = listp -> create_entry.common_link + link_pos; 2053 location = listp -> create_entry.next; 2054 if location = 0 2055 then looping = "0"b; 2056 end; 2057 return; 2058 2059 2060 2061 cleanup_VLA_common: 2062 entry; 2063 2064 /* Cleanup vla common allocation lists when cleanup encountered. */ 2065 2066 if first_header = null () 2067 then return; 2068 2069 do first_header = first_header repeat first_header while (first_header ^= null ()); 2070 chain_head = first_header; 2071 first_header = first_header -> entry.next; 2072 do this_chain = chain_head repeat this_chain while (this_chain ^= null ()); 2073 hdr = this_chain; 2074 this_chain = entry.chain; 2075 free entry; 2076 end /* do this_chain */; 2077 end /* do first_header */; 2078 2079 return /* cleanup_VLA_common */; 2080 2081 2082 /* create an entry for a header/symbol */ 2083 make_entry: 2084 proc; 2085 2086 allocate entry; 2087 entry.node = h; 2088 entry.chain, entry.next = null (); 2089 entry.offset = 0; 2090 entry.header = "1"b; 2091 return; 2092 end make_entry; /* Make the basic creation list entry. */ 2093 make_create_entry: 2094 proc (h); 2095 2096 dcl h ptr; 2097 dcl i fixed bin (18); /* index in text */ 2098 dcl last_listp ptr; /* -> last create_entry */ 2099 2100 listp = addrel (object_base, text_pos); 2101 2102 /* Set location of base pointer in section and set relocation of pointer */ 2103 2104 listp -> create_entry.location = h -> header.location; 2105 if h -> header.static | h -> header.in_common 2106 then reloc_halfs (text_pos).left = copy ("0"b, 18 - length (rc_is15)) || rc_is15; 2107 else if h -> header.automatic 2108 then reloc_halfs (text_pos).left = copy ("0"b, 18 - length (rc_a)) || rc_a; 2109 2110 listp -> create_entry.auto = h -> header.automatic; 2111 listp -> create_entry.static = h -> header.static; 2112 listp -> create_entry.common = h -> header.in_common; 2113 listp -> create_entry.LA = h -> header.LA; 2114 listp -> create_entry.VLA = h -> header.VLA; 2115 listp -> create_entry.K256 = VLA_is_256K; 2116 listp -> create_entry.init = h -> header.initialed; 2117 listp -> create_entry.length = h -> header.length; 2118 listp -> create_entry.next = 0; 2119 listp -> create_entry.name_length = h -> header.name_length; 2120 if listp -> create_entry.name_length ^= 0 2121 then listp -> create_entry.block_name = h -> header.block_name; 2122 2123 listp -> create_entry.pointer_count = 0; 2124 2125 if h -> header.automatic 2126 then alloc_auto_cleanup = "1"b; /* cleanup automatic LA's and VLA's */ 2127 2128 if Area_create_first < 0 /* flagged empty */ 2129 then Area_create_first = text_pos; 2130 else do; 2131 2132 /* Link previous entry to this one and set relocation too. */ 2133 2134 last_listp = addrel (object_base, Area_create_last); 2135 last_listp -> create_entry.next = text_pos; 2136 i = fixed (rel (addr (last_listp -> create_entry.next)), 18, 0) - fixed (rel (object_base), 18, 0); 2137 reloc_halfs (i).left = copy ("0"b, 18 - length (rc_t)) || rc_t; 2138 end; 2139 Area_create_last = text_pos; 2140 2141 end make_create_entry; 2142 end create_storage_entry; 2143 2144 relocate: 2145 procedure (which, locn, limit, section_name); 2146 2147 /* Relocates items in each bucket. */ 2148 2149 dcl which fixed binary (18), 2150 locn fixed binary (18), 2151 limit fixed binary (18), /* limit of section */ 2152 section_name char (*); /* name of section */ 2153 2154 dcl (i, loc, start) fixed binary (18); 2155 2156 loc = locn; 2157 2158 do start = which to which + 2 by 2; 2159 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 2160 cs = addr (rands (cur_subprogram)); 2161 call get_subr_options (cs); 2162 2163 do i = start to start + 1; 2164 cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + loc; 2165 2166 do hdr = cs -> subprogram.storage_info.first (i) repeat h -> node.next while (hdr > 0); 2167 h = addr (rands (hdr)); 2168 2169 if h -> node.node_type = header_node 2170 then do; 2171 call assign_address_offset (h, loc, 1, word_units); 2172 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 2173 s = addr (rands (sym)); 2174 call relocate_error (s); 2175 call assign_address_offset (s, loc, (s -> symbol.element_size), 2176 (s -> symbol.units)); 2177 end; 2178 end; 2179 2180 else do; 2181 call relocate_error (h); 2182 call assign_address_offset (h, loc, (h -> symbol.element_size), (h -> symbol.units)); 2183 end; 2184 end; 2185 2186 loc = cs -> subprogram.next_loc (i); 2187 end; 2188 2189 loc = loc + mod (loc, 2); 2190 end; 2191 end; 2192 2193 locn = loc; 2194 2195 /* Test if variable will fit within region. */ 2196 2197 relocate_error: 2198 proc (s); 2199 2200 dcl s ptr; /* pointer to node */ 2201 dcl next_loc fixed bin (18); 2202 2203 if s -> node.next ^= 0 2204 then next_loc = addr (rands (s -> node.next)) -> node.location; 2205 else next_loc = cs -> subprogram.next_loc (i) - loc; 2206 2207 if loc + next_loc > limit 2208 then call print_message (414, 2209 "with relocation of " || s -> symbol.name || " in " 2210 || addr (rands (cs -> subprogram.symbol)) -> symbol.name || " the " || section_name, 2211 ltrim (char (limit))); 2212 end relocate_error; 2213 end relocate; 2214 2215 get_array_size: 2216 procedure (pt) returns (fixed binary (18)); 2217 2218 /* Calculates the size of an array, and computes its virtual 2219* origin if constant. */ 2220 2221 dcl (pt, s, d) pointer; 2222 dcl (cm, i, n, v) fixed binary (18); 2223 2224 n = 0; 2225 s = pt; 2226 d = addr (rands (s -> symbol.dimension)); 2227 2228 if ^s -> symbol.variable_extents & ^s -> symbol.star_extents 2229 then do; 2230 d -> dimension.array_size = d -> dimension.element_count * s -> symbol.element_size; 2231 d -> dimension.has_array_size = "1"b; 2232 n = get_size_in_words ((d -> dimension.array_size), (s -> symbol.units)); 2233 2234 /* calculate virtual origin */ 2235 2236 v = 0; 2237 cm = s -> symbol.element_size; 2238 do i = 1 to d -> dimension.number_of_dims; 2239 v = v + cm * d -> dimension.lower_bound (i); 2240 cm = cm * d -> dimension.size (i); 2241 end; 2242 2243 d -> dimension.virtual_origin = v; 2244 d -> dimension.has_virtual_origin = "1"b; 2245 end; 2246 2247 else do; 2248 2249 /* Make a descriptor for the array */ 2250 2251 if s -> symbol.needs_descriptors | s -> symbol.put_in_symtab | shared_globals.options.table 2252 then i = make_symbol_descriptor (fixed (rel (s), 18)); 2253 2254 /* Allocate symbols for dimension.size (*) */ 2255 2256 if ^d -> dimension.has_dim_sizes 2257 then do; 2258 do i = 1 to d -> dimension.number_of_dims - binary (d -> dimension.assumed_size, 1); 2259 if string (d -> dimension.v_bound (i)) = "00"b 2260 then d -> dimension.size (i) = 2261 d -> dimension.upper_bound (i) - d -> dimension.lower_bound (i) + 1; 2262 else if ^d -> dimension.v_bound (i).lower & d -> dimension.lower_bound (i) = 1 2263 then d -> dimension.size (i) = d -> dimension.upper_bound (i); 2264 else d -> dimension.size (i) = create_automatic_integer (cs); 2265 end; 2266 d -> dimension.has_dim_sizes = "1"b; 2267 end; 2268 end; 2269 2270 return (n); 2271 2272 end get_array_size; 2273 2274 end assign_storage; 2275 2276 create_automatic_integer: 2277 procedure (cs) returns (fixed binary (18)); 2278 2279 /* Creates an automatic integer variable. */ 2280 2281 dcl cs pointer; /* Subprogram node pointer */ 2282 2283 dcl s pointer; /* Symbol pointer */ 2284 dcl sym fixed binary (18); /* Symbol offset */ 2285 2286 sym = create_node (symbol_node, size (symbol)); 2287 s = addr (rands (sym)); 2288 s -> symbol.data_type = int_mode; 2289 s -> symbol.by_compiler, s -> symbol.integer, s -> symbol.allocate, s -> symbol.automatic = "1"b; 2290 s -> symbol.element_size = 1; 2291 s -> symbol.units = word_units; 2292 2293 addr (rands (cs -> subprogram.last_symbol)) -> node.next = sym; 2294 cs -> subprogram.last_symbol = sym; 2295 2296 return (sym); 2297 2298 end create_automatic_integer; 2299 2300 /**** CREATE_REL_CONSTANT ****/ 2301 2302 create_rel_constant: 2303 procedure () returns (fixed binary (18)); 2304 2305 /* Creates a rel_constant */ 2306 2307 dcl var fixed binary (18); 2308 dcl p pointer; 2309 21 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 21 2 21 3 /* This include file defines the relocation bits as bit (6) entities. See 21 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 21 5 21 6 dcl ( rc_a initial("000000"b), /* absolute */ 21 7 rc_t initial("010000"b), /* text */ 21 8 rc_nt initial("010001"b), /* negative text */ 21 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 21 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 21 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 21 12 rc_dp initial("010101"b), /* def section */ 21 13 rc_s initial("010110"b), /* symbol segment */ 21 14 rc_ns initial("010111"b), /* negative symbol */ 21 15 rc_is18 initial("011000"b), /* internal static 18 */ 21 16 rc_is15 initial("011001"b), /* internal static 15 */ 21 17 rc_lb initial("011000"b), /* link block */ 21 18 rc_nlb initial("011001"b), /* negative link block */ 21 19 rc_sr initial("011010"b), /* self relative */ 21 20 rc_e initial("011111"b)) /* escape */ 21 21 bit(6) int static options(constant); 21 22 21 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 2310 2311 2312 var = create_node (label_node, size (label)); 2313 p = addr (rands (var)); 2314 2315 p -> label.operand_type = rel_constant; 2316 p -> label.reloc = rc_t; 2317 p -> label.referenced, p -> label.referenced_executable, p -> label.is_addressable = "1"b; 2318 2319 return (var); 2320 2321 end create_rel_constant; 2322 2323 interpreter: 2324 procedure (); 2325 2326 /* Written by R. A. Barnes 1 January 1976 */ 2327 2328 dcl base fixed bin (18); /* subscript of arg1 */ 2329 dcl top fixed bin (18); /* subscript of op1 */ 2330 2331 dcl cur_frame ptr; /* ptr to current procedure frame */ 2332 dcl mac_base ptr; /* ptr to base of macro segment */ 2333 2334 dcl cs ptr; /* ptr to current subprogram node */ 2335 2336 dcl imac fixed bin (18); /* index into fort_cg_macros_ */ 2337 dcl ipol fixed bin (18); /* index into polish */ 2338 2339 dcl left fixed bin (18); /* left half of macro instructiin */ 2340 dcl mopnd fixed bin (18); /* operand index in macro instruction */ 2341 dcl mop fixed bin (18); 2342 2343 dcl next_free_array_ref fixed bin (18); 2344 dcl desc_temp_chain fixed bin (18) unsigned; 2345 2346 dcl op_code fixed bin (18); 2347 2348 dcl (i, k, n, op1, op2, next_base, relation, scan_proc, skip, temp, zarg, desc, eaq_name, regno, sym) fixed bin (18); 2349 dcl (cdt, dt, dt1, dt2) fixed bin (4); 2350 dcl char1 character (1); 2351 2352 dcl (p, s) ptr; 2353 dcl (b1, b2, err_flag, build_profile_after_label) bit (1) aligned; 2354 dcl bit3 bit (3) aligned; 2355 2356 dcl from_base_man bit (1) aligned; /* "1"b if base_man_load_pr is active */ 2357 2358 2359 dcl stack (300) fixed bin (18); 2360 2361 dcl ( 2362 fort_cg_macros_$first_scan, 2363 fort_cg_macros_$abort_list, 2364 fort_cg_macros_$error_macro 2365 ) bit (36) aligned external static; 2366 2367 dcl 1 fort_cg_macros_$interpreter_macros (4) aligned ext static, 2368 2 entry fixed bin (17) unal, 2369 2 pad fixed bin (17) unal; 2370 2371 dcl 1 fort_cg_macros_$operator_table (109) aligned ext static, 2372 2 entry fixed bin (17) unal, 2373 2 pad fixed bin (17) unal; 2374 2375 dcl 1 fort_instruction_info_$fort_instruction_info_ (0:1023) aligned ext static, 2376 2 pad1 bit (18) unal, 2377 2 directable bit (1) unal, 2378 2 pad2 bit (17) unal; 2379 2380 dcl ERROR fixed bin (18) int static options (constant) init (-1); 2381 /* ERROR operand */ 2382 2383 dcl mask_left bit (36) aligned int static options (constant) init ("000000777777"b3); 2384 2385 dcl ( 2386 first_base initial (2), 2387 last_base initial (6), 2388 escape_index initial (1), 2389 first_index initial (2), 2390 last_index initial (7), 2391 arg_ptr initial (26), 2392 descriptor_ptr initial (34) 2393 ) fixed binary (18) internal static options (constant); 2394 2395 dcl 1 fort_cg_macros_$single_inst (158) aligned ext static like machine_instruction; 2396 22 1 /* BEGIN INCLUDE FILE fort_single_inst_names.incl.pl1 */ 22 2 22 3 /* This include file defines symbol names for the instructions defined in 22 4* fort_single_inst.incl.alm. 22 5* 22 6* Written: 6 October 1980 by C R Davis. 22 7* 22 8* Modified: 22 June 1984, M Mabey - Install typeless functions support. 22 9* Modified: 1 October 1982, T Oke - add packed pointer load, easp, eawp, 22 10* llr, als, div. 22 11* Modified: 20 September 1982, T Oke - To add packed pointer store, epaq, 22 12* qrl, stq and lrl. 22 13* Modified: 06 Jan 83, HH - Add 'lcq'. 22 14**/ 22 15 22 16 declare 22 17 ( 22 18 eax0 initial (1), 22 19 lxl0 initial (9), 22 20 lxl1 initial (10), 22 21 sxl0 initial (17), 22 22 load_base (6) initial (25, 26, 27, 28, 29, 30), 22 23 load_inst (10) initial (31, 32, 33, 34, 35, 36, 37, 32, 31, 32), 22 24 stq initial (38), 22 25 store_inst (9) initial (38, 39, 40, 41, 42, 43, 44, 39, 38), 22 26 sta initial (39), 22 27 ind_to_a (10) initial (45, 46, 47, 48, 49, 50, 51, 52, 86, 87), 22 28 adfx1 initial (53), 22 29 sbfx1 initial (54), 22 30 stz initial (55), 22 31 asq initial (56), 22 32 store_base (6) initial (57, 58, 59, 60, 61, 62), 22 33 a9bd initial (63), 22 34 aos initial (64), 22 35 compare_inst (9) initial (65, 66, 67, 68, 69, 70, 71, 66, 65), 22 36 store_no_round_inst (9) 22 37 initial (38, 39, 40, 72, 73, 74, 44, 39, 38), 22 38 load_ind initial (75), 22 39 store_ind initial (76), 22 40 round_inst (4:6) initial (77, 78, 77), 22 41 add_base (6) initial (79, 80, 81, 82, 83, 84), 22 42 mpy initial (85), 22 43 adlx0 initial (88), 22 44 sblx0 initial (96), 22 45 cmpx0 initial (104), 22 46 eaq initial (112), 22 47 qrs initial (113), 22 48 anq initial (114), 22 49 orq initial (115), 22 50 orsq initial (116), 22 51 nop initial (117), 22 52 getlp initial (118), 22 53 store_packed_base(6)initial (119, 120, 121, 122, 123, 124), 22 54 epaq initial (125), 22 55 lrl initial (126), 22 56 qrl initial (127), 22 57 load_packed_base(6) initial (128, 129, 130, 131, 132, 133), 22 58 load_segment_num(6) initial (134, 135, 136, 137, 138, 139), 22 59 load_word_num (6) initial (140, 141, 142, 143, 144, 145), 22 60 llr initial (146), 22 61 als initial (147), 22 62 div initial (148), 22 63 lcq initial (149), 22 64 era initial (150), 22 65 erq initial (151), 22 66 ersa initial (152), 22 67 ersq initial (153), 22 68 alr initial (154), 22 69 ana initial (155), 22 70 lrs initial (156), 22 71 qls initial (157), 22 72 lca initial (158) 22 73 ) fixed binary (18) internal static options (constant); 22 74 22 75 /* END INCLUDE FILE fort_single_inst_names.incl.pl1 */ 2397 2398 2399 dcl dt_from_reg (18) fixed bin (4) int static options (constant) 2400 init (1, 5, 4, 2, 3, 2, 2, 1, 7, 0, 5, 5, 5, 5, 5, 5, 5, 5); 2401 2402 dcl eaq_name_to_reg (18) fixed bin internal static options (constant) 2403 initial (2, 1, 3, 3, 3, 3, 2, 1, 2, 4, 4, 4, 4, 4, 4, 4, 4, 4); 2404 2405 dcl ( 2406 A initial (1), 2407 Q initial (2), 2408 EAQ initial (3), 2409 IND initial (4) 2410 ) fixed bin (18) internal static options (constant); 2411 2412 dcl ( 2413 in_q init (1), /* integer value in the Q */ 2414 in_a init (2), /* logical value in the A */ 2415 in_aq init (3), /* complex value in the AQ */ 2416 in_eaq init (4), /* real value in the EAQ */ 2417 in_deaq init (5), /* dp value in the EAQ */ 2418 in_ieaq init (6), /* imag value in EAQ */ 2419 in_iq init (7), /* second word of doubleword in Q */ 2420 in_ia init (8), /* integer value in A */ 2421 in_tq init (9), /* typeless value in the Q */ 2422 in_ind init (10), /* wildcard for logical value in IND */ 2423 tze init (11), /* .eq. */ 2424 tnz init (12), /* .ne. */ 2425 tmi init (13), /* .lt. */ 2426 tpl init (14), /* .ge. */ 2427 tmoz init (15), /* .le. */ 2428 tpnz init (16), /* .gt. */ 2429 tnc init (17), /* j_l_s */ 2430 trc init (18) /* j_ge_s */ 2431 ) fixed bin (18) int static options (constant); 2432 2433 dcl ( /* op_base equ 361 */ 2434 allocate_char_string initial (361 + 0), 2435 reallocate_char_string initial (361 + 29), 2436 alloc_auto_adj initial (361 + 72), 2437 shorten_stack initial (361 + 163), 2438 long_profile initial (361 + 426), 2439 shorten_stack_protect_ind initial (361 + 451), 2440 VLA_words_per_seg initial (361 - 476) /* SPECIAL conversion */ 2441 ) fixed binary (14) internal static options (constant); 2442 2443 dcl shorten_stack_mask bit (14) aligned internal static options (constant) initial ("01000000010000"b); 2444 /* Reserve pr1,x1 */ 2445 dcl zero_for_dt (0:7) fixed bin (18); 2446 2447 dcl function fixed bin (18) int static init (13) options (constant); 2448 2449 dcl ( 2450 check_subscript init (1), 2451 subscript_mpy init (2), 2452 move_eis init (3), 2453 check_stringrange init (4) 2454 ) fixed bin (18) int static options (constant); 2455 2456 dcl entry_info_size fixed bin (18) int static init (7) options (constant); 2457 2458 dcl descriptor_mask_addr bit (36) aligned internal static options (constant) initial ("000250000100"b3); 2459 /* pr0|168 = 000077777777 */ 2460 2461 dcl (result, source) bit (72) aligned; 2462 2463 dcl based_integer fixed bin (35) based; 2464 2465 dcl 1 inst_address aligned like symbol.address; 2466 2467 dcl 1 saved_cat_address aligned like node.address automatic; 2468 2469 dcl char_temp char (8); 2470 2471 dcl int_image fixed bin (35) based; 2472 dcl real_image float bin (27) based; 2473 dcl dp_image float bin (63) based; 2474 dcl cmpx_image complex float bin (27) based; 2475 dcl bit_image bit (72) aligned based; 2476 2477 dcl ind_word bit (36) aligned based; 2478 2479 dcl 1 machine_state aligned, 2480 2 eaq (4), /* A, Q, EAQ, IND */ 2481 3 name fixed bin (18), 2482 3 number fixed bin (18), 2483 3 variable (4) fixed bin (18), 2484 3 reserved bit (1) aligned, 2485 2 rounded bit (1) aligned, 2486 2 indicators_valid fixed bin (18), 2487 2 value_in_xr bit (1) aligned, 2488 2 index_regs (0:7), 2489 3 bits structure unaligned, 2490 4 global bit (1), /* Not used */ 2491 4 reserved bit (1), 2492 4 mbz bit (34), 2493 3 type fixed bin (18), 2494 3 variable fixed bin (18), 2495 3 used fixed bin (18), 2496 3 offset fixed bin (18), 2497 2 address_in_base bit (1) aligned, 2498 2 base_regs (0:7), 2499 3 bits structure unaligned, 2500 4 global bit (1), /* Not used */ 2501 4 reserved bit (1), 2502 4 mbz bit (34), 2503 3 type fixed bin (18), 2504 3 variable fixed bin (18), 2505 3 used fixed bin (18), 2506 3 offset fixed bin (18), 2507 2 stack_extended bit (1) aligned, 2508 2 last_dynamic_temp fixed bin (18); 2509 2510 dcl 1 proc_frame based (cur_frame) aligned, 2511 2 node_type fixed bin (4) unal, 2512 2 flags structure unaligned, 2513 3 func bit (1), 2514 3 scan_interpreter_frame, 2515 4 interpreter_called bit (1) unal, 2516 4 scan_called bit (1) unal, 2517 3 pad bit (28) unal, 2518 2 prev ptr unal, 2519 2 next ptr unal, 2520 2 return fixed bin (18), 2521 2 base fixed bin (18), 2522 2 error_label fixed bin (18), 2523 2 interpreter_return label local, 2524 2 nshort fixed bin (18), 2525 2 short (3) fixed bin (18); 2526 2527 dcl 1 hast based (addr (macro_instruction (imac))), 2528 2 instruction_word bit (36) aligned, 2529 2 half_array (18) fixed bin (17) unaligned; 2530 2531 dcl 1 macro_instruction (0:262143) based (mac_base) aligned, 2532 2 left fixed bin (17) unal, /* left half - label or integer */ 2533 2 operand fixed bin (3) unal, 2534 2 eaq_name fixed bin (5) unal, 2535 2 inhibit bit (1) unal, 2536 2 op_code bit (7) unal; 2537 2538 dcl 1 machine_instruction (0:262143) based (mac_base) aligned, 2539 2 operand fixed bin (3) unal, 2540 2 increment fixed bin (13) unal, 2541 2 op_code bit (10) unal, 2542 2 inhibit bit (1) unal, 2543 2 ext_base_and_tag unal, 2544 3 ext_base bit (1) unal, 2545 3 tag bit (6) unal; 2546 2547 dcl 1 macro_dt_inst (0:262143) based (mac_base) aligned, 2548 2 number fixed bin (17) unal, 2549 2 data_type fixed bin (9) unal, 2550 2 inhibit bit (1) unal, 2551 2 op_code bit (7) unal; 2552 2553 dcl 1 macro_bits_inst (0:262143) based (mac_base) aligned, 2554 2 left fixed bin (17) unal, 2555 2 bits bit (10) unal, 2556 2 inhibit bit (1) unal, 2557 2 op_code bit (7) unal; 2558 2559 dcl 1 macro_if_inst (0:262143) based (mac_base) aligned, 2560 2 left fixed bin (17) unal, 2561 2 operand fixed bin (3) unal, 2562 2 relation bit (3) unal, 2563 2 with fixed bin (2) unal, 2564 2 inhibit bit (1) unal, 2565 2 op_code bit (7) unal; 2566 2567 dcl 1 macro_regs_inst (0:262143) based (mac_base) aligned, 2568 2 regs bit (18) unal, 2569 2 pad bit (10) unal, 2570 2 inhibit bit (1) unal, 2571 2 op_code bit (7) unal; 2572 2573 dcl 1 macro_cond_inst (0:262143) based (mac_base) aligned, 2574 2 left bit (18) unal, 2575 2 operand bit (4) unal, 2576 2 pad bit (5) unal, 2577 2 if_test bit (1) unal, 2578 2 inhibit bit (1) unal, 2579 2 op_code bit (7) unal; 2580 2581 dcl 1 instruction (0:262143) aligned based (object_base), 2582 2 base bit (3) unal, 2583 2 offset fixed bin (14) unal, 2584 2 op bit (10) unal, 2585 2 inhibit bit (1) unal, 2586 2 ext_base_and_tag unal, 2587 3 ext_base bit (1) unal, 2588 3 tag bit (6) unal; 2589 2590 dcl text_word (0:262143) bit (36) aligned based (object_base); 2591 2592 dcl 1 reloc (0:262143) aligned based (relocation_base), 2593 2 skip1 bit (12) unal, 2594 2 left_rel bit (6) unal, 2595 2 skip2 bit (12) unal, 2596 2 right_rel bit (6) unal; 2597 2598 dcl 1 half based aligned, 2599 2 left fixed bin (17) unal, 2600 2 right fixed bin (17) unal; 2601 2602 dcl 1 arg_list auto aligned, 2603 2 header aligned, 2604 3 arg_count fixed bin (17) unal, 2605 3 code bit (18) unal, 2606 3 desc_count fixed bin (17) unal, 2607 3 pad bit (18) unal, 2608 2 itp_list (254) like itp aligned; /* Big enough for 127 args 2609* and descriptors */ 2610 2611 dcl 1 entry_descriptor aligned, 2612 2 type_bits bit (12) unaligned, 2613 2 char_size bit (24) unaligned; 2614 2615 dcl (length, mod) builtin; 2616 23 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 23 2 23 3 /* This include file defines the relocation bits as bit (6) entities. See 23 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 23 5 23 6 dcl ( rc_a initial("000000"b), /* absolute */ 23 7 rc_t initial("010000"b), /* text */ 23 8 rc_nt initial("010001"b), /* negative text */ 23 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 23 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 23 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 23 12 rc_dp initial("010101"b), /* def section */ 23 13 rc_s initial("010110"b), /* symbol segment */ 23 14 rc_ns initial("010111"b), /* negative symbol */ 23 15 rc_is18 initial("011000"b), /* internal static 18 */ 23 16 rc_is15 initial("011001"b), /* internal static 15 */ 23 17 rc_lb initial("011000"b), /* link block */ 23 18 rc_nlb initial("011001"b), /* negative link block */ 23 19 rc_sr initial("011010"b), /* self relative */ 23 20 rc_e initial("011111"b)) /* escape */ 23 21 bit(6) int static options(constant); 23 22 23 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 2617 2618 2619 /* initialize cur_subprogram and friend */ 2620 2621 cur_subprogram = first_subprogram; 2622 cs = addr (rands (cur_subprogram)); 2623 call get_subr_options (cs); 2624 2625 /* initialize constant builtins */ 2626 2627 builtins (0) = create_integer_constant (0); 2628 builtins (1) = create_integer_constant (1); 2629 builtins (5) = create_constant (dp_mode, unspec (null)); 2630 builtins (6) = 0; 2631 builtins (7) = create_integer_constant (2); 2632 2633 /* initialize array of zero constants */ 2634 2635 zero_for_dt (0) = ERROR; /* for invalid register states */ 2636 zero_for_dt (1) = builtins (0); /* integer */ 2637 addr (result) -> real_image = 0.0; 2638 zero_for_dt (2) = create_constant (real_mode, result); 2639 /* real */ 2640 addr (result) -> dp_image = 0.0; 2641 zero_for_dt (3) = create_constant (dp_mode, result); 2642 /* double precision */ 2643 addr (result) -> cmpx_image = 0.0; 2644 zero_for_dt (4) = create_constant (cmpx_mode, result); 2645 /* complex */ 2646 result = "0"b; 2647 zero_for_dt (5) = create_constant (logical_mode, result); 2648 /* logical */ 2649 zero_for_dt (6) = ERROR; /* character */ 2650 zero_for_dt (7) = builtins (0); /* typeless */ 2651 2652 /* initialize automatic vars for this program */ 2653 2654 call initialize_auto; 2655 2656 /* initialize builtins for auto template and overlay */ 2657 2658 char_constant_length = 0; /* do not allocate the value field */ 2659 builtins (3) = create_node (char_constant_node, size (char_constant)); 2660 p = addr (rands (builtins (3))); 2661 p -> char_constant.operand_type = constant_type; 2662 p -> char_constant.data_type = char_mode; 2663 p -> char_constant.is_addressable, p -> char_constant.allocated = "1"b; 2664 p -> char_constant.location = auto_template; 2665 p -> char_constant.reloc = rc_t; 2666 p -> char_constant.length = 2667 chars_per_word * (addr (rands (last_subprogram)) -> subprogram.next_loc (2) - first_auto_var_loc); 2668 p -> char_constant.no_value_stored = "1"b; /* value is already in the text */ 2669 2670 builtins (4) = create_node (array_ref_node, size (array_ref)); 2671 p = addr (rands (builtins (4))); 2672 p -> array_ref.operand_type = array_ref_type; 2673 p -> array_ref.data_type = char_mode; 2674 p -> array_ref.is_addressable, p -> array_ref.allocated, p -> array_ref.ext_base = "1"b; 2675 p -> array_ref.base = sp; 2676 p -> array_ref.address.offset = first_auto_var_loc; 2677 if init_auto_to_zero 2678 then p -> array_ref.length = chars_per_word * (last_auto_loc - first_auto_var_loc); 2679 else p -> array_ref.length = addr (rands (builtins (3))) -> char_constant.length; 2680 p -> array_ref.ref_count = 131071; /* prevent deletion */ 2681 2682 builtins (8) = create_node (symbol_node, size (symbol)); 2683 p = addr (rands (builtins (8))); 2684 p -> symbol.operand_type = dummy; 2685 p -> symbol.by_compiler = "1"b; 2686 p -> symbol.allocated, p -> symbol.is_addressable, p -> symbol.ext_base = "1"b; 2687 p -> symbol.base = sp; 2688 2689 builtins (11) = create_node (symbol_node, size (symbol)); 2690 p = addr (rands (builtins (11))); 2691 p -> symbol.operand_type = variable_type; 2692 p -> symbol.data_type = int_mode; 2693 p -> symbol.by_compiler = "1"b; 2694 p -> symbol.needs_pointer = "1"b; 2695 p -> symbol.descriptor = "1"b; 2696 p -> symbol.address.ext_base = "1"b; 2697 2698 /* perform other initializations */ 2699 2700 next_free_array_ref = 0; 2701 desc_temp_chain = 0; 2702 build_profile_after_label, unspec (machine_state) = "0"b; 2703 from_base_man = "0"b; 2704 2705 /* initialize scanners */ 2706 2707 mac_base = ptr (addr (fort_cg_macros_$first_scan), 0); 2708 imac = fixed (rel (addr (fort_cg_macros_$first_scan)), 18) - 1; 2709 2710 /* get first procedure frame and initialize operand stack */ 2711 2712 cur_frame = null; 2713 2714 cur_frame = create_proc_frame (); 2715 2716 base, top = 0; 2717 2718 /* Set things up for the first program unit */ 2719 2720 call start_subprogram (); 2721 2722 /* MAIN LOOP! */ 2723 2724 do while ("1"b); 2725 2726 imac = imac + 1; 2727 2728 /* look at next instruction */ 2729 2730 loop: 2731 if ^macro_instruction (imac).inhibit 2732 then do; 2733 2734 /* have machine instruction */ 2735 2736 call emit_inst; 2737 go to step; 2738 end; 2739 2740 /* have macro instruction */ 2741 2742 mopnd = macro_instruction (imac).operand; 2743 left = macro_instruction (imac).left; 2744 mop = fixed (macro_instruction (imac).op_code, 7); 2745 2746 go to action (mop); 2747 2748 action (1): /* copy */ 2749 op1 = stack (get_operand (mopnd)); 2750 call copy (op1); 2751 go to step; 2752 2753 action (2): /* swap */ 2754 op1 = get_operand (mopnd); 2755 2756 k = stack (top); 2757 stack (top) = stack (op1); 2758 stack (op1) = k; 2759 2760 go to step; 2761 2762 action (3): /* pop */ 2763 op1 = get_operand (mopnd); 2764 call pop (op1); 2765 go to step; 2766 2767 action (4): /* push_temp */ 2768 dt = macro_dt_inst (imac).data_type; 2769 2770 if dt ^= 0 2771 then call push (assign_temp (dt)); 2772 2773 else do; 2774 2775 /* have block of words */ 2776 2777 if left < 0 2778 then do; 2779 2780 /* have count */ 2781 2782 left = stack (top) + bias; 2783 top = top - 1; 2784 end; 2785 call push (assign_block (left)); 2786 end; 2787 2788 go to step; 2789 2790 action (5): /* push_variable */ 2791 call push_variable ((macro_dt_inst (imac).data_type)); 2792 go to step; 2793 2794 action (6): /* dispatch for simple macro instructions */ 2795 go to simple (left); 2796 2797 simple (1): /* push_label */ 2798 simple (2): /* push_rel_constant */ 2799 call push (create_rel_constant ()); 2800 go to step; 2801 2802 action (8): /* push_constant */ 2803 dt = macro_dt_inst (imac).data_type; 2804 2805 if dt ^= 0 2806 then do; 2807 call push (create_constant (dt, addr (machine_instruction (imac + 1)) -> bit_image)); 2808 imac = imac + data_type_size (dt); 2809 end; 2810 2811 else do; 2812 if left < 0 2813 then do; 2814 left = stack (top) + bias; 2815 top = top - 1; 2816 end; 2817 call print_message (427, "push_constant_block"); 2818 end; 2819 2820 go to step; 2821 2822 action (9): /* convert_constant */ 2823 source = addr (rands (stack (top))) -> constant.value; 2824 cdt = addr (rands (stack (top))) -> constant.data_type; 2825 dt = macro_dt_inst (imac).data_type; 2826 result = conv_round (dt, cdt) ((source), 0); 2827 2828 stack (top) = create_constant (dt, result); 2829 go to step; 2830 2831 action (54): /* push_count */ 2832 call push (left - bias); 2833 go to step; 2834 2835 action (10): /* push_count_indexed */ 2836 op1 = get_operand (mopnd); 2837 i = stack (op1) + bias; 2838 2839 if i <= 0 | i > left 2840 then call print_message (402, "push_count_indexed"); 2841 2842 call push (half_array (i) - bias); 2843 2844 imac = imac + divide (left + 1, 2, 17, 0); 2845 go to step; 2846 2847 action (11): /* push_builtin */ 2848 call push ((builtins (left))); 2849 go to step; 2850 2851 action (14): /* call */ 2852 action (70): 2853 if mop = 14 2854 then call setup_call (left, imac, 0, 0); 2855 else do; 2856 imac = imac + 1; 2857 call setup_call (left, imac, (macro_instruction (imac).left), 0); 2858 end; 2859 2860 imac = left; 2861 go to step; 2862 2863 action (15): /* return */ 2864 if left = 0 2865 then do; 2866 2867 /* should be a proc invocation */ 2868 2869 if proc_frame.func 2870 then call print_message (403); 2871 2872 call pop (base); 2873 end; 2874 2875 else do; 2876 2877 /* should be a func invocation */ 2878 2879 if ^proc_frame.func 2880 then call print_message (404); 2881 2882 i = macro_instruction (imac).eaq_name; 2883 if i = 0 2884 then do; 2885 2886 /* return operand name */ 2887 2888 op1 = get_operand (mopnd); 2889 2890 k = stack (op1); 2891 stack (op1) = stack (base); 2892 if k < 0 2893 then stack (base) = create_integer_constant (k + bias); 2894 else stack (base) = k; 2895 2896 call pop (base + 1); 2897 end; 2898 2899 else do; 2900 2901 /* return eaq_name */ 2902 2903 call pop (base); 2904 2905 dt = dt_from_reg (i); 2906 temp = assign_temp (dt); 2907 call push (temp); 2908 2909 call in_reg (temp, i); 2910 end; 2911 end; 2912 2913 p = cur_frame; 2914 2915 call pop_frame; 2916 2917 /* now, actually return */ 2918 2919 imac = p -> proc_frame.return; 2920 2921 if p -> proc_frame.interpreter_called 2922 then do; 2923 err_flag = "0"b; 2924 go to p -> proc_frame.interpreter_return; 2925 end; 2926 2927 go to step; 2928 2929 action (16): /* jump */ 2930 imac = left; 2931 go to loop; 2932 2933 action (17): /* scan */ 2934 rescan: 2935 do while (polish (ipol) < 0 | polish (ipol) > last_assigned_op); 2936 2937 /* have a count or operand */ 2938 2939 call push (effective_operand (polish (ipol))); 2940 ipol = ipol + 1; 2941 end; 2942 2943 /* we have an operator */ 2944 2945 op_code = polish (ipol); 2946 ipol = ipol + 1; 2947 2948 scan_proc = fort_cg_macros_$operator_table (op_code).entry; 2949 2950 next_base = get_nextbase (scan_proc); 2951 2952 do i = next_base repeat i + 1 while (i <= top & stack (i) ^= ERROR); 2953 end; 2954 2955 if i <= top 2956 then do; 2957 call pop (next_base); 2958 2959 if fixed (macro_instruction (scan_proc).op_code, 7) = function 2960 then call push (ERROR); 2961 2962 i = macro_instruction (scan_proc).left; 2963 if i = 0 2964 then go to rescan; 2965 2966 call setup_call (i, imac - 1, left, 0); 2967 imac = i; 2968 end; 2969 2970 else do; 2971 call setup_call (scan_proc, imac - 1, left, next_base); 2972 imac = scan_proc; 2973 end; 2974 2975 proc_frame.scan_called = "1"b; 2976 go to step; 2977 2978 action (18): /* exit */ 2979 if proc_frame.func 2980 then call print_message (405); 2981 else if ^proc_frame.scan_called 2982 then call print_message (406); 2983 2984 call pop (base); 2985 2986 imac = proc_frame.return + left; 2987 2988 call pop_frame; 2989 go to step; 2990 2991 action (19): /* s_call */ 2992 proc_frame.nshort = proc_frame.nshort + 1; 2993 if proc_frame.nshort > hbound (proc_frame.short, 1) 2994 then call print_message (407, "s_call stack", hbound (proc_frame.short, 1) - bias); 2995 else proc_frame.short (proc_frame.nshort) = imac; 2996 imac = left; 2997 go to loop; 2998 2999 simple (3): /* s_return */ 3000 if proc_frame.nshort < 0 3001 then call print_message (408); 3002 else do; 3003 imac = proc_frame.short (proc_frame.nshort); 3004 proc_frame.nshort = proc_frame.nshort - 1; 3005 end; 3006 3007 go to step; 3008 3009 action (21): /* if_dt */ 3010 b2 = "1"b; 3011 go to dt_join; 3012 3013 action (22): /* unless_dt */ 3014 b2 = "0"b; 3015 3016 dt_join: 3017 i = addr (rands (stack (top))) -> symbol.data_type; 3018 3019 if i <= 0 | i > length (macro_bits_inst (imac).bits) 3020 then call print_message (445, stack (top), "data_type"); 3021 else b1 = substr (macro_bits_inst (imac).bits, i, 1); 3022 3023 go to if_join; 3024 3025 action (23): /* if_optype */ 3026 b2 = "1"b; 3027 go to optype_join; 3028 3029 action (24): /* unless_optype */ 3030 b2 = "0"b; 3031 3032 optype_join: 3033 if stack (top) > 0 /* item can be operand or count */ 3034 then do; 3035 i = addr (rands (stack (top))) -> symbol.operand_type; 3036 /* an operand */ 3037 3038 if i <= 0 | i > length (macro_bits_inst (imac).bits) 3039 then do; 3040 call print_message (445, stack (top), "operand_type"); 3041 stop; 3042 end; 3043 end; 3044 3045 else i = count_type; /* a count */ 3046 3047 b1 = substr (macro_bits_inst (imac).bits, i, 1); 3048 3049 go to if_join; 3050 3051 action (25): /* (if unless)_array */ 3052 b2 = macro_cond_inst (imac).if_test; 3053 p = addr (rands (stack (top))); 3054 if p -> node.node_type = symbol_node 3055 then b1 = p -> symbol.dimensioned; 3056 else b1 = "0"b; 3057 go to if_join; 3058 3059 action (26): /* (if unless)_aligned */ 3060 b2 = macro_cond_inst (imac).if_test; 3061 p = addr (rands (stack (get_operand (mopnd)))); 3062 3063 if p -> node.units = char_units 3064 then do; 3065 if p -> node.node_type = symbol_node 3066 then if p -> symbol.parameter 3067 then b1 = "0"b; 3068 else b1 = (p -> symbol.address.char_num = 0); 3069 3070 else if p -> node.node_type = array_ref_node 3071 then if addr (rands (p -> array_ref.parent)) -> symbol.parameter 3072 then b1 = "0"b; 3073 else b1 = (p -> array_ref.address.char_num = 0 & ^cs -> subprogram.options.ansi_77); 3074 3075 else b1 = (p -> node.address.char_num = 0); 3076 end; 3077 else b1 = "1"b; 3078 3079 go to if_join; 3080 3081 action (27): /* if_eaq */ 3082 b2 = "1"b; 3083 go to eaq_join; 3084 3085 action (28): /* unless_eaq */ 3086 b2 = "0"b; 3087 3088 eaq_join: 3089 op1 = stack (get_operand (mopnd)); 3090 3091 if addr (rands (op1)) -> node.value_in.eaq 3092 then do; 3093 eaq_name = get_eaq_name (op1); 3094 if macro_instruction (imac).eaq_name = in_ind 3095 then b1 = (eaq_name > in_ind); 3096 else b1 = (eaq_name = macro_instruction (imac).eaq_name); 3097 end; 3098 else b1 = "0"b; /* op1 not in any eaq register */ 3099 go to if_join; 3100 3101 action (29): /* dt_jump */ 3102 dt1 = addr (rands (stack (top))) -> symbol.data_type; 3103 dt2 = addr (rands (stack (top - 1))) -> symbol.data_type; 3104 3105 if dt1 <= 0 3106 then call print_message (445, stack (top), "data_type"); 3107 3108 else if dt2 <= 0 3109 then call print_message (445, stack (top - 1), "data_type"); 3110 3111 else if dt1 = typeless_mode 3112 then i = 19; 3113 3114 else if dt1 > cmpx_mode 3115 then i = 17; 3116 3117 else if dt2 = typeless_mode 3118 then i = 20; 3119 3120 else if dt2 > cmpx_mode 3121 then i = 18; 3122 3123 else i = 4 * (dt1 - 1) + dt2; 3124 3125 imac = half_array (i); 3126 go to loop; 3127 3128 action (124): /* dt_jump1 */ 3129 dt = addr (rands (stack (get_operand (mopnd)))) -> symbol.data_type; 3130 3131 if dt <= 0 | dt > last_assigned_mode 3132 then do; 3133 call print_message (445, stack (get_operand (mopnd)), "data_type"); 3134 stop; 3135 end; 3136 3137 imac = half_array (dt); 3138 goto loop; 3139 3140 action (30): /* ind_jump */ 3141 if machine_state.eaq (IND).name < tze 3142 then call print_message (409); 3143 else imac = half_array (machine_state.eaq (IND).name - tze + 1); 3144 3145 go to loop; 3146 3147 action (72): /* if_ind */ 3148 b2 = "1"b; 3149 go to ind_join; 3150 3151 action (73): /* unless_ind */ 3152 b2 = "0"b; 3153 3154 ind_join: 3155 if machine_state.eaq (IND).name >= in_ind & machine_state.eaq (IND).number > 0 3156 then call print_message (410); 3157 3158 eaq_name = macro_instruction (imac).eaq_name; 3159 regno = eaq_name_to_reg (eaq_name); 3160 b1 = (machine_state.indicators_valid = regno); 3161 go to if_join; 3162 3163 action (81): /* (if unless)_parameter */ 3164 b2 = macro_cond_inst (imac).if_test; 3165 op1 = get_operand (mopnd); 3166 b1 = addr (rands (stack (op1))) -> symbol.parameter; 3167 go to if_join; 3168 3169 action (85): /* (if unless)_negative */ 3170 b2 = macro_cond_inst (imac).if_test; 3171 op1 = get_operand (mopnd); 3172 b1 = check_negative (stack (op1)); 3173 go to if_join; 3174 3175 action (87): /* (if unless)_local */ 3176 b2 = macro_cond_inst (imac).if_test; 3177 op1 = stack (get_operand (mopnd)); 3178 b1 = addr (rands (op1)) -> symbol.external & addr (rands (op1)) -> symbol.initial > 0; 3179 go to if_join; 3180 3181 action (89): /* (if unless)_main */ 3182 b2 = macro_cond_inst (imac).if_test; 3183 b1 = cs -> subprogram.subprogram_type = main_program; 3184 go to if_join; 3185 3186 action (95): /* (if unless)_needs_descriptors */ 3187 b2 = macro_cond_inst (imac).if_test; 3188 op1 = stack (get_operand (mopnd)); 3189 b1 = addr (rands (op1)) -> symbol.needs_descriptors; 3190 go to if_join; 3191 3192 action (99): /* (if unless)_namelist_used */ 3193 b2 = macro_cond_inst (imac).if_test; 3194 b1 = cs -> subprogram.namelist_used; 3195 go to if_join; 3196 3197 action (31): /* if */ 3198 b2 = "1"b; 3199 go to unless_join; 3200 3201 action (32): /* unless */ 3202 b2 = "0"b; 3203 3204 unless_join: 3205 op1 = get_operand (mopnd); 3206 op1 = stack (op1) + bias; 3207 3208 op2 = macro_if_inst (imac).with; 3209 if op2 = 3 3210 then op2 = stack (top) + bias; 3211 3212 relation = fixed (macro_if_inst (imac).relation, 3); 3213 go to comp (relation); 3214 3215 comp (0): 3216 b1 = op1 < op2; 3217 go to if_join; 3218 3219 comp (1): 3220 b1 = op1 > op2; 3221 go to if_join; 3222 3223 comp (2): 3224 b1 = op1 = op2; 3225 go to if_join; 3226 3227 comp (3): 3228 b1 = op1 ^= op2; 3229 go to if_join; 3230 3231 comp (4): 3232 b1 = op1 <= op2; 3233 go to if_join; 3234 3235 comp (5): 3236 b1 = op1 >= op2; 3237 3238 if_join: 3239 if b1 = b2 3240 then do; 3241 imac = left; 3242 go to loop; 3243 end; 3244 3245 go to step; 3246 3247 action (33): /* jump_indexed */ 3248 op1 = get_operand (mopnd); 3249 i = stack (op1) + bias; 3250 3251 if i <= 0 | i > left 3252 then call print_message (402, "jump_indexed"); 3253 else imac = half_array (i); 3254 3255 go to loop; 3256 3257 action (34): /* emit */ 3258 do imac = imac + 1 to imac + left; 3259 text_word (text_pos) = unspec (machine_instruction (imac)); 3260 text_pos = text_pos + 1; 3261 end; 3262 go to loop; 3263 3264 action (78): /* assign_entry */ 3265 op1 = get_operand (mopnd); 3266 call reset_regs; 3267 goto label_join; 3268 3269 action (35): /* label */ 3270 op1 = get_operand (mopnd); 3271 3272 if addr (rands (stack (op1))) -> label.referenced_executable 3273 /* reset only if label is used */ 3274 then call reset_regs; 3275 goto label_join; 3276 3277 action (36): /* relcon */ 3278 op1 = get_operand (mopnd); 3279 3280 label_join: 3281 call alloc_label (op1, text_pos); 3282 3283 if addr (rands (stack (op1))) -> label.restore_prs 3284 /* is this label the target of a non-local goto */ 3285 then call emit_zero (getlp); /* yes, restore frozen register (pr4) */ 3286 3287 if build_profile_after_label 3288 then do; 3289 call build_profile_entry; 3290 build_profile_after_label = "0"b; 3291 end; 3292 go to step; 3293 3294 action (37): /* set_rel_constant */ 3295 op1 = get_operand (mopnd); 3296 call alloc_label (op1, stack (top) + bias); 3297 top = top - 1; 3298 go to step; 3299 3300 action (38): /* add_to_address */ 3301 if left = 0 3302 then do; 3303 instruction (text_pos - 1).offset = instruction (text_pos - 1).offset + stack (top) + bias; 3304 top = top - 1; 3305 end; 3306 3307 else do; 3308 op1 = get_operand (mopnd); 3309 p = addr (rands (stack (op1))); 3310 3311 if p -> label.operand_type ^= rel_constant 3312 then call print_message (411, stack (op1)); 3313 3314 i = p -> label.location + stack (top - 1) + bias; 3315 instruction (i).offset = instruction (i).offset + stack (top) + bias; 3316 3317 top = top - 2; 3318 end; 3319 3320 go to step; 3321 3322 action (39): /* insert_bits */ 3323 call print_message (424, "insert_bits"); 3324 go to step; 3325 3326 action (40): /* reserve_regs */ 3327 call reserve_regs ((macro_regs_inst (imac).regs)); 3328 go to step; 3329 3330 action (41): /* load_pr */ 3331 op1 = stack (get_operand (mopnd)); 3332 3333 if assembly_list & addr (rands (op1)) -> node.node_type = symbol_node 3334 then a_name (text_pos) = op1; 3335 3336 call base_man_load_pr (op1, left); 3337 go to step; 3338 3339 action (112): /* load_pr_value */ 3340 op1 = stack (get_operand (mopnd)); 3341 3342 if assembly_list & addr (rands (op1)) -> node.node_type = symbol_node 3343 then a_name (text_pos) = op1; 3344 3345 call base_man_load_pr_value (op1, left); 3346 go to step; 3347 3348 simple (49): /* desc_ptr_in_pr3 */ 3349 machine_state.base_regs (which_base (3)).type = 9; 3350 machine_state.base_regs (which_base (3)).used = text_pos; 3351 machine_state.base_regs (which_base (3)).variable = 0; 3352 machine_state.base_regs (which_base (3)).offset = 0; 3353 go to step; 3354 3355 simple (50): /* arg_ptr_in_pr1 */ 3356 machine_state.base_regs (which_base (1)).type = 5; 3357 machine_state.base_regs (which_base (1)).used = text_pos; 3358 machine_state.base_regs (which_base (1)).variable = 0; 3359 machine_state.base_regs (which_base (1)).offset = 0; 3360 go to step; 3361 3362 simple (4): /* free_regs */ 3363 call free_regs; 3364 go to step; 3365 3366 simple (5): /* reset_regs */ 3367 call reset_regs; 3368 go to step; 3369 3370 action (44): /* make_addressable */ 3371 action (71): 3372 op1 = get_operand (mopnd); 3373 call m_a (addr (rands (stack (op1)))); 3374 3375 if mop = 71 3376 then do; 3377 op2 = get_operand ((machine_instruction (imac).operand)); 3378 call m_a (addr (rands (stack (op2)))); 3379 end; 3380 3381 go to step; 3382 3383 action (45): /* use_eaq */ 3384 call use_eaq (0); 3385 go to step; 3386 3387 action (46): /* load */ 3388 op1 = stack (get_operand (mopnd)); 3389 3390 if op1 < 0 /* a count */ 3391 then op1 = create_integer_constant (op1 + bias); 3392 3393 call load (op1, (macro_instruction (imac).eaq_name)); 3394 go to step; 3395 3396 simple (22): /* safe_load */ 3397 call print_message (424, "safe_load"); 3398 go to step; 3399 3400 action (47): /* load_top */ 3401 eaq_name = macro_instruction (imac).eaq_name;/* Copy in case imac is changed */ 3402 temp = 0; /* swap flag */ 3403 3404 /* If loading into the A, get temps in IND out first */ 3405 3406 if eaq_name = in_a 3407 then if machine_state.eaq (IND).number > 0 3408 then if addr (rands (stack (top))) -> node.value_in.eaq 3409 then if addr (rands (stack (top - 1))) -> node.value_in.eaq 3410 then call use_ind (); 3411 3412 /* If both operands are in the eaq, check the eaq names 3413* and swap if the top operand is the wrong name but the 3414* lower one is the right name. */ 3415 3416 if addr (rands (stack (top))) -> node.value_in.eaq 3417 then if addr (rands (stack (top - 1))) -> node.value_in.eaq 3418 then if get_eaq_name (stack (top)) ^= eaq_name 3419 then if get_eaq_name (stack (top - 1)) = eaq_name 3420 then temp = 1; 3421 3422 /* If the top operand is not in the eaq, and the lower one is 3423* or if the top operand is a constant, swap the operands. */ 3424 3425 if ^addr (rands (stack (top))) -> node.value_in.eaq 3426 then if addr (rands (stack (top - 1))) -> node.value_in.eaq 3427 | addr (rands (stack (top))) -> node.node_type = constant_node 3428 | addr (rands (stack (top))) -> node.node_type = char_constant_node 3429 then temp = 1; 3430 3431 if temp > 0 3432 then do; 3433 k = stack (top - 1); 3434 stack (top - 1) = stack (top); 3435 stack (top) = k; 3436 3437 /* If operands are swapped and a label is given, transfer to that label. */ 3438 3439 if left > 0 3440 then imac = left - 1; 3441 end; 3442 3443 call load ((stack (top)), eaq_name); 3444 3445 go to step; 3446 3447 action (113): /* load_for_test */ 3448 op1 = stack (get_operand (mopnd)); 3449 op2 = macro_instruction (imac).eaq_name; 3450 regno = eaq_name_to_reg (op2); 3451 3452 call load (op1, op2); 3453 3454 /* if indicators are invalid, set them with a compare */ 3455 3456 if machine_state.indicators_valid ^= regno 3457 then do; 3458 call emit_single ((compare_inst (op2)), (zero_for_dt (dt_from_reg (op2)))); 3459 machine_state.indicators_valid = regno; 3460 end; 3461 3462 goto step; 3463 3464 action (111): /* store */ 3465 op1 = stack (get_operand (mopnd)); 3466 call store (op1, (macro_instruction (imac).eaq_name), left); 3467 go to step; 3468 3469 action (48): /* in_reg */ 3470 op1 = stack (get_operand (mopnd)); 3471 call in_reg (op1, (macro_instruction (imac).eaq_name)); 3472 go to step; 3473 3474 action (105): /* compare */ 3475 op1 = stack (get_operand (mopnd)); 3476 if op1 < 0 /* a count */ 3477 then op1 = create_integer_constant (op1 + bias); 3478 b1 = (op1 = zero_for_dt (addr (rands (op1)) -> node.data_type)); 3479 eaq_name = macro_instruction (imac).eaq_name; 3480 regno = eaq_name_to_reg (eaq_name); 3481 3482 if machine_state.indicators_valid ^= regno | ^b1 3483 then do; 3484 3485 if do_rounding & ^machine_state.rounded 3486 then if (eaq_name = in_eaq) | (eaq_name = in_deaq) 3487 then if (eaq_name = machine_state.eaq (regno).name) | (eaq_name ^= in_deaq) 3488 | (machine_state.eaq (regno).name = 0) 3489 then do; 3490 if machine_state.eaq (regno).name ^= 0 3491 then i = round_inst (machine_state.eaq (regno).name); 3492 else i = round_inst (eaq_name); 3493 call emit_zero (i); 3494 machine_state.rounded = "1"b; 3495 end; 3496 3497 call emit_single ((compare_inst (eaq_name)), op1); 3498 3499 if b1 3500 then machine_state.indicators_valid = regno; 3501 else machine_state.indicators_valid = 0; 3502 3503 end; 3504 3505 go to step; 3506 3507 simple (6): /* reset_eaq */ 3508 call reset_eaq (EAQ); 3509 call reset_eaq (IND); 3510 go to step; 3511 3512 simple (7): /* use_ind */ 3513 call use_ind; 3514 go to step; 3515 3516 action (20): /* set_inds_valid */ 3517 eaq_name = macro_instruction (imac).eaq_name; 3518 machine_state.indicators_valid = eaq_name_to_reg (eaq_name); 3519 go to step; 3520 3521 action (51): /* increment */ 3522 op1 = get_operand (mopnd); 3523 stack (op1) = stack (op1) + left; 3524 go to step; 3525 3526 action (52): /* decrement */ 3527 op1 = get_operand (mopnd); 3528 stack (op1) = stack (op1) - left; 3529 go to step; 3530 3531 action (53): /* multiply */ 3532 op1 = get_operand (mopnd); 3533 3534 k = (stack (op1) + bias) * left; /* form product */ 3535 if k >= bias 3536 then call print_message (433, stack (op1), left - bias); 3537 /* product is too large to be count */ 3538 else stack (op1) = k - bias; /* product ok */ 3539 go to step; 3540 3541 simple (28): /* skip_data */ 3542 ipol = ipol + polish (ipol) + 1; 3543 go to step; 3544 3545 action (50): /* push_sf_arg_count */ 3546 action (55): /* push_bif_index */ 3547 op1 = get_operand (mopnd); 3548 i = addr (rands (stack (op1))) -> symbol.char_size - bias; 3549 call push (i); 3550 go to step; 3551 3552 simple (8): /* start_subscript */ 3553 call start_subscript; 3554 go to step; 3555 3556 simple (9): /* next_subscript */ 3557 call next_subscript; 3558 go to step; 3559 3560 simple (10): /* finish_subscript */ 3561 call finish_subscript; 3562 go to step; 3563 3564 simple (11): /* subscript_error */ 3565 call signal_error; 3566 go to step; 3567 3568 simple (21): /* optimized_subscript */ 3569 call print_message (424, "optimized_subscript"); 3570 goto step; 3571 3572 simple (39): /* make_substring */ 3573 call make_substring (); 3574 go to step; 3575 3576 simple (12): /* s_func_finish */ 3577 free_temps (1), free_temps (2), free_temps (3) = 0; 3578 go to step; 3579 3580 action (61): /* s_func_label */ 3581 op1 = get_operand (mopnd); 3582 addr (rands (stack (op1))) -> symbol.initial = stack (top); 3583 go to step; 3584 3585 action (62): /* push_s_func_label */ 3586 op1 = get_operand (mopnd); 3587 call push ((addr (rands (stack (op1))) -> symbol.initial)); 3588 go to step; 3589 3590 action (63): /* push_s_func_var */ 3591 op1 = stack (get_operand (mopnd)); 3592 3593 do i = 1 to stack (top) + bias; 3594 p = addr (rands (op1)); 3595 if p -> symbol.next_member = 0 3596 then do; 3597 imac = left; 3598 go to loop; 3599 end; 3600 3601 op1 = p -> symbol.next_member; 3602 end; 3603 3604 call push (op1); 3605 3606 go to step; 3607 3608 action (64): /* push_array_size */ 3609 op1 = get_operand (mopnd); 3610 p = addr (rands (stack (op1))); 3611 p = addr (rands (p -> symbol.dimension)); 3612 3613 if p -> dimension.variable_array_size 3614 then op1 = p -> dimension.array_size; 3615 else op1 = create_integer_constant ((p -> dimension.array_size)); 3616 3617 call push (op1); 3618 go to step; 3619 3620 action (65): /* print */ 3621 call setup_message_structure; 3622 call print_message_op; 3623 go to step; 3624 3625 /* NOTE - This code was modified on 26 May 1977 by DSL to conflict with the documented 3626* actions for this macro. 3627* 3628* In the case of the frame called by scan being a "FUNC" frame, the error 3629* macro now pushes an ERROR operand whether or not the error_label for 3630* the scan was "continue". 3631* */ 3632 action (66): /* error */ 3633 if left ^= 0 3634 then do; 3635 call setup_message_structure; 3636 call print_message_op; 3637 end; 3638 3639 do while (proc_frame.error_label = 0); 3640 cur_frame = proc_frame.prev; 3641 end; 3642 3643 call pop (proc_frame.base); 3644 3645 p = cur_frame; 3646 3647 call pop_frame; 3648 3649 if p -> proc_frame.scan_called 3650 then if p -> proc_frame.func 3651 then call push (ERROR); 3652 3653 if ^p -> proc_frame.interpreter_called 3654 then do; 3655 imac = p -> proc_frame.error_label; 3656 go to loop; 3657 end; 3658 3659 else do; 3660 err_flag = "1"b; 3661 imac = p -> proc_frame.return; 3662 go to p -> proc_frame.interpreter_return; 3663 end; 3664 3665 action (68): /* push_length */ 3666 op1 = get_char_size (addr (rands (stack (get_operand (mopnd))))); 3667 if op1 > 0 /* Not a count */ 3668 then do; 3669 p = addr (rands (op1)); 3670 if p -> node.node_type = temporary_node 3671 then p -> temporary.ref_count = p -> temporary.ref_count + 1; 3672 end; 3673 3674 call push (op1); 3675 go to step; 3676 3677 action (7): /* emit_eis */ 3678 call emit_eis; 3679 go to step; 3680 3681 simple (13): /* end_unit */ 3682 if top ^= 0 | base > 1 3683 then call print_message (425); 3684 3685 cur_subprogram = cs -> subprogram.next_subprogram; 3686 if cur_subprogram = 0 3687 then return; 3688 3689 call start_subprogram (); 3690 3691 go to step; 3692 3693 action (76): /* make_io_desc */ 3694 result = macro_regs_inst (imac).regs | bit (fixed (stack (top) + bias, 36), 36); 3695 stack (top) = create_constant (int_mode, result); 3696 go to step; 3697 3698 action (77): /* (if unless)_one_word_dt */ 3699 b2 = macro_cond_inst (imac).if_test; 3700 b1 = one_word_dt (stack (get_operand (mopnd))); 3701 goto if_join; 3702 3703 simple (14): /* stat */ 3704 cur_statement = ipol - 1; 3705 addr (polish (cur_statement)) -> statement.location = bit (text_pos, 18); 3706 ipol = ipol + (size (statement) - 1); 3707 3708 if generate_profile 3709 then if addr (polish (cur_statement)) -> statement.put_in_profile 3710 then if polish (ipol + 1) = label_op 3711 then build_profile_after_label = "1"b; 3712 else call build_profile_entry; 3713 go to step; 3714 3715 simple (15): /* check_parameters */ 3716 /*** Expects: 3717* 3718* count of parameters 3719* param1 3720* param2 3721* . 3722* . 3723* . 3724* paramn ***/ 3725 zarg = base; 3726 n = stack (zarg) + bias; 3727 3728 /* Perform entry descriptor processing to fill in arguments. */ 3729 /* We will put the node offset to the descriptor into the text section. 3730* gen_entry_defs will later fill in the true text offset from the allocated 3731* nodes. */ 3732 /* NOTE. We depend upon parm_desc_ptrsp being left set to the descriptor 3733* block. This is a relatively safe assumption however. */ 3734 3735 do i = 1 to n; 3736 parm_desc_ptrs.descriptor_relp (i) = make_entry_descriptor ((stack (zarg + i))); 3737 3738 k = fixed (rel (addr (parm_desc_ptrs.descriptor_relp (i)))); 3739 if mod (i, 2) = 0 3740 then reloc (k).left_rel = rc_t; 3741 else reloc (k).right_rel = rc_t; 3742 end; 3743 3744 /* Next store pointers to multi-position parameters, and VLA 3745* parameters. */ 3746 3747 do i = 1 to n; 3748 p = addr (rands (stack (zarg + i))); 3749 3750 if assembly_list & p -> node.node_type = symbol_node 3751 then a_name (text_pos) = stack (zarg + i); 3752 3753 if p -> node.node_type = symbol_node 3754 then if p -> symbol.VLA 3755 then do; 3756 3757 /* Store pointers to Very Large Array parameters in the 3758* VLA pointer blocks. */ 3759 3760 bit3 = base_man_load_any_pr (2, 2 * i, 0); 3761 sym = addr (rands (p -> symbol.dimension)) -> dimension.VLA_base_addressor; 3762 s = addr (rands (sym)); 3763 if VLA_is_256K 3764 then call emit_c_a_var ((store_packed_base (which_base (fixed (bit3, 3)))), s); 3765 else do; /* 255K addressing */ 3766 if assembly_list 3767 then a_name (text_pos) = fixed (rel (p)); 3768 unspec (inst_address) = "0"b; 3769 inst_address.base = bit3; 3770 inst_address.ext_base = "1"b; 3771 call emit_c_a ((epaq), unspec (inst_address)); 3772 call emit_single ((qrl), 18 - bias); 3773 call emit_c_a_var ((stq), s); 3774 call emit_single ((lrl), 54 - bias); 3775 inst_address.base = "000"b; 3776 inst_address.offset = VLA_words_per_seg; 3777 call emit_c_a ((mpy), unspec (inst_address)); 3778 call emit_c_a_var ((asq), s); 3779 if assembly_list 3780 then a_name (text_pos) = fixed (rel (p)); 3781 call emit_c_a ((store_packed_base (which_base (fixed (bit3, 3)))), 3782 c_a ((p -> symbol.address.offset), 6)); 3783 end; 3784 end; 3785 3786 else if p -> symbol.stack_indirect 3787 then do; 3788 bit3 = base_man_load_any_pr (2, 2 * i, 0); 3789 if assembly_list & p -> node.node_type = symbol_node 3790 then a_name (text_pos) = stack (zarg + i); 3791 call emit_c_a ((store_base (which_base (fixed (bit3, 3)))), c_a ((p -> symbol.location), 6)) 3792 ; 3793 end; 3794 end; 3795 3796 /* Next store length of star extent character strings */ 3797 3798 do i = 1 to n; 3799 p = addr (rands (stack (zarg + i))); 3800 if p -> node.node_type = symbol_node 3801 then if p -> symbol.v_length ^= 0 3802 then do; 3803 if assembly_list & p -> node.node_type = symbol_node 3804 then a_name (text_pos) = stack (zarg + i); 3805 call get_param_char_size (p, i); 3806 end; 3807 end; 3808 3809 /* Finally compute bounds, etc. of variable extent arrays */ 3810 3811 do i = 1 to n; 3812 p = addr (rands (stack (zarg + i))); 3813 if p -> node.node_type = symbol_node 3814 then if p -> symbol.dimensioned 3815 then if p -> symbol.variable_extents | p -> symbol.star_extents 3816 then if p -> symbol.allocate 3817 then do; 3818 if assembly_list & p -> node.node_type = symbol_node 3819 then a_name (text_pos) = stack (zarg + i); 3820 call get_param_array_size (p); 3821 end; 3822 end; 3823 3824 /* Last but not least emit code for star extent function allocation. */ 3825 3826 if cs -> subprogram.star_extent_function 3827 then do; 3828 p = addr (rands (cs -> subprogram.first_symbol)); 3829 3830 /* THIS DEPENDS UPON return_value BEING THE FIRST DEFINED SYMBOL IN THE FUNCTION. */ 3831 3832 call emit_single ((load_inst (in_q)), (p -> symbol.v_length)); 3833 call emit_single ((adfx1), 3 - bias); /* adq 3 */ 3834 call emit_single ((qrs), 2 - bias); /* qrs 2 */ 3835 call flush_base (which_base (2)); 3836 call emit_operator_call ((alloc_auto_adj)); 3837 call emit_c_a ((store_base (which_base (2))), c_a ((p -> symbol.location), 6)); 3838 3839 /* If the return_value_param has a descriptor, copy to our descriptor. */ 3840 3841 if addr (rands (stack (zarg + n))) -> symbol.hash_chain ^= 0 & p -> symbol.hash_chain ^= 0 3842 then do; 3843 call emit_single ((load_inst (in_q)), (addr (rands (stack (zarg + n))) -> symbol.hash_chain)); 3844 call emit_single ((store_inst (in_q)), (p -> symbol.hash_chain)); 3845 end; 3846 call reset_eaq (Q); 3847 end; 3848 3849 go to step; 3850 3851 action (80): /* push_char_temp */ 3852 if left < 0 3853 then do; 3854 3855 /* have count */ 3856 3857 left = stack (top) + bias; 3858 top = top - 1; 3859 end; 3860 3861 call push (assign_char_temp (left)); 3862 go to step; 3863 3864 simple (16): /* check_arg_list */ 3865 call check_arg_list; 3866 go to step; 3867 3868 simple (17): /* store_arg_addrs */ 3869 /*** Expects: 3870* 3871* external reference 3872* number of arguments 3873* arg1 3874* arg2 3875* . 3876* . 3877* . 3878* argn 3879* arglist temp ***/ 3880 zarg = base + 1; 3881 n = stack (zarg) + bias; 3882 temp = stack (zarg + n + 1); 3883 3884 do i = 1 to n; 3885 call base_man_load_pr ((stack (zarg + i)), 3); 3886 3887 if assembly_list & addr (rands (stack (zarg + i))) -> node.node_type = symbol_node 3888 then a_name (text_pos) = stack (zarg + i); 3889 3890 call emit_single_with_inc (store_base (3), temp, 2 * i); 3891 end; 3892 3893 go to step; 3894 3895 action (91): /* (if unless)_constant_addrs */ 3896 b2 = macro_cond_inst (imac).if_test; 3897 zarg = base + 1; 3898 n = stack (zarg) + bias; 3899 b1 = n <= hbound (itp_list, 1); 3900 3901 /* If descriptors must be supplied with this call, we cannot use 3902* an ITP argument list. This is because the constant nodes for 3903* the argument list and the descriptors will not be allocated 3904* until later, and we must know the addresses now. */ 3905 3906 /* If we have a VLA parameter then we MUST make a correct 3907* pointer to it, since we cannot indirect through the stack 3908* or the linkage section through a packed pointer. */ 3909 3910 if addr (rands (stack (base))) -> symbol.needs_descriptors 3911 then b1 = "0"b; 3912 3913 do i = 1 to n while (b1); 3914 p = addr (rands (stack (zarg + i))); 3915 3916 if assembly_list & p -> node.node_type = symbol_node 3917 then a_name (text_pos) = stack (zarg + i); 3918 3919 if p -> node.node_type = symbol_node & p -> symbol.VLA 3920 then b1 = "0"b; /* VLA is non-constant */ 3921 3922 if ^p -> node.is_addressable | ^p -> node.allocated 3923 | p -> node.ext_base & ^(p -> node.base = sp | p -> node.base = lp) 3924 then b1 = "0"b; 3925 end; 3926 3927 go to if_join; 3928 3929 action (93): /* get_quick_label */ 3930 op1 = get_operand (mopnd); 3931 k = stack (op1); 3932 if addr (rands (k)) -> symbol.external 3933 then k = addr (rands (k)) -> symbol.initial; 3934 stack (op1) = addr (rands (k)) -> symbol.initial; 3935 go to step; 3936 3937 simple (18): /* gen_itp_list */ 3938 unspec (arg_list.header) = "0"b; 3939 zarg = base + 1; 3940 n = stack (zarg) + bias; 3941 arg_list.arg_count = 2 * n; 3942 3943 do i = 1 to n; 3944 p = addr (rands (stack (zarg + i))); 3945 call set_itp_addr (p, i); 3946 end; 3947 3948 stack (top) = create_constant_block (addr (arg_list), 2 * n + 2); 3949 go to step; 3950 3951 simple (19): /* make_descriptors */ 3952 if addr (rands (stack (base))) -> symbol.needs_descriptors 3953 then do; 3954 zarg = base + 1; 3955 n = stack (zarg) + bias; 3956 temp = stack (zarg + n + 1); 3957 3958 skip = 2 * n; 3959 if addr (rands (stack (base))) -> symbol.parameter 3960 then skip = skip + 2; 3961 3962 do i = 1 to n; 3963 desc = make_descriptor ((stack (zarg + i))); 3964 3965 if assembly_list & addr (rands (stack (zarg + i))) -> node.node_type = symbol_node 3966 then a_name (text_pos) = stack (zarg + i); 3967 3968 call base_man_load_pr (desc, 3); 3969 call emit_single_with_inc (store_base (3), temp, skip + 2 * i); 3970 end; 3971 3972 end; 3973 3974 go to step; 3975 3976 simple (42): /* free_descriptors */ 3977 do while (desc_temp_chain ^= 0); 3978 p = addr (rands (desc_temp_chain)); 3979 desc_temp_chain = p -> temporary.next; 3980 call free_temp (p); 3981 end; 3982 3983 go to step; 3984 3985 simple (20): /* set_runtime_block_loc */ 3986 addr (rands (stack (base))) -> symbol.hash_chain = text_pos; 3987 go to step; 3988 3989 action (104): /* check_ref_count */ 3990 call print_message (424, "check_ref_count"); 3991 goto step; 3992 3993 action (110): /* save_state */ 3994 call print_message (424, "save_state"); 3995 3996 3997 action (108): /* round */ 3998 if do_rounding & ^machine_state.rounded 3999 then do; 4000 eaq_name = macro_instruction (imac).eaq_name; 4001 call emit_zero ((round_inst (eaq_name))); 4002 machine_state.rounded = "1"b; 4003 machine_state.indicators_valid = eaq_name_to_reg (eaq_name); 4004 end; 4005 4006 goto step; 4007 4008 action (109): /* flush_ref */ 4009 op1 = stack (get_operand (mopnd)); 4010 call flush_ref (op1); 4011 4012 goto step; 4013 4014 action (114): /* set_in_storage */ 4015 op1 = stack (get_operand (mopnd)); 4016 addr (rands (op1)) -> node.not_in_storage = "0"b; 4017 goto step; 4018 4019 action (125): /* pad_char_const_to_word */ 4020 op1 = get_operand (mopnd); 4021 4022 if addr (rands (stack (op1))) -> char_constant.length = chars_per_word 4023 then goto step; 4024 4025 else if addr (rands (stack (op1))) -> char_constant.length > chars_per_word 4026 then call print_message (443, chars_per_word - bias, (stack (op1))); 4027 4028 substr (char_temp, 1, chars_per_word) = addr (rands (stack (op1))) -> char_constant.value; 4029 stack (op1) = create_char_constant (substr (char_temp, 1, chars_per_word)); 4030 goto step; 4031 4032 action (126): /* pad_char_const_to_dw */ 4033 op1 = get_operand (mopnd); 4034 4035 if addr (rands (stack (op1))) -> char_constant.length = chars_per_dw 4036 then goto step; 4037 4038 else if addr (rands (stack (op1))) -> char_constant.length > chars_per_dw 4039 then call print_message (443, chars_per_dw - bias, (stack (op1))); 4040 4041 substr (char_temp, 1, chars_per_dw) = addr (rands (stack (op1))) -> char_constant.value; 4042 stack (op1) = create_char_constant (substr (char_temp, 1, chars_per_dw)); 4043 goto step; 4044 4045 simple (44): /* int_to_char1 */ 4046 p = addr (rands (stack (top))); 4047 if p -> node.node_type = constant_node & p -> node.data_type = int_mode 4048 then do; 4049 char1 = byte (addr (p -> constant.value) -> int_image); 4050 call push (create_char_constant (char1)); 4051 end; 4052 else call print_message (462); 4053 4054 go to step; 4055 4056 simple (45): /* char1_to_int */ 4057 p = addr (rands (stack (top))); 4058 if p -> node.node_type = char_constant_node 4059 then do; 4060 temp = rank (substr (p -> char_constant.value, 1, 1)); 4061 call push (create_integer_constant ((temp))); 4062 end; 4063 else call print_message (463); 4064 4065 go to step; 4066 4067 action (57): /* start_cat */ 4068 call start_cat (b1); 4069 if b1 4070 then do; /* Skip first mlr */ 4071 imac = left; 4072 go to loop; 4073 end; 4074 else go to step; 4075 4076 simple (46): /* continue_cat */ 4077 call continue_cat (); 4078 go to step; 4079 4080 simple (47): /* finish_cat */ 4081 call finish_cat (); 4082 go to step; 4083 4084 action (58): /* shorten_stack */ 4085 if machine_state.stack_extended 4086 then do; 4087 4088 /* Reserve pr1 and call the correct operator */ 4089 4090 call reserve_regs (shorten_stack_mask); 4091 4092 if left > 0 /* protect indicators? */ 4093 then call emit_operator_call (shorten_stack_protect_ind); 4094 else do; 4095 call use_ind (); 4096 call emit_operator_call (shorten_stack); 4097 end; 4098 4099 machine_state.stack_extended = "0"b; 4100 machine_state.last_dynamic_temp = 0; 4101 4102 call free_regs (); 4103 end; 4104 4105 go to step; 4106 4107 action (60): /* (if unless)_ansi77 */ 4108 b2 = macro_cond_inst (imac).if_test; 4109 b1 = cs -> subprogram.options.ansi_77; 4110 go to if_join; 4111 4112 simple (48): /* set_needs_descriptors */ 4113 addr (rands (stack (base))) -> symbol.needs_descriptors = "1"b; 4114 go to step; 4115 4116 action (69): /* (if unless)_variable_arglist */ 4117 b2 = macro_cond_inst (imac).if_test; 4118 op1 = stack (get_operand (mopnd)); 4119 b1 = addr (rands (op1)) -> symbol.variable_arglist; 4120 go to if_join; 4121 4122 action (74): /* (if unless)_char_star_function */ 4123 b2 = macro_cond_inst (imac).if_test; 4124 b1 = cs -> subprogram.star_extent_function; 4125 go to if_join; 4126 4127 action (75): /* (if unless)_check_multiply */ 4128 b2 = macro_cond_inst (imac).if_test; 4129 b1 = cs -> subprogram.options.check_multiply; 4130 go to if_join; 4131 4132 action (79): /* (if unless)_storage_created */ 4133 b2 = macro_cond_inst (imac).if_test; 4134 if Area_create_first >= 0 4135 then b1 = "1"b; 4136 else b1 = "0"b; 4137 go to if_join; 4138 4139 action (88): /* (if unless)_VLA */ 4140 b2 = macro_cond_inst (imac).if_test; 4141 op1 = stack (get_operand (mopnd)); 4142 4143 /* Only VLA if it is a symbol, which is VLA. */ 4144 4145 if addr (rands (op1)) -> node.node_type = symbol_node 4146 then b1 = addr (rands (op1)) -> symbol.VLA; 4147 else b1 = "0"b; 4148 go to if_join; 4149 4150 action (90): /* (if unless)_cleanup */ 4151 b2 = macro_cond_inst (imac).if_test; 4152 b1 = alloc_auto_cleanup; 4153 go to if_join; 4154 4155 simple (52): /* emit_cleanup_args */ 4156 text_halfs (text_pos).left = cleanup_body_address; 4157 if assembly_list 4158 then a_name (text_pos) = -1; /* tell listing generator this is not an inst */ 4159 text_pos = text_pos + 1; 4160 go to step; 4161 4162 4163 simple (53): /* emit_storage_args */ 4164 if Area_create_first < 0 /* See if storage */ 4165 then do; 4166 text_halfs (text_pos).left = fixed ("777777"b3, 18); 4167 reloc (text_pos).left_rel = rc_a; /* leave absolute */ 4168 end; 4169 else do; 4170 text_halfs (text_pos).left = Area_create_first; 4171 reloc (text_pos).left_rel = rc_t; /* relocate in text */ 4172 end; 4173 4174 if Area_init_first < 0 /* See if initialization */ 4175 then do; 4176 text_halfs (text_pos).right = fixed ("777777"b3, 18); 4177 reloc (text_pos).right_rel = rc_a; /* leave absolute */ 4178 end; 4179 else do; 4180 text_halfs (text_pos).right = Area_init_first; 4181 reloc (text_pos).right_rel = rc_t; /* relocate in text */ 4182 end; 4183 4184 if assembly_list 4185 then a_name (text_pos) = -1; /* list in octal */ 4186 4187 text_pos = text_pos + 1; 4188 goto step; 4189 4190 4191 simple (54): /* emit_profile_entry */ 4192 if ^(generate_profile & generate_long_profile) 4193 then goto step; 4194 4195 call emit_profile_dummy; 4196 call emit_profile_dummy; 4197 4198 call emit_profile_control; 4199 call emit_profile_control; 4200 4201 call emit_profile_dummy; 4202 4203 goto step; 4204 4205 simple (57): /* rhs_fld */ 4206 call rhs_fld; 4207 goto step; 4208 4209 simple (58): /* lhs_fld */ 4210 call lhs_fld; 4211 goto step; 4212 4213 emit_profile_dummy: 4214 proc; 4215 4216 /* emit a long_profile reference to long_profile_header.dummy */ 4217 4218 call emit_operator_call (long_profile); 4219 text_halfs (text_pos).left = profile_start; 4220 reloc (text_pos).left_rel = rc_is18; 4221 4222 /* emit relative offset from long_profile_header to dummy entry */ 4223 4224 text_halfs (text_pos).right = 5; /* dummy offset */ 4225 reloc (text_pos).right_rel = rc_a; 4226 text_pos = text_pos + 1; 4227 return; 4228 end emit_profile_dummy; 4229 4230 4231 emit_profile_control: 4232 proc; 4233 4234 /* emit a long_profile reference to long_profile_header.control */ 4235 4236 call emit_operator_call (long_profile); 4237 text_halfs (text_pos).left = profile_start; 4238 reloc (text_pos).left_rel = rc_is18; 4239 4240 /* emit relative offset from long_profile_header to control entry */ 4241 4242 text_halfs (text_pos).right = 9; /* control offset */ 4243 reloc (text_pos).right_rel = rc_a; 4244 text_pos = text_pos + 1; 4245 return; 4246 end emit_profile_control; 4247 4248 simple (55): /* force_even */ 4249 if mod (text_pos, 2) ^= 0 4250 then call emit_zero (nop); 4251 goto step; 4252 4253 simple (56): /* emit_entry_defs */ 4254 /*** Expects: 4255* 4256* entry label 4257* count of parameters ***/ 4258 /*** Make pointer to descriptor area we will build later. 4259* 4260* We will allocate space to put the node offset to the 4261* descriptor in the text section. This will later be filled 4262* by 'check_parameters' to hold the index of the constant 4263* node, then gen_entry_defs will later fill in the true text 4264* offset from the allocated nodes. 4265* 4266* This code is split into the three sections, this, 4267* check_parameters, and gen_entry_defs, since at this point 4268* we need to reserve space, but have not yet seen the quads 4269* or polish defining the parameters. At check parameters we 4270* put in the node offset to the descriptor, since it may not 4271* have been allocated, and forward refs only relocate the 4272* left half of an instruction. Finally at gen_entry_defs time 4273* we convert the node index to a text offset because all text 4274* allocations have been made at that time. ***/ 4275 zarg = base + 2; 4276 n = stack (base + 1) + bias; 4277 4278 parm_desc_ptrsp = addr (text_word (text_pos)); 4279 parm_desc_ptrs.n_args = n; 4280 k = text_pos; 4281 4282 /* Skip allocated area, and setup descr_relp_offset */ 4283 4284 text_pos = text_pos + divide (n, 2, 18) + 1; 4285 text_halfs (text_pos).left = k; 4286 text_halfs (text_pos).right = 0; 4287 4288 reloc (text_pos).left_rel = rc_t; 4289 reloc (text_pos).right_rel = rc_a; 4290 text_pos = text_pos + 1; 4291 go to step; 4292 4293 action (92): /* (if unless)_hfp */ 4294 b2 = macro_cond_inst (imac).if_test; 4295 b1 = cs -> subprogram.options.hfp; 4296 goto if_join; 4297 4298 /* These macro opcodes are unused, or (if named) are used only by the 4299* optimizing code generaor. */ 4300 4301 simple (23): /* discard_state */ 4302 simple (24): /* push_output */ 4303 simple (25): /* bump_args */ 4304 simple (26): /* drop_args */ 4305 simple (27): /* push_operand_count */ 4306 simple (29): /* set_rounded */ 4307 simple (30): /* load_xreg */ 4308 simple (31): /* load_preg */ 4309 simple (32): /* drop_all_counts */ 4310 simple (33): /* ind_to_a */ 4311 simple (34): /* assign_index */ 4312 simple (35): /* compare_index */ 4313 simple (36): /* test_index */ 4314 simple (37): /* increment_index */ 4315 simple (38): /* decrement_index */ 4316 simple (40): /* refresh_regs_if_next_is_jump */ 4317 simple (41): /* note_eligible_ind_var_use */ 4318 simple (43): /* force_ql */ 4319 simple (51): 4320 call print_message (436, left - bias); 4321 go to step; 4322 4323 action (42): /* use_a */ 4324 action (43): /* use_q */ 4325 action (49): /* refresh_regs */ 4326 action (59): /* set_next_operand */ 4327 action (82): /* (if unless)_global */ 4328 action (83): /* (if unless)_induction_var */ 4329 action (84): /* (if unless)_fb17 */ 4330 action (86): /* (if unless)_global_ind_var */ 4331 action (94): 4332 action (96): 4333 action (97): 4334 action (98): 4335 action (100): 4336 action (101): /* if_next_statement */ 4337 action (102): /* unless_next_statement */ 4338 action (103): 4339 action (106): 4340 action (107): 4341 action (115): /* bump */ 4342 action (116): /* drop */ 4343 action (117): 4344 action (118): /* (if unless)_zero */ 4345 action (119): 4346 action (120): 4347 action (121): /* push_ref_count */ 4348 action (122): 4349 action (123): 4350 action (127): /* power_of_two */ 4351 call print_message (436, mop - bias); 4352 go to step; 4353 4354 /* THESE SHOULD NOT EXECUTE */ 4355 action (0): /* undefined */ 4356 action (12): /* proc */ 4357 action (13): /* func */ 4358 action (56): /* (if unless)_saving_stack_extent */ 4359 action (67): /* used by rest_of_error */ 4360 call print_message (413); 4361 4362 step: 4363 end; 4364 4365 /**** STACK FRAME MANIPULATION ****/ 4366 4367 push: 4368 procedure (i); 4369 4370 /* Pushes an item onto the operand stack */ 4371 4372 dcl i fixed binary (18); 4373 4374 top = top + 1; 4375 4376 if top > hbound (stack, 1) 4377 then do; 4378 call print_message (407, "operand stack", hbound (stack, 1) - bias); 4379 return; 4380 end; 4381 4382 stack (top) = i; 4383 4384 end push; 4385 4386 copy: 4387 procedure (opnd); 4388 4389 /* Copies an operand onto the top of the stack */ 4390 4391 dcl (opnd, op) fixed binary (18); 4392 4393 op = effective_operand (opnd); 4394 4395 call push (op); 4396 4397 if op > 0 4398 then do; 4399 p = addr (rands (op)); 4400 if p -> node.node_type = array_ref_node | p -> node.node_type = temporary_node 4401 then p -> temporary.ref_count = p -> temporary.ref_count + 1; 4402 end; 4403 4404 end copy; 4405 4406 pop: 4407 procedure (pthru); 4408 4409 /* Pops the stack through thru -- top becomes thru - 1 */ 4410 4411 dcl (pthru, thru) fixed binary (18); /* pop through thru */ 4412 4413 dcl n fixed binary (18); 4414 4415 thru = pthru; 4416 4417 do while (top >= thru); 4418 if stack (top) > 0 4419 then do; 4420 p = addr (rands (stack (top))); 4421 if p -> node.node_type = temporary_node 4422 then do; 4423 n, p -> temporary.ref_count = p -> temporary.ref_count - 1; 4424 if n <= 0 4425 then call free_temp (p); 4426 end; 4427 else if p -> node.node_type = array_ref_node 4428 then do; 4429 n, p -> array_ref.ref_count = p -> array_ref.ref_count - 1; 4430 if n <= 0 4431 then call free_array_ref (p); 4432 end; 4433 end; 4434 4435 top = top - 1; 4436 end; 4437 4438 end pop; 4439 4440 pop_frame: 4441 procedure (); 4442 4443 /* Pops a procedure frame */ 4444 4445 cur_frame = cur_frame -> proc_frame.prev; 4446 base = cur_frame -> proc_frame.base; 4447 4448 end pop_frame; 4449 4450 get_operand: 4451 procedure (opnd) returns (fixed binary (18)); 4452 4453 /* Takes an operand number as specified in a macro and returns 4454* the corresponding operand stack subscript. */ 4455 4456 dcl opnd fixed binary (18); /* Operand number specified in macro */ 4457 4458 dcl i fixed binary (18); 4459 4460 if opnd < 0 4461 then return (top + opnd + 1); /* opn */ 4462 else if opnd > 0 4463 then return (base + opnd - 1); /* argn */ 4464 else do; 4465 4466 /* opv */ 4467 4468 i = stack (top) + bias; 4469 top = top - 1; 4470 return (top - i + 1); 4471 end; 4472 4473 end get_operand; 4474 4475 interpreter_proc: 4476 procedure (mac_num, ret_lab); 4477 4478 /* Calls an interpreter macro procedure. ret_lab must 4479* be set to the label of the stmt immediately following 4480* the call to interpreter_proc. 4481* 4482* Note that this scheme is really an attempt to escape the 4483* necessity for recursion in invoking interpreter macro 4484* procedures. To be truly safe, this should have recursively 4485* invoked the entire interpreter. For this scheme to work, 4486* all procedures between the caller and the interpreter MUST 4487* be quick, and none of them (including the caller) must be 4488* invoked during the processing of the interpreter macro 4489* procedure. This is necessary to ensure that no local 4490* variables are destroyed. Obviously a procedure is safe if 4491* its last statement results in a call to interpreter_proc; 4492* the interesting cases arise when some other statement in 4493* a procedure directly or indirectly invokes interpreter_proc. 4494* 4495* Of course, this is illegal PL/I. */ 4496 4497 dcl mac_num fixed binary (18), /* Macro number of interpreter procedure */ 4498 ret_lab label local; /* Label to return to */ 4499 4500 dcl macro_proc fixed binary (18); 4501 4502 macro_proc = fort_cg_macros_$interpreter_macros (mac_num).entry; 4503 4504 call setup_call (macro_proc, imac, imac, 0); 4505 4506 proc_frame.interpreter_called = "1"b; 4507 proc_frame.interpreter_return = ret_lab; 4508 4509 imac = macro_proc; 4510 go to step; 4511 4512 end interpreter_proc; 4513 4514 setup_call: 4515 procedure (macro_proc, return, error_exit, nb); 4516 4517 /* Pushes a new procedure frame and sets it up for a call */ 4518 4519 dcl macro_proc fixed binary (18), /* Procedure being called */ 4520 return fixed binary (18), /* Location from which the call is being made */ 4521 error_exit fixed binary (18), /* Location to jump to if errors occur */ 4522 nb fixed binary (18); /* Presupplied next_base if ^= 0 */ 4523 4524 dcl (mac_proc, next_base) fixed binary (18); 4525 4526 mac_proc = macro_proc; 4527 4528 if nb = 0 4529 then next_base = get_nextbase (mac_proc); 4530 else next_base = nb; 4531 4532 /* get next procedure frame */ 4533 4534 if cur_frame -> proc_frame.next ^= null 4535 then cur_frame = cur_frame -> proc_frame.next; 4536 else cur_frame = create_proc_frame (); 4537 4538 /* initialize next procedure frame */ 4539 4540 string (proc_frame.flags) = "0"b; 4541 4542 if fixed (macro_instruction (mac_proc).op_code, 7) = function 4543 then proc_frame.func = "1"b; 4544 4545 proc_frame.return = return; 4546 proc_frame.error_label = error_exit; 4547 base, proc_frame.base = next_base; 4548 proc_frame.nshort = 0; 4549 4550 end setup_call; 4551 4552 create_proc_frame: 4553 procedure () returns (pointer); 4554 4555 /* Allocates a procedure frame in the operand region */ 4556 4557 dcl p pointer; 4558 4559 if mod (next_free_operand, 2) ^= 0 4560 then do; 4561 rands (next_free_operand) = 0; /* for debugging */ 4562 next_free_operand = next_free_operand + 1; 4563 end; 4564 4565 4566 p = addr (rands (next_free_operand)); 4567 next_free_operand = next_free_operand + size (proc_frame); 4568 4569 if next_free_operand >= operand_max_len 4570 then do; 4571 call print_message (407, "operand region", char (operand_max_len)); 4572 /* FATAL */ 4573 return (null); /* should never be executed */ 4574 end; 4575 4576 if cur_frame ^= null 4577 then cur_frame -> proc_frame.next = p; 4578 4579 unspec (p -> proc_frame) = "0"b; 4580 p -> proc_frame.prev = cur_frame; 4581 p -> proc_frame.next = null; 4582 return (p); 4583 4584 end create_proc_frame; 4585 4586 get_nextbase: 4587 procedure (macro_proc) returns (fixed binary (18)); 4588 4589 /* Calculates base of new stack frame */ 4590 4591 dcl macro_proc fixed binary (18); /* Proc being called */ 4592 4593 dcl nargs fixed binary (18); 4594 4595 nargs = macro_dt_inst (macro_proc).data_type; 4596 if nargs < 0 4597 then nargs = stack (top) + bias + 1; 4598 return (top - nargs + 1); 4599 4600 end get_nextbase; 4601 4602 /**** TEMPORARY MANAGEMENT ****/ 4603 4604 assign_temp: 4605 procedure (data_type) returns (fixed binary (18)); 4606 4607 /* Assigns a temporary of a specific data type */ 4608 4609 dcl data_type fixed binary (4); 4610 4611 dcl (clength, dt, size, temp) fixed binary (18); 4612 4613 dt = data_type; 4614 size = data_type_size (dt); 4615 go to join; 4616 4617 4618 assign_char_temp: 4619 entry (char_length) returns (fixed binary (18)); 4620 4621 /* Assigns a character temporary */ 4622 4623 dcl char_length fixed binary (18); 4624 4625 dt = char_mode; 4626 clength = char_length; 4627 size = divide (clength + chars_per_word - 1, chars_per_word, 17, 0); 4628 go to join; 4629 4630 4631 assign_block: 4632 entry (block_size) returns (fixed binary (18)); 4633 4634 /* Assigns a doubleword aligned block */ 4635 4636 dcl block_size fixed binary (18); 4637 4638 size = block_size; 4639 size = size + mod (size, 2); 4640 dt = 0; 4641 4642 join: 4643 temp = get_temp (size); 4644 addr (rands (temp)) -> temporary.data_type = dt; 4645 addr (rands (temp)) -> temporary.ref_count = 1; 4646 addr (rands (temp)) -> temporary.units = word_units; 4647 4648 if dt = char_mode 4649 then do; 4650 addr (rands (temp)) -> temporary.length = clength; 4651 if cs -> subprogram.options.ansi_77 4652 then addr (rands (temp)) -> temporary.units = char_units; 4653 end; 4654 4655 return (temp); 4656 4657 get_temp: 4658 procedure (amount) returns (fixed binary (18)); 4659 4660 /* Finds a free temporary of the desired size */ 4661 4662 dcl (amt, amount, i, prev, temp) fixed binary (18); 4663 4664 amt = amount; 4665 4666 if amt <= 2 4667 then do; 4668 i = amt; 4669 temp = free_temps (i); 4670 4671 if temp ^= 0 4672 then do; 4673 free_temps (i) = addr (rands (temp)) -> temporary.next; 4674 return (temp); 4675 end; 4676 end; 4677 4678 else do; 4679 i = 3; 4680 prev = 0; 4681 temp = free_temps (3); 4682 4683 do while (temp ^= 0); 4684 4685 if addr (rands (temp)) -> temporary.size >= amt 4686 then do; 4687 if prev = 0 4688 then free_temps (3) = addr (rands (temp)) -> temporary.next; 4689 else addr (rands (prev)) -> temporary.next = addr (rands (temp)) -> temporary.next; 4690 return (temp); 4691 end; 4692 4693 prev = temp; 4694 temp = addr (rands (temp)) -> temporary.next; 4695 end; 4696 end; 4697 4698 if i > 1 4699 then if mod (last_auto_loc, 2) ^= 0 4700 then do; 4701 4702 /* force doubleword alignment */ 4703 4704 temp = create_temp (1); 4705 addr (rands (temp)) -> temporary.next = free_temps (1); 4706 free_temps (1) = temp; 4707 end; 4708 4709 return (create_temp (amt)); 4710 4711 end get_temp; 4712 4713 end assign_temp; 4714 4715 get_temp_node: 4716 procedure () returns (fixed binary (18)); 4717 4718 /* Gets a temp node off the free chain, or allocates a new one. */ 4719 4720 dcl size builtin; 4721 dcl temp fixed binary (18); 4722 4723 if next_free_temp = 0 4724 then temp = create_node (temporary_node, size (temporary)); 4725 else do; 4726 temp = next_free_temp; 4727 next_free_temp = addr (rands (temp)) -> temporary.next; 4728 unspec (addr (rands (temp)) -> temporary) = "0"b; 4729 addr (rands (temp)) -> temporary.node_type = temporary_node; 4730 end; 4731 4732 return (temp); 4733 4734 end get_temp_node; 4735 4736 create_temp: 4737 procedure (amount) returns (fixed binary (18)); 4738 4739 /* Creates a new temporary, possibly reusing a discarded 4740* temporary node. */ 4741 4742 dcl node_size fixed binary; 4743 dcl (amount, op_type, temp) fixed binary (18); 4744 dcl amt fixed binary (18); 4745 dcl loc fixed binary (18); 4746 dcl node_type fixed binary (4); 4747 dcl p pointer; 4748 dcl size builtin; 4749 4750 node_type = temporary_node; 4751 node_size = size (temporary); 4752 op_type = temp_type; 4753 go to join; 4754 4755 create_var: 4756 entry (amount) returns (fixed binary (18)); 4757 4758 /* Creates an automatic variable of the desired size */ 4759 4760 node_type = symbol_node; 4761 node_size = size (symbol); 4762 op_type = variable_type; 4763 4764 join: 4765 amt = amount; 4766 loc = last_auto_loc; 4767 4768 if loc + amt > max_stack_size 4769 then call print_message (414, "in making a temporary the stack frame", max_stack_size - bias); 4770 else last_auto_loc = loc + amt; 4771 4772 if node_type = symbol_node 4773 then temp = create_node (node_type, node_size); 4774 else temp = get_temp_node (); 4775 4776 p = addr (rands (temp)); 4777 4778 p -> temporary.operand_type = op_type; 4779 string (p -> temporary.addressing_bits), string (p -> temporary.bits) = "0"b; 4780 4781 p -> temporary.is_addressable, p -> temporary.allocate, p -> temporary.allocated = "1"b; 4782 4783 unspec (p -> temporary.address) = ext_base_on; 4784 p -> temporary.base = sp; 4785 4786 if node_type = temporary_node 4787 then do; 4788 p -> temporary.size = amt; 4789 p -> temporary.not_in_storage = "1"b; 4790 end; 4791 4792 p -> temporary.next = 0; 4793 4794 p -> temporary.units = word_units; 4795 4796 call set_address_offset (p, loc, amt, word_units); 4797 4798 return (temp); 4799 4800 end create_temp; 4801 4802 free_temp: 4803 procedure (temp_ptr); 4804 4805 /* Procedure to free a temporary. If the temporary has 4806* variable length, the reference count of the associated 4807* length temporary is decremented, and that temporary is 4808* freed if necessary. */ 4809 4810 dcl temp_ptr pointer; /* Pointer to temp node */ 4811 4812 dcl (tp, ltp) pointer; /* To temp, length temp */ 4813 dcl count fixed binary (18); /* Reference count */ 4814 4815 tp = temp_ptr; 4816 4817 if tp -> temporary.variable_length 4818 then do; 4819 4820 /* Must deal with associated length temporary */ 4821 4822 ltp = addr (rands (tp -> temporary.length)); 4823 if ltp -> node.node_type = temporary_node 4824 then do; 4825 count, ltp -> temporary.ref_count = ltp -> temporary.ref_count - 1; 4826 if count <= 0 4827 then call free_one_temp (ltp); 4828 tp -> temporary.length = 0; 4829 tp -> temporary.variable_length = "0"b; 4830 end; 4831 end; 4832 4833 call free_one_temp (tp); 4834 4835 end free_temp; 4836 4837 free_one_temp: 4838 procedure (temp_ptr); 4839 4840 /* This procedure flushes a temporary from the machine state 4841* and threads it onto the appropriate free list. */ 4842 4843 dcl temp_ptr pointer; /* Pointer to temp node */ 4844 4845 dcl tp pointer; /* To temp node */ 4846 dcl (temp, prev_temp, this_temp) fixed binary (18); 4847 dcl temp_size fixed binary (18); 4848 4849 tp = temp_ptr; 4850 temp = fixed (rel (tp), 18); 4851 4852 /* Check for reference count error */ 4853 4854 if tp -> temporary.ref_count < 0 4855 then do; 4856 call print_message (415, temp); 4857 return; 4858 end; 4859 4860 tp -> temporary.not_in_storage = "1"b; 4861 temp_size = tp -> temporary.size; 4862 4863 call flush_ref (temp); 4864 call flush_addr (temp); 4865 4866 /* Restore address of dynamic temporary */ 4867 4868 if tp -> temporary.stack_indirect 4869 then do; 4870 unspec (tp -> temporary.address) = tp -> temporary.addr_hold; 4871 tp -> temporary.address.ext_base = "1"b; 4872 tp -> temporary.needs_pointer = "0"b; 4873 tp -> temporary.is_addressable = ^tp -> temporary.large_address; 4874 tp -> temporary.stack_indirect = "0"b; 4875 end; 4876 4877 /* One and two word temps have their own free lists */ 4878 4879 if temp_size < 3 4880 then do; 4881 call thread_temp (temp, temp_size, 0); 4882 return; 4883 end; 4884 4885 /* Larger temps go on the third free list, sorted by size */ 4886 4887 prev_temp = 0; 4888 this_temp = free_temps (3); 4889 do while (this_temp ^= 0); 4890 4891 if temp_size <= addr (rands (this_temp)) -> temporary.size 4892 then do; 4893 call thread_temp (temp, 3, prev_temp); 4894 return; 4895 end; 4896 4897 prev_temp = this_temp; 4898 this_temp = addr (rands (this_temp)) -> temporary.next; 4899 4900 end; 4901 4902 /* Temp is larger than any on the free list. */ 4903 4904 call thread_temp (temp, 3, prev_temp); 4905 4906 end free_one_temp; 4907 4908 thread_temp: 4909 procedure (temp, chain, prev); 4910 4911 /* Threads temp onto the free list specified by chain after 4912* the temp prev. */ 4913 4914 dcl (temp, chain, prev) fixed binary (18); 4915 4916 if prev = 0 4917 then do; 4918 4919 /* Put temp at beginning of free list */ 4920 4921 addr (rands (temp)) -> temporary.next = free_temps (chain); 4922 free_temps (chain) = temp; 4923 end; 4924 4925 else do; 4926 addr (rands (temp)) -> temporary.next = addr (rands (prev)) -> temporary.next; 4927 addr (rands (prev)) -> temporary.next = temp; 4928 end; 4929 4930 end thread_temp; 4931 4932 push_variable: 4933 procedure (dt); 4934 4935 /* Pushes an automatic variable of data_type dt onto the stack */ 4936 4937 dcl dt fixed binary (18); 4938 4939 dcl (var, amt, temp) fixed binary (18); 4940 4941 amt = data_type_size (dt); 4942 4943 if amt > 1 4944 then if mod (last_auto_loc, 2) ^= 0 4945 then do; 4946 4947 /* force doubleword alignement for the variable */ 4948 4949 temp = create_temp (1); 4950 call free_temp (addr (rands (temp))); 4951 end; 4952 4953 var = create_var (amt); 4954 4955 addr (rands (var)) -> symbol.data_type = dt; 4956 4957 call push (var); 4958 4959 end push_variable; 4960 4961 /**** DYNAMIC TEMPORARY MANAGEMENT ****/ 4962 4963 assign_dynamic_temp: 4964 procedure () returns (fixed binary (18)); 4965 4966 /* This procedure allocates and initializes a dynamic 4967* character temporary, but emits no code. Dynamic temps 4968* are implemented as two word temporaries which hold a 4969* pointer to the actual stack extension. */ 4970 4971 dcl t fixed binary (18); /* Two word temp */ 4972 dcl p pointer; /* Pointer to it */ 4973 4974 t = assign_block (2); 4975 p = addr (rands (t)); 4976 4977 p -> temporary.data_type = char_mode; 4978 p -> temporary.stack_indirect = "1"b; 4979 p -> temporary.needs_pointer = "1"b; 4980 p -> temporary.is_addressable = "0"b; 4981 4982 p -> temporary.addr_hold = substr (unspec (p -> temporary.address), 1, 18); 4983 p -> temporary.reloc_hold = p -> temporary.reloc; 4984 4985 unspec (p -> temporary.address) = ext_base_on; 4986 p -> temporary.reloc = rc_a; 4987 4988 return (t); 4989 4990 end assign_dynamic_temp; 4991 4992 allocate_dynamic_temp: 4993 procedure (temp, tv_offset); 4994 4995 /* Emits code to extend the stack for a dynamic temporary. 4996* The parameter tv_offset should be set to either 4997* allocate_char_string or reallocate_char_string. */ 4998 4999 dcl temp fixed binary (18); /* Temporary node */ 5000 dcl tv_offset fixed binary (14); /* Operator offset */ 5001 5002 dcl p pointer; 5003 5004 p = addr (rands (temp)); 5005 5006 call load ((p -> temporary.length), in_q); 5007 call use_eaq (0); 5008 call flush_base (which_base (2)); 5009 call emit_operator_call ((tv_offset)); 5010 5011 machine_state.stack_extended = "1"b; 5012 machine_state.address_in_base = "1"b; 5013 p -> temporary.address_in_base = "1"b; 5014 p -> temporary.address.base = bases (which_base (2)); 5015 5016 machine_state.last_dynamic_temp = temp; 5017 5018 machine_state.base_regs (which_base (2)).variable = temp; 5019 machine_state.base_regs (which_base (2)).type = 1; 5020 machine_state.base_regs (which_base (2)).used = text_pos; 5021 machine_state.base_regs (which_base (2)).offset = 0; 5022 5023 end allocate_dynamic_temp; 5024 5025 /**** EMISSION OF OBJECT CODE ****/ 5026 5027 emit_inst: 5028 procedure (); 5029 5030 /* Emits an instruction of object code */ 5031 5032 dcl (inc, rand) fixed binary (18); 5033 5034 if string (machine_instruction (imac).ext_base_and_tag) ^= "0"b 5035 then text_word (text_pos) = unspec (machine_instruction (imac)); 5036 5037 else do; 5038 5039 /* have an operand */ 5040 5041 inc = machine_instruction (imac).increment; 5042 rand = get_operand ((machine_instruction (imac).operand)); 5043 5044 call put_word ((machine_instruction (imac)), (stack (rand)), inc); 5045 end; 5046 5047 text_pos = text_pos + 1; 5048 5049 end emit_inst; 5050 5051 emit_single: 5052 procedure (mac_num, rand); 5053 5054 /* Emits an instruction from a table of single instructions */ 5055 5056 dcl mac_num fixed binary (18), /* Single instruction number */ 5057 rand fixed binary (18); /* Operand for the inst */ 5058 dcl inc fixed binary (18); 5059 5060 inc = fort_cg_macros_$single_inst (mac_num).increment; 5061 5062 call put_word ((fort_cg_macros_$single_inst (mac_num)), (rand), inc); 5063 5064 text_pos = text_pos + 1; 5065 return; 5066 5067 5068 emit_single_with_inc: 5069 entry (mac_num, rand, incr); 5070 5071 /* Emits a single instruction with a specified address increment */ 5072 5073 dcl incr fixed binary (18); 5074 5075 inc = incr; 5076 5077 5078 call put_word ((fort_cg_macros_$single_inst (mac_num)), (rand), inc); 5079 5080 text_pos = text_pos + 1; 5081 5082 end emit_single; 5083 5084 emit_with_tag: 5085 procedure (mac_num, address, tag); 5086 5087 /* Emits an instruction with a constant address and a tag field */ 5088 5089 dcl mac_num fixed binary (18), 5090 address fixed binary (18), 5091 tag bit (6) aligned; 5092 5093 dcl 1 inst like machine_instruction aligned; 5094 5095 text_word (text_pos) = unspec (fort_cg_macros_$single_inst (mac_num)) & mask_left; 5096 instruction (text_pos).tag = tag; 5097 text_halfs (text_pos).left = address; 5098 text_pos = text_pos + 1; 5099 return; 5100 end emit_with_tag; 5101 5102 emit_zero: 5103 procedure (mac_num); 5104 5105 /* Emits an instruction without operands */ 5106 5107 dcl mac_num fixed binary (18); 5108 5109 text_word (text_pos) = unspec (fort_cg_macros_$single_inst (mac_num)); 5110 text_pos = text_pos + 1; 5111 5112 end emit_zero; 5113 5114 emit_c_a: 5115 procedure (mac_num, address); 5116 5117 /* Emits an instruction given an address probably supplied by c_a */ 5118 5119 dcl mac_num fixed binary (18); /* Single instruction number */ 5120 dcl address bit (36) aligned; 5121 5122 text_word (text_pos) = (unspec (fort_cg_macros_$single_inst (mac_num)) & mask_left) | address; 5123 5124 if fort_cg_macros_$single_inst (mac_num).increment ^= 0 5125 then if instruction (text_pos).ext_base 5126 then instruction (text_pos).offset = 5127 instruction (text_pos).offset + fort_cg_macros_$single_inst (mac_num).increment; 5128 else text_halfs (text_pos).left = 5129 text_halfs (text_pos).left + fort_cg_macros_$single_inst (mac_num).increment; 5130 5131 text_pos = text_pos + 1; 5132 5133 end emit_c_a; 5134 5135 emit_c_a_var: 5136 procedure (mac_num, var_ptr); 5137 5138 /* Emits an instruction given an address probably supplied by 5139* c_a and outputs reloc and listing info */ 5140 5141 dcl mac_num fixed binary (18); /* Single instruction number */ 5142 dcl var_ptr pointer; /* Pointer to node for operand */ 5143 dcl p pointer; /* Pointer to array_ref_parent */ 5144 dcl text_offset fixed bin; /* offset of instruction in text section */ 5145 5146 reloc (text_pos).left_rel = var_ptr -> node.reloc; 5147 5148 if assembly_list 5149 then if var_ptr -> node.node_type = array_ref_node 5150 then a_name (text_pos) = var_ptr -> array_ref.parent; 5151 else a_name (text_pos) = binary (rel (var_ptr), 18, 0); 5152 5153 call emit_c_a ((mac_num), unspec (var_ptr -> node.address)); 5154 5155 /* catch possible references to the text section - phx13550 */ 5156 5157 p = var_ptr; 5158 if var_ptr -> node.node_type = array_ref_node 5159 then p = addr (rands (var_ptr -> array_ref.parent)); 5160 5161 if substr (unspec (p -> node.address), 30, 7) = "0000000"b 5162 then do; 5163 text_pos = text_pos - 1; /* Backup since emit_c_a inc text_pos */ 5164 text_offset = instruction.offset (text_pos); 5165 instruction.offset (text_pos) = 0; /* clear out offset (14 bit) */ 5166 call text_ref (p, (fort_cg_macros_$single_inst (mac_num).increment) + text_offset, 5167 fixed (fort_cg_macros_$single_inst (mac_num).op_code, 10), 0); 5168 text_pos = text_pos + 1; /* fixup */ 5169 end; 5170 end emit_c_a_var; 5171 5172 emit_temp_store: 5173 procedure (mac_no, temp); 5174 5175 /* Emits code to store a temporary. Calls emit_c_a rather 5176* than emit_single to avoid recursion. */ 5177 5178 dcl (mac_no, mac) fixed binary (18); 5179 dcl temp fixed binary (18); 5180 dcl p pointer; 5181 5182 mac = mac_no; 5183 p = addr (rands (temp)); 5184 5185 if ^p -> temporary.is_addressable 5186 then call m_a_except_xreg (p); 5187 5188 call emit_c_a (mac, unspec (p -> temporary.address)); 5189 5190 p -> temporary.not_in_storage = "0"b; 5191 5192 end emit_temp_store; 5193 5194 emit_operator_call: 5195 procedure (tv_offset); 5196 5197 /* Emits an instruction of the form tsx0 pr0|tv_offset. */ 5198 5199 dcl tv_offset fixed binary (14); 5200 dcl 1 inst aligned like instruction; 5201 5202 unspec (inst) = ext_base_on; 5203 inst.offset = tv_offset; 5204 inst.op = "1110000000"b; /* 700 (0) - tsx0 */ 5205 5206 text_word (text_pos) = unspec (inst); 5207 text_pos = text_pos + 1; 5208 5209 end emit_operator_call; 5210 5211 put_word: 5212 procedure (inst, rand, inc); 5213 5214 /* Uses inst as a template to put out an instruction with 5215* rand as an operand and inc as the increment */ 5216 5217 dcl 1 inst like machine_instruction parameter aligned, 5218 rand fixed binary (18), 5219 inc fixed binary (18); 5220 5221 dcl p pointer; 5222 5223 dcl mop fixed binary (18); 5224 5225 if rand < 0 5226 then do; 5227 5228 /* have a count, make it the address */ 5229 5230 text_word (text_pos) = unspec (inst) & mask_left; 5231 5232 /* use direct modifier if possible */ 5233 5234 mop = fixed (inst.op_code, 10); 5235 if directable (mop) 5236 then instruction (text_pos).tag = DL_mod; /* dl */ 5237 5238 text_halfs (text_pos).left = rand + bias + inc; 5239 return; 5240 end; 5241 5242 p = addr (rands (effective_operand (rand))); 5243 5244 if ^p -> node.is_addressable 5245 then do; 5246 if inc ^= 0 & p -> node.address.ext_base 5247 then call increment_address (p, (inc)); 5248 call m_a (p); 5249 end; 5250 5251 text_word (text_pos) = (unspec (inst) & mask_left) | unspec (p -> node.address); 5252 5253 reloc (text_pos).left_rel = p -> node.reloc; 5254 5255 if assembly_list 5256 then if p -> node.node_type = array_ref_node 5257 then a_name (text_pos) = p -> array_ref.parent; 5258 else a_name (text_pos) = rand; 5259 5260 if substr (unspec (p -> node.address), 30, 7) = "0000000"b 5261 then call text_ref (p, (inc), fixed (inst.op_code, 10), 0); 5262 else if inc ^= 0 5263 then if instruction (text_pos).ext_base 5264 then if ^p -> node.is_addressable 5265 then call increment_address (p, -inc); 5266 else instruction (text_pos).offset = instruction (text_pos).offset + inc; 5267 else text_halfs (text_pos).left = text_halfs (text_pos).left + inc; 5268 5269 end put_word; 5270 5271 text_ref: 5272 procedure (pt, inc, mop, desc_no); 5273 5274 /* Handles reference to the text section */ 5275 5276 dcl pt pointer; /* Points to addressed node */ 5277 dcl inc fixed binary (18); /* Address increment */ 5278 dcl mop fixed binary (18); /* Instruction opcode */ 5279 dcl desc_no fixed binary (18); /* EIS descriptor number, or 0 */ 5280 5281 dcl temp fixed binary (18); 5282 dcl (p, q) pointer; 5283 dcl use_dl bit (1) aligned; 5284 dcl value bit (36) aligned; 5285 5286 dcl ( 5287 ldq init ("236"b3), 5288 lcq init ("336"b3), 5289 adq init ("076"b3), 5290 sbq init ("176"b3) 5291 ) bit (10) aligned internal static options (constant); 5292 5293 dcl mf (0:2) fixed binary (6) internal static options (constant) initial (31, 31, 13); 5294 /* Location of MF within instruction */ 5295 5296 5297 p = pt; 5298 5299 q = null (); 5300 if p -> node.node_type = constant_node 5301 then q = addr (p -> constant.value); 5302 else if p -> node.node_type = char_constant_node 5303 then do; 5304 value = unspec (p -> char_constant.value); 5305 q = addr (value); 5306 end; 5307 5308 if q ^= null () 5309 then if inc = 0 5310 then if directable (mop) 5311 then do; 5312 5313 /* Attempt to use DL modification for any constant, 5314* unless it is an operand of an EIS instruction. */ 5315 5316 if (q -> half.left = 0) & (desc_no = 0) 5317 then do; 5318 text_halfs (text_pos).left = q -> half.right; 5319 instruction (text_pos).tag = DL_mod; 5320 /* dl */ 5321 reloc (text_pos).left_rel = rc_a; 5322 return; 5323 end; 5324 5325 /* Attempt to use DU modification for any constant, 5326* unless it is the first operand of an EIS instruction. */ 5327 5328 if (q -> half.right = 0) & (desc_no ^= 1) 5329 then do; 5330 text_halfs (text_pos).left = q -> half.left; 5331 substr (text_word (text_pos - desc_no), mf (desc_no), 6) = DU_mod; 5332 reloc (text_pos).left_rel = rc_a; 5333 return; 5334 end; 5335 5336 if q -> int_image < 0 5337 then do; 5338 5339 /* Attempt to optimize negative constants */ 5340 5341 temp = -q -> int_image; 5342 q = addr (temp); 5343 5344 if q -> half.left = 0 5345 then do; 5346 use_dl = "1"b; 5347 5348 if instruction (text_pos).op = ldq 5349 then instruction (text_pos).op = lcq; 5350 5351 else if instruction (text_pos).op = adq 5352 then instruction (text_pos).op = sbq; 5353 5354 else if instruction (text_pos).op = sbq 5355 then instruction (text_pos).op = adq; 5356 5357 else if instruction (text_pos).op = lcq 5358 then instruction (text_pos).op = ldq; 5359 5360 else use_dl = "0"b; 5361 5362 if use_dl 5363 then do; 5364 text_halfs (text_pos).left = q -> half.right; 5365 instruction (text_pos).tag = DL_mod; 5366 reloc (text_pos).left_rel = rc_a; 5367 return; 5368 end; 5369 end; 5370 end; 5371 end; 5372 5373 p -> node.allocate = "1"b; 5374 5375 if ^p -> node.allocated 5376 then do; 5377 text_halfs (text_pos).left = inc; 5378 5379 /* add this forward reference to a list of forward refs */ 5380 5381 if next_free_polish >= polish_max_len 5382 then call print_message (407, "polish region", char (polish_max_len)); 5383 5384 if p -> node.operand_type = external 5385 then p = addr (rands (p -> symbol.initial)); 5386 5387 next_free_polish = next_free_polish + 1; 5388 5389 forward_refs (next_free_polish - 1).operand = fixed (rel (p), 18); 5390 forward_refs (next_free_polish - 1).instruction = text_pos; 5391 end; 5392 5393 else if inc ^= 0 5394 then text_halfs (text_pos).left = text_halfs (text_pos).left + inc; 5395 5396 /* try to use a direct modifier with a rel_constant */ 5397 5398 if p -> node.operand_type = rel_constant 5399 then if directable (mop) 5400 then instruction (text_pos).tag = DL_mod; /* dl */ 5401 5402 end text_ref; 5403 5404 emit_eis: 5405 procedure (); 5406 5407 /* Emits a single EIS instruction, presently assumed to 5408* be 1 instruction word + 2 descriptor words. Only 5409* desc9a is allowed for now. An example follows: 5410* 5411* emit_eis 5412* 5413* mlr (pr),(pr),fill(040) 5414* desc9a op1 5415* desc9a arg2+3 5416* 5417* If the length field is omitted, which is the usual 5418* case, the interpreter supplies it. The interpreter 5419* supplies the Modification Fields. If the equal_lengths 5420* keyword is given, the length of the second operand is 5421* taken to be identical to the length of the first. */ 5422 5423 dcl arg (2) pointer; 5424 dcl op (2) fixed binary (18); 5425 dcl len (2) fixed binary (18); 5426 dcl lreg (2) bit (6) aligned; 5427 dcl inc (2) fixed binary (18); 5428 dcl p ptr; /* pointer to descriptor addressed node */ 5429 dcl text_offset fixed bin (18); /* used for text reference */ 5430 5431 dcl 1 descriptor (0:262143) based (object_base) aligned, 5432 2 word_address bit (18) unaligned, 5433 2 char bit (2) unaligned, 5434 2 bit bit (4) unaligned, 5435 2 length bit (12) unaligned; 5436 5437 dcl mf (3) fixed binary (6) internal static options (constant) initial (30, 12, 3); 5438 5439 dcl (i, inst_pos) fixed binary (18); 5440 5441 dcl bit builtin; 5442 5443 imac = imac + 1; /* point at the instruction */ 5444 5445 /* pick up the operands and address increments */ 5446 5447 do i = 1 to 2; 5448 op (i) = stack (get_operand ((machine_instruction (imac + i).operand))); 5449 arg (i) = addr (rands (op (i))); 5450 inc (i) = machine_instruction (imac + i).increment; 5451 lreg (i) = "00"b3; 5452 end; 5453 5454 /* Make operands addressable, reserving registers as needed */ 5455 5456 call make_both_addressable (arg, inc); 5457 5458 /* Get lengths of operands, reserving registers as needed */ 5459 5460 call get_eis_length (1); /* Get length of 1st opnd */ 5461 5462 if left > 0 /* Equal lengths? */ 5463 then if mac_base -> descriptor (imac + 2).length = "000"b3 5464 then do; 5465 5466 /* Copy length info from 1st opnd to 2nd */ 5467 5468 len (2) = len (1); 5469 lreg (2) = lreg (1); 5470 end; 5471 5472 else call print_message (466); 5473 5474 else call get_eis_length (2); /* Get length for opnd 2 */ 5475 5476 /* Move in the instruction word */ 5477 5478 inst_pos = text_pos; 5479 text_word (text_pos) = unspec (machine_instruction (imac)); 5480 5481 /* fill in the descriptors and modification fields */ 5482 5483 do i = 1 to 2; 5484 imac = imac + 1; 5485 text_pos = text_pos + 1; 5486 5487 substr (text_word (inst_pos), mf (i), 7) = substr (unspec (arg (i) -> node.address), 30, 7); 5488 5489 if lreg (i) 5490 then substr (text_word (inst_pos), mf (i) + 1, 1) = "1"b; 5491 5492 /* Fill in address of descriptor, including char and bit offsets */ 5493 5494 substr (unspec (descriptor (text_pos)), 1, 24) = substr (unspec (arg (i) -> node.address), 1, 20); 5495 5496 if lreg (i) 5497 then descriptor (text_pos).length = (6)"0"b || lreg (i); 5498 else descriptor (text_pos).length = bit (fixed (len (i), 12), 12); 5499 5500 reloc (text_pos).left_rel = arg (i) -> node.reloc; 5501 5502 if assembly_list 5503 then if arg (i) -> node.node_type = array_ref_node 5504 then a_name (text_pos) = arg (i) -> array_ref.parent; 5505 else a_name (text_pos) = op (i); 5506 5507 /* See if text reference, if so may need forward reference. */ 5508 5509 text_offset = inc (i); 5510 p = arg (i); 5511 if p -> node.node_type = array_ref_node 5512 then do; 5513 p = addr (rands (p -> array_ref.parent)); 5514 text_offset = text_offset + arg (i) -> node.offset; 5515 end; 5516 if substr (unspec (p -> node.address), 30, 7) = "0000000"b 5517 then call text_ref (p, text_offset, fixed (machine_instruction (imac - i).op_code, 10), i); 5518 5519 else if inc (i) ^= 0 5520 then if arg (i) -> node.ext_base 5521 then if ^arg (i) -> node.is_addressable 5522 then call increment_address (arg (i), -inc (i)); 5523 else instruction (text_pos).offset = instruction (text_pos).offset + inc (i); 5524 else text_halfs (text_pos).left = text_halfs (text_pos).left + inc (i); 5525 end; 5526 5527 text_pos = text_pos + 1; 5528 5529 /* Free regs used by addresses and lengths of EIS operands */ 5530 5531 call free_regs (); 5532 5533 return; 5534 5535 get_eis_length: 5536 procedure (opno); 5537 5538 /* Internal procedure of emit_eis. Computes the length of the 5539* specified operand of the EIS instruction, setting len and 5540* lreg. */ 5541 5542 dcl (opno, i) fixed binary; /* Operand number */ 5543 dcl csize fixed binary (18); /* Character size of opnd */ 5544 5545 i = opno; 5546 5547 if mac_base -> descriptor (imac + i).length = "000"b3 5548 then do; 5549 5550 /* Length not given, figure it out */ 5551 5552 csize = get_char_size ((arg (i))); 5553 if csize < 0 /* Constant length */ 5554 then len (i) = csize + bias; 5555 else do; 5556 if addr (rands (csize)) -> node.value_in.eaq 5557 then lreg (i) = eaq_man_load_a_or_q (addr (rands (csize))); 5558 else lreg (i) = xr_man_load_any_xr (addr (rands (csize))); 5559 len (i) = 0; 5560 end; 5561 end; 5562 5563 else len (i) = fixed (mac_base -> descriptor (imac + i).length, 12); 5564 5565 /* If constant length will not fit in 12 bits, put it in an index register */ 5566 5567 if len (i) > 4095 5568 then lreg (i) = xr_man_load_const (len (i)); 5569 5570 /* Reserve register used for length */ 5571 5572 call lock_tag_register ((lreg (i))); 5573 5574 end get_eis_length; 5575 5576 end emit_eis; 5577 5578 /**** ADDRESSING SECTION ****/ 5579 5580 m_a: 5581 procedure (pt); 5582 5583 /* make_addressable */ 5584 5585 dcl (p, pt, s, v) pointer; 5586 5587 p = pt; 5588 5589 if p -> node.is_addressable 5590 then return; 5591 5592 if p -> node.address_in_base 5593 then do; 5594 p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17), 0); 5595 return; 5596 end; 5597 5598 if p -> node.node_type = array_ref_node 5599 then do; 5600 s = addr (rands (p -> array_ref.parent)); 5601 if ^p -> array_ref.has_address 5602 then do; 5603 call print_message (446, fixed (rel (p), 18)); 5604 stop; 5605 end; 5606 5607 if p -> array_ref.variable_offset 5608 then do; 5609 v = addr (rands (p -> array_ref.v_offset)); 5610 if v -> node.value_in.eaq | v -> node.dont_update 5611 /* really node.subs_in_q */ 5612 | p -> array_ref.large_offset 5613 then do; 5614 5615 /* Process array-ref of VLA. 'v' is the total Packed Pointer. If it is in 5616* the Q or A register then we leave it and will later use epp,easp, else if 5617* it is in storage then we can use an lprp. */ 5618 5619 if ^s -> symbol.VLA 5620 then do; 5621 p -> array_ref.address.tag = eaq_man_load_a_or_q (v); 5622 v -> node.dont_update = "0"b; /* really node.subs_in_q */ 5623 end; 5624 5625 end; 5626 else p -> array_ref.address.tag = xr_man_load_any_xr (v); 5627 end; 5628 5629 end; 5630 5631 call m_a_except_xreg (p); 5632 5633 if p -> node.data_type = char_mode & p -> node.units ^= char_units 5634 then do; 5635 if ^from_base_man 5636 then if p -> node.address.tag 5637 then do; 5638 p -> node.addr_hold = substr (unspec (p -> node.address), 1, 18); 5639 p -> node.reloc_hold = p -> node.reloc; 5640 p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17), 0); 5641 p -> node.address.offset = 0; 5642 p -> node.address.tag = "0"b; 5643 p -> node.reloc = rc_a; 5644 end; 5645 end; 5646 5647 5648 end m_a; 5649 5650 m_a_except_xreg: 5651 procedure (pt); 5652 5653 /* make_addressable, but don't call xr_man and don't do special 5654* aligned character addressing. */ 5655 5656 dcl (p, pt) pointer; /* Node to make addressable */ 5657 dcl p1 pointer; /* Node to get adressing info from */ 5658 dcl (i, offset) fixed binary (18); 5659 5660 p = pt; 5661 5662 if p -> node.node_type = array_ref_node 5663 then p1 = addr (rands (p -> array_ref.parent)); 5664 else p1 = p; 5665 5666 if p1 -> node.needs_pointer 5667 then do; 5668 5669 /* prevent a multi-position VLA parameter from missing VLA processing. */ 5670 5671 if p1 -> node.stack_indirect & ^(p1 -> node.node_type = symbol_node & p1 -> symbol.VLA) 5672 then do; 5673 i = 4; 5674 if p1 -> node.node_type = temporary_node 5675 then do; 5676 offset = fixed (substr (p1 -> temporary.addr_hold, 4, 15), 15); 5677 if offset >= 16384 5678 then offset = offset - 32768; 5679 if p1 -> temporary.large_address 5680 then offset = offset + p1 -> temporary.location; 5681 p -> temporary.address.base = base_man_load_any_pr (i, offset, 0); 5682 return; 5683 end; 5684 end; 5685 5686 /* Must be a symbol node */ 5687 5688 else if p1 -> symbol.VLA 5689 then do; 5690 p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17, 0), 0); 5691 return; 5692 end; /* we are pointer at our pointer */ 5693 else if p1 -> symbol.LA 5694 then do; 5695 if p1 -> symbol.static 5696 then i = 11; /* static indirect */ 5697 else i = 4; /* stack */ 5698 p1 = addr (rands (p1 -> symbol.parent)); 5699 end; 5700 else if p1 -> symbol.in_common 5701 then do; 5702 i = 3; 5703 p1 = addr (rands (p1 -> symbol.parent)); 5704 end; 5705 else if p1 -> symbol.parameter 5706 then i = 2; 5707 else if p1 -> symbol.descriptor 5708 then i = 10; 5709 else do; 5710 call print_message (417, fixed (rel (p), 18)); 5711 return; 5712 end; 5713 5714 if ^p -> symbol.large_address 5715 then p -> symbol.address.base = base_man_load_any_pr (i, (p1 -> node.location), 0); 5716 else p -> symbol.address.base = base_man_load_any_pr (i, (p1 -> node.location), (p -> symbol.location)); 5717 end; 5718 5719 else if p1 -> node.node_type = symbol_node 5720 then do; 5721 if p1 -> symbol.external & p1 -> symbol.initial ^= 0 5722 then do; 5723 5724 /* have an external subr or func reference 5725* that is really local */ 5726 5727 p1 = addr (rands (p1 -> symbol.initial)); 5728 5729 if p1 -> symbol.allocated 5730 then do; 5731 unspec (p -> symbol.address) = unspec (p1 -> symbol.address); 5732 p -> symbol.allocated, p -> symbol.is_addressable = "1"b; 5733 end; 5734 end; 5735 5736 else if p1 -> symbol.parameter 5737 then p -> node.address.base = base_man_load_arg_ptr (); 5738 5739 else call m_a_check_large_address (p, p1); 5740 end; 5741 5742 else call m_a_check_large_address (p, p1); 5743 5744 end m_a_except_xreg; 5745 5746 m_a_check_large_address: 5747 procedure (pt, pt1); 5748 5749 /* Handles large addresses */ 5750 5751 dcl (pt, p, pt1, p1) pointer; 5752 dcl usual_base bit (3) aligned; 5753 dcl i fixed binary (18); 5754 5755 p = pt; 5756 p1 = pt1; 5757 5758 if p -> node.large_address 5759 then do; 5760 5761 /* have abs(address) >= 16K */ 5762 5763 usual_base = sp; 5764 if p1 -> node.node_type = symbol_node 5765 then if p1 -> symbol.static | p1 -> symbol.external 5766 then usual_base = lp; 5767 5768 i = p -> node.location; 5769 5770 if i ^= 0 5771 then p -> node.address.base = base_man_load_large_base (i, usual_base); 5772 else p -> node.address.base = usual_base; 5773 5774 end; 5775 5776 end m_a_check_large_address; 5777 5778 increment_address: 5779 procedure (p, inc); 5780 5781 /* Applies increment to address of node */ 5782 5783 dcl p pointer, 5784 inc fixed binary (18); 5785 5786 dcl (loc, offset) fixed binary (18); 5787 5788 if ^p -> node.large_address 5789 then p -> node.address.offset = p -> node.address.offset + inc; 5790 5791 else do; 5792 loc, offset = p -> node.address.offset + p -> node.location + inc; 5793 offset = mod (offset + 16384, 32768) - 16384; 5794 p -> node.location = loc - offset; 5795 p -> node.address.offset = offset; 5796 end; 5797 5798 end increment_address; 5799 5800 c_a: 5801 procedure (c, code) returns (bit (36) aligned); 5802 5803 /* Fabricates a constant address to be used with emit_c_a */ 5804 5805 dcl (c, n, code) fixed binary (18); 5806 5807 dcl 1 inst_address aligned like symbol.address; 5808 5809 n = c; 5810 unspec (inst_address) = "0"b; 5811 go to sw (code); 5812 5813 sw (1): /* n,ql */ 5814 inst_address.tag = QL_mod; 5815 go to exit; 5816 5817 sw (5): /* location n in the linkage section */ 5818 inst_address.base = lp; 5819 go to set_ext_base; 5820 5821 sw (6): /* location n in the stack */ 5822 inst_address.base = sp; 5823 go to set_ext_base; 5824 5825 sw (3): /* location n indirect in linkage section */ 5826 sw (11): /* location n indirect in static section */ 5827 inst_address.base = lp; 5828 go to indirect; 5829 5830 sw (4): /* location n indirect in stack */ 5831 inst_address.base = sp; 5832 5833 indirect: 5834 inst_address.tag = inst_address.tag | "010000"b; 5835 5836 set_ext_base: 5837 inst_address.ext_base = "1"b; 5838 5839 if n >= 16384 5840 then do; 5841 n = mod (n + 16384, 32768) - 16384; 5842 inst_address.base = base_man_load_large_base (c - n, (inst_address.base)); 5843 end; 5844 5845 exit: 5846 inst_address.offset = n; 5847 return (unspec (inst_address)); 5848 5849 end c_a; 5850 5851 c_a_18: 5852 procedure (n, code) returns (bit (36) aligned); 5853 5854 /* Fabricates a constant address with 18 bit offset field 5855* for use with emit_c_a. */ 5856 5857 dcl n fixed binary (18); /* Offset */ 5858 dcl code fixed binary (18); /* 1 = DU */ 5859 5860 dcl 1 inst_address aligned, 5861 2 offset fixed binary (17) unaligned, 5862 2 op_code bit (10) unaligned, 5863 2 inhibit bit (1) unaligned, 5864 2 ext_base bit (1) unaligned, 5865 2 tag bit (6) unaligned; 5866 5867 unspec (inst_address) = "0"b; 5868 5869 inst_address.offset = n; 5870 5871 if code = 1 5872 then inst_address.tag = DU_mod; 5873 5874 return (unspec (inst_address)); 5875 5876 end c_a_18; 5877 5878 make_both_addressable: 5879 procedure (arg, inc); 5880 5881 /* Makes two operands simultaneously addressable by reserving 5882* registers as it goes. */ 5883 5884 dcl arg (2) pointer; 5885 dcl inc (2) fixed binary (18); 5886 dcl (i, reg) fixed binary (3); 5887 dcl p pointer; 5888 5889 do i = 1 to 2; 5890 5891 p = arg (i); 5892 5893 if ^p -> node.is_addressable 5894 then do; 5895 5896 if inc (i) ^= 0 & p -> node.address.ext_base 5897 then call increment_address (p, inc (i)); 5898 5899 call m_a (p); 5900 5901 /* Reserve any XRs or EAQ registers used */ 5902 5903 call lock_tag_register ((p -> node.address.tag)); 5904 5905 /* Reserve any base registers used */ 5906 5907 if p -> node.address.ext_base 5908 then do; 5909 reg = which_base (fixed (p -> node.address.base, 3)); 5910 machine_state.base_regs (reg).reserved = "1"b; /* lock for use in addressing */ 5911 end; 5912 5913 end; 5914 5915 end; 5916 5917 end make_both_addressable; 5918 5919 /**** GET_FREE_REG ****/ 5920 5921 get_free_reg: 5922 procedure (regs, first, last, k) returns (fixed binary (3)); 5923 5924 /* Implements register searching algorithm */ 5925 5926 dcl 1 regs (0:7) aligned like base_regs, 5927 (first, last) fixed binary (18), /* Limits of search */ 5928 k fixed binary (3); /* Register already found to be empty */ 5929 5930 dcl (i, j) fixed binary (3); 5931 dcl lused fixed binary (18); 5932 5933 if k > 0 5934 then if ^regs (k).reserved 5935 then return (k); 5936 5937 j = -1; 5938 lused = 131071; 5939 5940 do i = first to last; 5941 5942 if ^regs (i).reserved 5943 then do; 5944 if regs (i).type = 0 5945 then return (i); 5946 if regs (i).used < lused 5947 then do; 5948 lused = regs (i).used; 5949 j = i; 5950 end; 5951 end; 5952 5953 end; 5954 5955 if j < 0 5956 then call print_message (418); 5957 else return (j); 5958 5959 end get_free_reg; 5960 5961 /**** POINTER REGISTER MANAGEMENT ****/ 5962 5963 /* The contents of the pointer registers are determined by the 5964* value of the type field as follows: 5965* (v = variable field) 5966* 5967* -1 UNKNOWN 5968* 0 EMPTY 5969* 1 address of operand specified by v 5970* 2 ptr to loc v in arg list 5971* 3 ptr thru link with offset v 5972* 4 ptr at at stack offset v 5973* 5 arg list ptr 5974* 6 linkage ptr 5975* 7 value of operand specified by v 5976* 8 stack ptr 5977* 9 ptr to arg desc list 5978* 10 ptr to loc v in desc list 5979* 11 ptr thru static with offset v 5980* */ 5981 5982 base_man_load_any_pr: 5983 procedure (code, num, offset) returns (bit (3) aligned); 5984 5985 dcl (n, code) fixed binary (18), /* Type of operation */ 5986 (v, num) fixed binary (18), /* Location of ptr to be loaded */ 5987 (off, offset) fixed binary (18); /* Offset to be added to pointer */ 5988 5989 dcl VLA bit (1); /* True if VLA */ 5990 dcl s ptr; 5991 5992 dcl (i, j, k) fixed bin (3); 5993 dcl address bit (36) aligned; 5994 dcl diff fixed bin (18); 5995 5996 n = code; 5997 v = num; 5998 diff, off = offset; 5999 6000 j, k = 0; 6001 6002 do i = first_base to last_base; 6003 if base_regs (i).type = 0 6004 then k = i; 6005 else if base_regs (i).type = n 6006 then if base_regs (i).variable = v 6007 then if base_regs (i).offset = off 6008 then do; 6009 base_regs (i).used = text_pos; 6010 return (bases (i)); 6011 end; 6012 else j = i; 6013 end; 6014 6015 if j > 0 6016 then do; 6017 6018 /* Right storage area, but wrong offset */ 6019 6020 diff = off - base_regs (j).offset; 6021 address = c_a (0, 6); 6022 substr (address, 1, 3) = bases (j); 6023 i = get_free_reg (base_regs, first_base, last_base, k); 6024 call flush_base (i); 6025 call emit_c_a ((load_base (i)), address); 6026 end; 6027 6028 else if n = 1 6029 then do; 6030 s = addr (rands (v)); 6031 if s -> node.node_type = symbol_node 6032 then VLA = s -> symbol.VLA; 6033 else if s -> node.node_type = array_ref_node 6034 then VLA = addr (rands (s -> array_ref.parent)) -> symbol.VLA; 6035 else VLA = "0"b; 6036 s -> node.address_in_base = "1"b; 6037 machine_state.address_in_base = "1"b; 6038 i = get_free_reg (base_regs, first_base, last_base, k); 6039 call flush_base (i); 6040 6041 /* A very large reference can be of two types: 6042* 1. array-reference. in this case the vsum of the reference is in memory 6043* and is the total addressor needed by lprp. 6044* 2. normal-reference. in this case the address in the symbol node is 6045* sufficient to address directly a base to the variable for 6046* lprp. 6047* */ 6048 6049 if VLA 6050 then call base_man_load_VLA (v, i); 6051 else call emit_c_a_var ((load_base (i)), addr (rands (v))); 6052 end; 6053 6054 else if n = 2 | n = 10 6055 then do; 6056 address = c_a (v, 4); 6057 if n = 2 6058 then substr (address, 1, 3) = base_man_load_arg_ptr (); 6059 else substr (address, 1, 3) = base_man_load_desc_ptr (); 6060 6061 i = get_free_reg (base_regs, first_base, last_base, 0); 6062 call flush_base (i); 6063 call emit_c_a ((load_base (i)), address); 6064 end; 6065 6066 else do; 6067 6068 address = c_a (v, n); 6069 6070 if v >= 16384 6071 then k = 0; /* base_regs state was changed */ 6072 6073 i = get_free_reg (base_regs, first_base, last_base, k); 6074 call flush_base (i); 6075 6076 if n = 3 /* linkage indirect */ 6077 then reloc (text_pos).left_rel = rc_lp15; 6078 else if n = 11 /* static indirect */ 6079 then reloc (text_pos).left_rel = rc_is15; 6080 6081 call emit_c_a ((load_base (i)), address); 6082 6083 end; 6084 6085 if diff ^= 0 6086 then call emit_c_a ((add_base (i)), c_a_18 (diff, 1)); 6087 6088 base_regs (i).type = n; 6089 base_regs (i).variable = v; 6090 base_regs (i).offset = off; 6091 base_regs (i).used = text_pos; 6092 6093 return (bases (i)); 6094 6095 end base_man_load_any_pr; 6096 6097 base_man_load_VLA: 6098 proc (op, i); 6099 6100 dcl op fixed bin (18); 6101 dcl (loc_p, s, p, v) ptr; 6102 dcl i fixed bin (3); 6103 dcl address bit (36) aligned; 6104 dcl 1 inst_address like symbol.address based (addr (address)); 6105 dcl location fixed bin (18); /* address of operand */ 6106 6107 /* Do addressing in the following situations. 6108* 6109* 1. Simple reference. Use the 256K pointer directly at the symbol. 6110* 2. Array reference. Use the 255K pointer if 'VLA_is_255K', else use 6111* the packed pointer. The 255K pointer is either in the A or Q or 6112* stored at 'v_offset'. Set the listing to indicate the symbol. */ 6113 6114 /* p is the pointer to the operand supplied. 6115* s is the pointer to the symbol involved. 6116* v is the pointer to the node whose address will be loaded. */ 6117 6118 p = addr (rands (op)); 6119 if p -> node.node_type = array_ref_node 6120 then do; 6121 s = addr (rands (p -> array_ref.parent)); /* symbol */ 6122 v = addr (rands (p -> array_ref.v_offset)); /* addressor */ 6123 end; 6124 else v, s = p; /* symbol and addressor */ 6125 6126 reloc (text_pos).left_rel = v -> node.reloc; 6127 6128 /* Use array name in listing. */ 6129 6130 if assembly_list 6131 then a_name (text_pos) = binary (rel (s), 18, 0); 6132 6133 /* if we are dealing with the symbol direct, then use its addressing info, else 6134* use the addressing info of the v_offset temp, which is in the stack */ 6135 6136 if v ^= s /* not symbol */ 6137 then loc_p = v; /* array_ref */ 6138 else loc_p = s; /* symbol */ 6139 6140 /* if this is a non-dimensioned VLA symbol, use it's saved 6141* offset information. */ 6142 if v = s & ^s -> symbol.dimensioned 6143 then substr (unspec (s -> symbol.address), 1, 18) = s -> symbol.addr_hold; 6144 6145 if loc_p -> symbol.large_address 6146 then location = loc_p -> node.address.offset + loc_p -> node.location; 6147 else location = loc_p -> node.address.offset; 6148 6149 if v ^= s 6150 then address = c_a (location, 6); /* array_ref */ 6151 else if loc_p -> symbol.in_common | loc_p -> symbol.static 6152 then address = c_a (location, 5); /* static/common */ 6153 else address = c_a (location, 6); /* auto */ 6154 6155 /* If the subscript calculated is aready in the A or the Q then we can do 6156* work directly. Else we load the packed base. */ 6157 6158 if s ^= v & v -> node.value_in.eaq 6159 then do; 6160 address = "0"b; 6161 if get_eaq_name ((p -> array_ref.v_offset)) = in_q 6162 then do; /* use Q addressing */ 6163 inst_address.tag = QL_mod; /* load segment with text ring */ 6164 call emit_c_a ((load_base (i)), address); 6165 inst_address.tag = QU_mod; /* load word number */ 6166 call emit_c_a ((load_segment_num (i)), address); 6167 end; 6168 else do; /* use A addressing */ 6169 inst_address.tag = AL_mod; /* load segment with text ring */ 6170 call emit_c_a ((load_base (i)), address); 6171 inst_address.tag = AU_mod; /* load word */ 6172 call emit_c_a ((load_segment_num (i)), address); 6173 end; 6174 end; 6175 else do; 6176 call emit_c_a ((load_packed_base (i)), address); 6177 6178 /* for symbols (not array_refs), zero the offset in the 6179* symbol, since all references through the pointer just 6180* created must be prN|0 references. */ 6181 if v = s & ^s -> symbol.dimensioned 6182 then s -> symbol.address.offset = 0; 6183 end; 6184 end base_man_load_VLA; 6185 6186 flush_base: 6187 procedure (i); 6188 6189 /* Empties a pointer register prior to reuse */ 6190 6191 dcl i fixed binary (3); /* Base reg to flush */ 6192 dcl p pointer; 6193 6194 if machine_state.base_regs (i).type = 1 6195 then do; 6196 p = addr (rands (machine_state.base_regs (i).variable)); 6197 p -> node.address_in_base = "0"b; 6198 6199 if p -> node.stack_indirect 6200 then if p -> node.node_type = temporary_node 6201 then if p -> temporary.not_in_storage 6202 then do; 6203 6204 /* Store pointer to dynamic temp */ 6205 6206 call base_man_store_temp (p, (i)); 6207 return; 6208 end; 6209 6210 /* Restore address of aligned character string */ 6211 6212 substr (unspec (p -> node.address), 1, 18) = p -> node.addr_hold; 6213 p -> node.reloc = p -> node.reloc_hold; 6214 6215 end; 6216 6217 end flush_base; 6218 6219 base_man_load_pr: 6220 procedure (opnd, which); 6221 6222 /* Loads the address of an operand into the 6223* specified register and reserves the register */ 6224 6225 dcl opnd fixed binary (18), /* Index of operand */ 6226 which fixed binary (18); /* Register to use */ 6227 6228 dcl i fixed binary (3); 6229 dcl op fixed binary (18); 6230 dcl p pointer; 6231 dcl 1 inst_address aligned like node.address; 6232 dcl tag_hold bit (6) aligned; 6233 dcl char_num_hold fixed bin (2) aligned; 6234 dcl VLA bit (1); 6235 6236 from_base_man = "1"b; 6237 6238 i = which; 6239 op = opnd; 6240 p = addr (rands (op)); 6241 6242 /* force addressability so we can look at the address */ 6243 6244 if p -> node.node_type = symbol_node 6245 then VLA = p -> symbol.VLA; 6246 else if p -> node.node_type = array_ref_node 6247 then VLA = addr (rands (p -> array_ref.parent)) -> symbol.VLA; 6248 else VLA = "0"b; 6249 6250 if ^p -> node.is_addressable & ^VLA /* VLA is always addressable */ 6251 then call m_a (p); 6252 6253 if p -> node.units = char_units 6254 then do; 6255 6256 /* Tag specifies a character offset in a register. Save 6257* the tag, so epp does not use it, and deal with it 6258* manually below. Do the same for char_num. */ 6259 6260 tag_hold = p -> node.address.tag; 6261 p -> node.address.tag = "00"b3; 6262 char_num_hold = p -> node.address.char_num; 6263 p -> node.address.char_num = 0; 6264 end; 6265 6266 call flush_base (i); 6267 6268 /* A very large reference can be of two types: 6269* 1. array-reference. in this case the vsum of the reference is in memory 6270* and is the total addressor needed by lprp. 6271* 2. normal-reference. in this case the address in the symbol node is 6272* sufficient to address directly a base to the variable for 6273* lprp. 6274* */ 6275 /* If we are dealing in char_units, then we want to avoid 6276* calling m_a and setting the node.address.tag. Therefore, 6277* we use emit_c_a_var instead of emit_single. */ 6278 6279 if p -> node.address.base ^= bases (i) | ^p -> node.address.ext_base | p -> node.address.offset ^= 0 6280 | p -> node.address.tag ^= "00"b3 6281 then if p -> node.units = char_units /* characters cannot be VLA's so no code here. */ 6282 then call emit_c_a_var ((load_base (i)), p); 6283 else if VLA 6284 then call base_man_load_VLA (op, i); 6285 else call emit_single ((load_base (i)), op); 6286 6287 if p -> node.units = char_units 6288 then do; 6289 6290 /* Handle character offsets */ 6291 6292 unspec (inst_address) = ext_base_on; /* Initialize address for a9bd instructions */ 6293 inst_address.base = bases (i); 6294 6295 if char_num_hold ^= 0 6296 then if tag_hold & "001000"b 6297 then do; 6298 6299 /* Have constant offset + offset in XR */ 6300 6301 inst_address.tag = xr_man_add_const (binary (substr (tag_hold, 4, 3), 3), (char_num_hold)); 6302 call emit_c_a (a9bd, unspec (inst_address)); 6303 end; 6304 6305 else if tag_hold ^= "00"b3 6306 then do; 6307 6308 /* Have constant offset + offset not in XR */ 6309 6310 inst_address.tag = xr_man_load_const ((char_num_hold)); 6311 call emit_c_a (a9bd, unspec (inst_address)); 6312 inst_address.tag = tag_hold; 6313 call emit_c_a (a9bd, unspec (inst_address)); 6314 end; 6315 6316 else do; 6317 6318 /* Constant offset only */ 6319 6320 inst_address.tag = xr_man_load_const ((char_num_hold)); 6321 call emit_c_a (a9bd, unspec (inst_address)); 6322 end; 6323 6324 else if tag_hold ^= "00"b3 6325 then do; 6326 6327 /* Variable offset only */ 6328 6329 inst_address.tag = tag_hold; 6330 call emit_c_a (a9bd, unspec (inst_address)); 6331 end; 6332 6333 p -> node.address.tag = tag_hold; /* Restore original tag */ 6334 p -> node.address.char_num = char_num_hold; /* and char_num */ 6335 6336 end; 6337 6338 machine_state.base_regs (i).reserved = "1"b; /* Lock for use in addressing */ 6339 machine_state.base_regs (i).type = -1; /* Unknown value */ 6340 machine_state.base_regs (i).variable = op; /* debugging */ 6341 machine_state.base_regs (i).offset = 0; 6342 machine_state.base_regs (i).used = text_pos; 6343 6344 from_base_man = "0"b; 6345 6346 end base_man_load_pr; 6347 6348 base_man_load_pr_value: 6349 procedure (opnd, which); 6350 6351 /* Loads the value of an operand into the specified register */ 6352 6353 dcl opnd fixed binary (18), /* Index of operand */ 6354 which fixed binary (18); /* Register to use */ 6355 6356 dcl i fixed binary (3); 6357 dcl op fixed binary (18); 6358 dcl p pointer; 6359 6360 op = opnd; 6361 p = addr (rands (op)); 6362 i = which; 6363 6364 /* load value if it is not loaded already */ 6365 6366 if machine_state.base_regs (i).type ^= 7 | machine_state.base_regs (i).variable ^= op 6367 | machine_state.base_regs (i).offset ^= 0 6368 then do; 6369 6370 /* Force addressability so we can look at the address */ 6371 6372 if ^p -> node.is_addressable 6373 then call m_a (p); 6374 6375 call flush_base (i); 6376 6377 if substr (p -> node.address.tag, 1, 2) /* inst addr already has a modifier */ 6378 then call print_message (416, op); /* illegal address field */ 6379 6380 substr (p -> node.address.tag, 1, 2) = "01"b;/* RI */ 6381 6382 call emit_c_a_var ((load_base (i)), p); 6383 6384 substr (p -> node.address.tag, 1, 2) = "00"b;/* Restore tag */ 6385 6386 base_regs (i).type = 7; /* value of op in pr */ 6387 base_regs (i).variable = op; /* debugging */ 6388 base_regs (i).offset = 0; 6389 end; 6390 6391 base_regs (i).used = text_pos; 6392 6393 end base_man_load_pr_value; 6394 6395 base_man_load_large_base: 6396 procedure (offset, base) returns (bit (3) aligned); 6397 6398 /* Loads pointer register with contents(base) + offset. 6399* This routine is used to deal with address offsets >= 16K. */ 6400 6401 dcl (off, offset) fixed binary (18); 6402 dcl base bit (3) aligned; /* MUST be sp or lp */ 6403 6404 dcl (i, k) fixed binary (3); 6405 dcl code fixed binary (18); 6406 dcl 1 inst_address aligned like symbol.address; 6407 6408 off = offset; 6409 6410 if base = lp 6411 then code = 6; 6412 else code = 8; 6413 6414 k = 0; 6415 6416 do i = first_base to last_base; 6417 if base_regs (i).type = 0 6418 then k = i; 6419 else if base_regs (i).type = code & base_regs (i).offset = off 6420 then do; 6421 base_regs (i).used = text_pos; 6422 return (bases (i)); 6423 end; 6424 6425 end; 6426 6427 i = get_free_reg (base_regs, first_base, last_base, k); 6428 6429 call flush_base (i); 6430 6431 unspec (inst_address) = ext_base_on; 6432 inst_address.base = base; 6433 6434 call emit_c_a ((load_base (i)), unspec (inst_address)); 6435 call emit_c_a ((add_base (i)), c_a_18 (off, 1)); 6436 6437 base_regs (i).type = code; 6438 base_regs (i).variable = 0; 6439 base_regs (i).offset = off; 6440 base_regs (i).used = text_pos; 6441 6442 return (bases (i)); 6443 6444 end base_man_load_large_base; 6445 6446 base_man_load_large_base_no_flush: 6447 procedure (offset, base, which) returns (bit (3) aligned); 6448 6449 /* Analogous to base_man_load_large_base, except that the 6450* register to load is specified and flush_base is not called, 6451* to avoid recursion. */ 6452 6453 dcl offset fixed binary (18); 6454 dcl base bit (3) aligned; 6455 dcl which fixed binary (3); 6456 6457 dcl 1 inst_address like node.address; 6458 6459 unspec (inst_address) = ext_base_on; 6460 inst_address.base = base; 6461 6462 call emit_c_a ((load_base (which)), unspec (inst_address)); 6463 call emit_c_a ((add_base (which)), c_a_18 ((offset), 1)); 6464 6465 if base = sp 6466 then base_regs (which).type = 8; 6467 else base_regs (which).type = 6; 6468 base_regs (which).variable = 0; 6469 base_regs (which).offset = offset; 6470 base_regs (which).used = text_pos; 6471 6472 return (bases (which)); 6473 6474 end base_man_load_large_base_no_flush; 6475 6476 base_man_load_arg_ptr: 6477 procedure () returns (bit (3) aligned); 6478 6479 /* Loads a pointer register with a pointer to the argument list. */ 6480 6481 dcl (i, k) fixed binary (3); 6482 dcl n fixed binary (18); 6483 6484 k = 0; 6485 6486 do i = first_base to last_base; 6487 if machine_state.base_regs (i).type = 0 6488 then k = i; 6489 else if machine_state.base_regs (i).type = 5 6490 then do; 6491 machine_state.base_regs (i).used = text_pos; 6492 return (bases (i)); 6493 end; 6494 end; 6495 6496 i = get_free_reg (machine_state.base_regs, first_base, last_base, k); 6497 call flush_base (i); 6498 6499 if cs -> subprogram.subprogram_type = main_program 6500 then n = arg_ptr; 6501 else n = cs -> subprogram.entry_info + 2; 6502 6503 call emit_c_a ((load_base (i)), c_a (n, 4)); 6504 6505 machine_state.base_regs (i).type = 5; 6506 machine_state.base_regs (i).variable = 0; 6507 machine_state.base_regs (i).used = text_pos; 6508 machine_state.base_regs (i).offset = 0; 6509 6510 return (bases (i)); 6511 6512 end base_man_load_arg_ptr; 6513 6514 base_man_load_desc_ptr: 6515 procedure () returns (bit (3) aligned); 6516 6517 /* Loads any pointer register with a pointer to the argument 6518* descriptor list. */ 6519 6520 dcl (i, k) fixed binary (3); 6521 dcl n fixed binary (18); 6522 6523 k = 0; 6524 6525 do i = first_base to last_base; 6526 if base_regs (i).type = 0 6527 then k = i; 6528 else if base_regs (i).type = 9 6529 then do; 6530 base_regs (i).used = text_pos; 6531 return (bases (i)); 6532 end; 6533 end; 6534 6535 i = get_free_reg (base_regs, first_base, last_base, k); 6536 call flush_base (i); 6537 6538 if cs -> subprogram.subprogram_type = main_program 6539 then n = descriptor_ptr; 6540 else n = cs -> subprogram.entry_info + 4; 6541 6542 call emit_c_a ((load_base (i)), c_a (n, 4)); 6543 6544 base_regs (i).type = 9; 6545 base_regs (i).variable = 0; 6546 base_regs (i).used = text_pos; 6547 base_regs (i).offset = 0; 6548 6549 return (bases (i)); 6550 6551 end base_man_load_desc_ptr; 6552 6553 base_man_store_temp: 6554 procedure (temp_ptr, which); 6555 6556 /* Emits code to store a pointer temporary. Note that since 6557* this routine is called from flush_base, we must be careful 6558* to not use any pointer registers which may require flushing 6559* to avoid recursion. */ 6560 6561 dcl (temp_ptr, tp) pointer; 6562 dcl (which, temp_reg) fixed binary (3); 6563 6564 dcl 1 inst_address like node.address; 6565 dcl (free_reg, large_base_reg, i) fixed binary (3); 6566 dcl was_reserved bit (1) aligned; 6567 6568 tp = temp_ptr; 6569 temp_reg = which; 6570 6571 unspec (inst_address) = tp -> temporary.addr_hold; 6572 inst_address.ext_base = "1"b; 6573 6574 tp -> temporary.not_in_storage = "0"b; 6575 6576 /* If the temp is simply addressable, just store it */ 6577 6578 if ^tp -> temporary.large_address 6579 then do; 6580 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 6581 return; 6582 end; 6583 6584 /* See if there is a pointer register which already points to 6585* the correct region for the large address. */ 6586 6587 free_reg, large_base_reg = 0; 6588 do i = first_base to last_base while (large_base_reg = 0); 6589 if base_regs (i).type = 0 6590 then free_reg = i; 6591 else if base_regs (i).type = 8 & base_regs (i).offset = tp -> temporary.location 6592 then large_base_reg = i; 6593 end; 6594 6595 /* If there is such a pointer register, use it */ 6596 6597 if large_base_reg > 0 6598 then do; 6599 base_regs (large_base_reg).used = text_pos; 6600 inst_address.base = bases (large_base_reg); 6601 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 6602 return; 6603 end; 6604 6605 /* Try to get an empty register, or any register which does 6606* not require flushing. Avoid the register we are trying to 6607* store by pretending it is reserved for the moment. */ 6608 6609 was_reserved = base_regs (temp_reg).reserved; 6610 base_regs (temp_reg).reserved = "1"b; 6611 i = get_free_reg (base_regs, first_base, last_base, free_reg); 6612 base_regs (temp_reg).reserved = was_reserved; 6613 6614 if base_regs (i).type ^= 1 6615 then do; 6616 inst_address.base = base_man_load_large_base_no_flush ((tp -> temporary.location), sp, i); 6617 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 6618 return; 6619 end; 6620 6621 /* Try to use pr4 as a last resort. */ 6622 6623 i = which_base (4); 6624 6625 if base_regs (i).reserved 6626 then call print_message (467); /* Sigh */ 6627 6628 inst_address.base = base_man_load_large_base_no_flush ((tp -> temporary.location), sp, i); 6629 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 6630 6631 call emit_zero (getlp); /* Restore pr4 */ 6632 6633 end base_man_store_temp; 6634 6635 /**** INDEX REGISTER MANAGEMENT ****/ 6636 6637 /* The contents of the index registers are determined by the 6638* value of the type field as follows: 6639* (v = variable field) 6640* 6641* -1 UNKNOWN 6642* 0 EMPTY 6643* 1 value v 6644* 2 constant value c 6645* */ 6646 6647 xr_man_load_any_xr: 6648 procedure (pt) returns (bit (6) aligned); 6649 6650 /* Loads an operand into any index register */ 6651 6652 dcl pt pointer; /* Points at value to be loaded */ 6653 6654 dcl p pointer; 6655 dcl v fixed binary (18); 6656 dcl i fixed binary (3); 6657 6658 p = pt; 6659 v = fixed (rel (p), 18); 6660 6661 if p -> node.value_in.x 6662 then do; 6663 do i = first_index to last_index; 6664 if index_regs (i).type = 1 6665 then if index_regs (i).variable = v 6666 then do; 6667 machine_state.index_regs (i).used = text_pos; 6668 return ("001"b || bit (i, 3)); 6669 end; 6670 end; 6671 call print_message (430, v); 6672 return ("00"b3); 6673 end; 6674 6675 i = get_free_reg (index_regs, first_index, last_index, 0); 6676 6677 call flush_xr (i); 6678 6679 call use_ind; 6680 6681 if p -> node.value_in.eaq 6682 then call emit_c_a (eax0 + i, c_a (0, 1)); 6683 6684 else do; 6685 if p -> node.not_in_storage 6686 then call print_message (419, v); 6687 6688 if ^p -> node.is_addressable 6689 then call m_a_except_xreg (p); 6690 6691 call emit_c_a_var (lxl0 + i, p); 6692 end; 6693 6694 index_regs (i).type = 1; 6695 index_regs (i).variable = v; 6696 p -> node.value_in.x = "1"b; 6697 index_regs (i).used = text_pos; 6698 machine_state.value_in_xr = "1"b; 6699 6700 return ("001"b || bit (i, 3)); 6701 6702 end xr_man_load_any_xr; 6703 6704 flush_xr: 6705 procedure (which); 6706 6707 /* Empties an index register prior to reuse */ 6708 6709 dcl which fixed binary (3); /* Index reg to flush */ 6710 6711 dcl i fixed bin (18); 6712 dcl p ptr; 6713 6714 if index_regs (which).type ^= 1 6715 then return; 6716 6717 i = which; 6718 6719 p = addr (rands (index_regs (i).variable)); 6720 p -> node.value_in.x = "0"b; 6721 6722 /* the value has not been previously stored, so do so */ 6723 6724 if p -> node.not_in_storage 6725 then do; 6726 call emit_temp_store (sxl0 + i, index_regs (i).variable); 6727 end; 6728 6729 end flush_xr; 6730 6731 xr_man_load_const: 6732 procedure (csize) returns (bit (6) aligned); 6733 6734 /* Loads a constant into any index register */ 6735 6736 dcl csize fixed binary (18); /* Constant to be loaded */ 6737 6738 dcl (i, k) fixed binary (3); 6739 dcl c fixed binary (18); 6740 6741 c = csize; 6742 6743 if const_in_xr (c, first_index, k) 6744 then do; 6745 index_regs (k).used = text_pos; 6746 return ("001"b || bit (binary (k, 3), 3)); 6747 end; 6748 6749 i = get_free_reg (index_regs, first_index, last_index, k); 6750 6751 call flush_xr (i); 6752 6753 call use_ind; 6754 6755 call emit_c_a (eax0 + i, c_a_18 (c, 0)); 6756 6757 index_regs (i).type = 2; 6758 index_regs (i).variable = c; 6759 index_regs (i).used = text_pos; 6760 6761 return ("001"b || bit (i, 3)); 6762 6763 end xr_man_load_const; 6764 6765 const_in_xr: 6766 procedure (value, first_xr, xr_num) returns (bit (1) aligned); 6767 6768 /* Procedure to find xr containing a particular constant value 6769* or find an empty xr. */ 6770 6771 dcl value fixed binary (18); /* Constant value required in xr */ 6772 dcl first_xr fixed binary (18); /* First xr to be checked */ 6773 dcl xr_num fixed binary (3); /* Xr containing value or a free xr */ 6774 dcl c fixed binary (18); 6775 dcl i fixed binary (3); 6776 6777 xr_num = 0; /* initialize - no xr found */ 6778 c = value; 6779 6780 do i = first_xr to last_index; 6781 if index_regs (i).type = 0 6782 then xr_num = i; 6783 else if index_regs (i).type = 2 6784 then if index_regs (i).variable = c 6785 then do; 6786 xr_num = i; 6787 return ("1"b); 6788 end; 6789 end; 6790 6791 return ("0"b); 6792 6793 end const_in_xr; 6794 6795 xr_man_add_const: 6796 procedure (which, csize) returns (bit (6) aligned); 6797 6798 /* Add a constant to the value in an index register */ 6799 6800 dcl which fixed binary (3); 6801 dcl csize fixed binary (18); 6802 6803 dcl c fixed binary (18); 6804 dcl (i, j) fixed binary (3); 6805 dcl address bit (36) aligned; 6806 6807 6808 i = which; 6809 c = csize; 6810 address = (36)"0"b; 6811 substr (address, 1, 18) = bit (c, 18); /* Set offset portion */ 6812 substr (address, 31, 6) = bit (fixed (i + 8, 6), 6); 6813 /* Set tag portion */ 6814 6815 j = get_free_reg (machine_state.index_regs, first_index, last_index, 0); 6816 6817 call flush_xr (j); 6818 call use_ind (); 6819 call emit_c_a (eax0 + j, address); /* Emit eax_m const,n */ 6820 6821 /* Although the index register we just loaded is not really empty, 6822* we will say it is because xr_man does not have the notion 6823* of a variable plus a constant in a register. This will only work 6824* if the next instruction emitted uses the index register and 6825* does not call for some other index register to be loaded. */ 6826 6827 machine_state.index_regs (j).type = 0; /* Empty */ 6828 machine_state.index_regs (j).variable = 0; 6829 machine_state.index_regs (j).used = text_pos; 6830 6831 return (bit (fixed (j + 8, 6), 6)); /* Return XR modifier */ 6832 6833 end xr_man_add_const; 6834 6835 /**** GENERAL REGISTER MANAGEMENT ****/ 6836 6837 reserve_regs: 6838 procedure (what); 6839 6840 /* Reserves index and base registers */ 6841 6842 dcl (what, reserve) bit (14) aligned; /* Mask specifying which regs to reserve */ 6843 dcl i fixed binary (18); 6844 dcl j fixed binary (3); 6845 dcl length builtin; 6846 6847 reserve = what; 6848 6849 do i = 1 to length (reserve); 6850 if substr (reserve, i, 1) 6851 then if i <= 8 6852 then do; 6853 j = i - 1; 6854 call flush_xr (j); 6855 machine_state.index_regs (j).reserved = "1"b; 6856 machine_state.index_regs (j).type = -1; 6857 /* Unknown value */ 6858 end; 6859 else do; 6860 j = i - 8; 6861 call flush_base (j); 6862 machine_state.base_regs (j).reserved = "1"b; 6863 machine_state.base_regs (j).type = -1; 6864 /* Unknown value */ 6865 machine_state.base_regs (j).variable = 0; 6866 /* debugging */ 6867 machine_state.base_regs (j).offset = 0; 6868 end; 6869 end; 6870 6871 end reserve_regs; 6872 6873 free_regs: 6874 procedure (); 6875 6876 /* Frees all reserved registers (index, base, and eaq) 6877* reloading pr4 if necessary */ 6878 6879 dcl i fixed binary (18); 6880 6881 machine_state.eaq (*).reserved = "0"b; 6882 6883 do i = escape_index to last_index; 6884 if machine_state.index_regs (i).reserved 6885 then do; 6886 machine_state.index_regs (i).reserved = "0"b; 6887 if machine_state.index_regs (i).type < 0/* Unknown? */ 6888 then machine_state.index_regs (i).type = 0; 6889 end; 6890 end; 6891 6892 do i = first_base to last_base; /* Normal bases */ 6893 if machine_state.base_regs (i).reserved 6894 then do; 6895 machine_state.base_regs (i).reserved = "0"b; 6896 if machine_state.base_regs (i).type < 0 /* Unknown? */ 6897 then machine_state.base_regs (i).type = 0; 6898 end; 6899 end; 6900 6901 /* Bug 508: Reload pr4 with linkage ptr value only if necessary */ 6902 6903 i = which_base (4); 6904 if machine_state.base_regs (i).reserved & machine_state.base_regs (i).type ^= 6 6905 then do; 6906 call emit_zero (getlp); /* Emit code to restore pr4 */ 6907 machine_state.base_regs (i).type = 6; /* linkage ptr */ 6908 end; 6909 6910 machine_state.base_regs (i).reserved = "0"b; 6911 6912 end free_regs; 6913 6914 reset_regs: 6915 procedure (); 6916 6917 /* Resets all regs to their initial state */ 6918 6919 dcl i fixed binary (3); 6920 6921 if machine_state.address_in_base 6922 then do i = first_base to last_base; 6923 call flush_base (i); 6924 end; 6925 6926 call reset_eaq (IND); /* Reset indicators */ 6927 call reset_eaq (EAQ); /* Reset A, Q, EAQ */ 6928 6929 if machine_state.value_in_xr 6930 then do i = first_index to last_index; 6931 if index_regs (i).type = 1 6932 then if index_regs (i).variable ^= 0 6933 then call flush_xr (i); 6934 end; 6935 6936 unspec (machine_state) = "0"b; 6937 6938 machine_state.base_regs (which_base (4)).type = 6;/* linkage_ptr */ 6939 6940 end reset_regs; 6941 6942 flush_ref: 6943 procedure (index); 6944 6945 /* Flush complex reference. This is an aliased reference. Here we find the 6946* paren header node and scan through the equivalenced list to find another 6947* node which has "value_in.eaq" set. Cause that node to be flushed too. */ 6948 6949 dcl (index, i) fixed binary (18); 6950 dcl p ptr; 6951 6952 call flush_simple_ref (index); /* Flush primary */ 6953 p = addr (rands (index)); 6954 if p -> node.node_type = symbol_node 6955 then if (p -> symbol.in_equiv_stmnt) & (p -> symbol.parent ^= 0) 6956 then do; 6957 p = addr (rands (p -> symbol.parent)); /* point to list */ 6958 do i = p -> header.first_element repeat p -> symbol.next_member while (i ^= 0); 6959 p = addr (rands (i)); 6960 if p -> symbol.value_in.eaq 6961 then call flush_simple_ref (i); 6962 end; 6963 end; 6964 6965 6966 6967 flush_simple_ref: 6968 procedure (temp_index); 6969 6970 /* Removes an item from the machine state */ 6971 6972 dcl (temp, temp_index) fixed binary (18); 6973 dcl p pointer; 6974 dcl (i, r) fixed binary (18); 6975 6976 temp = temp_index; 6977 6978 p = addr (rands (temp)); 6979 6980 if p -> node.value_in.eaq 6981 then do; 6982 do r = 1 to hbound (machine_state.eaq, 1); /* A, Q, EAQ, IND */ 6983 do i = 1 by 1 while (i <= machine_state.eaq (r).number); 6984 if machine_state.eaq (r).variable (i) = temp 6985 then do; 6986 do i = i + 1 by 1 while (i <= machine_state.eaq (r).number); 6987 machine_state.eaq (r).variable (i - 1) = machine_state.eaq (r).variable (i); 6988 end; 6989 6990 machine_state.eaq (r).number = machine_state.eaq (r).number - 1; 6991 if machine_state.eaq (r).number = 0 6992 then machine_state.eaq (r).name = 0; 6993 6994 end; 6995 end; 6996 end; 6997 end; 6998 6999 if p -> node.value_in.x 7000 then do i = first_index repeat i + 1 while (i <= last_index); 7001 if index_regs (i).type > 0 7002 then if index_regs (i).variable = temp 7003 then index_regs (i).type = 0; 7004 end; 7005 7006 string (p -> node.value_in) = "0"b; 7007 7008 end flush_simple_ref; 7009 end flush_ref; 7010 7011 flush_addr: 7012 procedure (temp_index); 7013 7014 /* Removes the address of an item from the machine state */ 7015 7016 dcl (temp, temp_index) fixed binary (18); 7017 dcl p pointer; 7018 dcl i fixed binary (18); 7019 7020 temp = temp_index; 7021 p = addr (rands (temp)); 7022 7023 if p -> node.address_in_base 7024 then do; 7025 do i = first_base repeat i + 1 while (i <= last_base); 7026 if base_regs (i).type = 1 7027 then if base_regs (i).variable = temp 7028 then base_regs (i).type = 0; 7029 end; 7030 p -> node.address_in_base = "0"b; 7031 end; 7032 7033 end flush_addr; 7034 7035 lock_tag_register: 7036 procedure (tag); 7037 7038 /* Reserves the register specified by the address tag */ 7039 7040 dcl (tag, t) bit (6) aligned; 7041 7042 t = tag; 7043 7044 /* if XR modification, lock index reg for use in addressing */ 7045 if substr (t, 3, 1) 7046 then machine_state.index_regs (fixed (t, 6) - 8).reserved = "1"b; 7047 else if t = QL_mod 7048 then call lock_eaq (Q); 7049 else if t = AL_mod 7050 then call lock_eaq (A); 7051 7052 end lock_tag_register; 7053 7054 /**** EAQ MANAGEMENT ****/ 7055 7056 eaq_man_load_a_or_q: 7057 procedure (pt) returns (bit (6) aligned); 7058 7059 /* Loads an integer value into the A or Q. */ 7060 7061 dcl (pt, p) pointer; 7062 dcl v fixed binary (18); 7063 dcl name fixed binary (18); 7064 7065 p = pt; 7066 v = fixed (rel (p), 18); 7067 7068 /* Take care of subscripts in the Q */ 7069 7070 if p -> node.dont_update /* really node.subs_in_q */ 7071 then return (QL_mod); 7072 7073 /* If the operand is already in the A or Q, no need to load it */ 7074 7075 if p -> node.value_in.eaq 7076 then do; 7077 name = get_eaq_name (v); 7078 if name = in_q 7079 then return (QL_mod); 7080 else if name = in_ia 7081 then return (AL_mod); 7082 end; 7083 7084 /* Must load the operand. If one of the A or Q is reserved, we must 7085* load the other one. If neither is reserved, we favor the Q. */ 7086 7087 if machine_state.eaq (A).reserved & machine_state.eaq (Q).reserved 7088 then call print_message (449); /* Oops */ 7089 7090 if machine_state.eaq (A).reserved 7091 then name = in_q; 7092 else if machine_state.eaq (Q).reserved 7093 then name = in_ia; 7094 else if machine_state.eaq (Q).number > 0 & machine_state.eaq (A).number = 0 & machine_state.eaq (IND).number = 0 7095 then name = in_ia; 7096 else name = in_q; 7097 7098 call use_eaq (v); 7099 7100 if ^p -> node.is_addressable 7101 then call m_a_except_xreg (p); 7102 7103 call emit_c_a_var (load_inst (name), p); 7104 7105 machine_state.indicators_valid = eaq_name_to_reg (name); 7106 7107 call in_reg (v, name); 7108 7109 if name = in_q 7110 then return (QL_mod); 7111 else return (AL_mod); 7112 7113 end eaq_man_load_a_or_q; 7114 7115 get_eaq_name: 7116 procedure (opnd) returns (fixed binary (18)); 7117 7118 /* Search the eaq state for opnd and return its eaq name */ 7119 7120 dcl (op, opnd) fixed binary (18); 7121 dcl (r, v) fixed binary (18); 7122 7123 op = opnd; 7124 7125 if ^addr (rands (op)) -> node.value_in.eaq 7126 then return (0); /* Don't even look */ 7127 7128 do r = 1 to hbound (machine_state.eaq, 1); 7129 7130 do v = 1 to machine_state.eaq (r).number; 7131 7132 if machine_state.eaq (r).variable (v) = op 7133 then return (machine_state.eaq (r).name); 7134 7135 end; 7136 7137 end; 7138 7139 /* If we get here, the node has value_in.eaq on but the operand 7140* is not in the eaq. */ 7141 7142 call print_message (450); 7143 return (0); 7144 7145 end get_eaq_name; 7146 7147 in_reg: 7148 procedure (v, name); 7149 7150 /* Puts an operand in an eaq register */ 7151 7152 dcl (var, v) fixed binary (18), 7153 name fixed binary (18), 7154 regno fixed binary (18); 7155 7156 var = v; 7157 regno = eaq_name_to_reg (name); 7158 7159 call reset (regno); 7160 7161 machine_state.rounded = "0"b; 7162 7163 machine_state.eaq (regno).number = 1; 7164 machine_state.eaq (regno).variable (1) = var; 7165 machine_state.eaq (regno).name = name; 7166 7167 if machine_state.eaq (regno).name = in_ind 7168 then do; 7169 call print_message (420, var); 7170 return; 7171 end; 7172 7173 addr (rands (var)) -> node.value_in.eaq = "1"b; 7174 7175 if regno = IND 7176 then machine_state.indicators_valid = 0; 7177 else machine_state.indicators_valid = regno; 7178 7179 end in_reg; 7180 7181 also_in_reg: 7182 procedure (v, name); 7183 7184 /* Appends an operand to the eaq register state */ 7185 7186 dcl (var, v) fixed binary (18), 7187 (i, regno) fixed binary (18), 7188 name fixed binary (18), 7189 p pointer; 7190 7191 regno = eaq_name_to_reg (name); 7192 var = v; 7193 7194 addr (rands (var)) -> node.value_in.eaq = "1"b; 7195 7196 if machine_state.eaq (regno).number < hbound (machine_state.eaq.variable, 2) 7197 then do; 7198 machine_state.eaq (regno).number = machine_state.eaq (regno).number + 1; 7199 machine_state.eaq (regno).variable (machine_state.eaq (regno).number) = var; 7200 return; 7201 end; 7202 else do i = 1 to hbound (machine_state.eaq.variable, 2); 7203 7204 p = addr (rands (machine_state.eaq (regno).variable (i))); 7205 7206 if p -> node.node_type ^= temporary_node 7207 then do; 7208 machine_state.eaq (regno).variable (i) = var; 7209 p -> node.dont_update, /* really node.subs_in_q */ 7210 p -> node.value_in.eaq = "0"b; 7211 return; 7212 end; 7213 end; 7214 7215 call print_message (448); 7216 7217 end also_in_reg; 7218 7219 use_eaq: 7220 procedure (array_name); 7221 7222 /* Empties the eaq, saving temporaries in storage and indexes 7223* of array references in index registers */ 7224 7225 dcl array_name fixed binary (18); 7226 dcl p pointer; 7227 dcl own_sub pointer; 7228 dcl bit6 bit (6) aligned; 7229 dcl mac fixed binary (18); 7230 dcl (r, i) fixed binary (18); 7231 7232 own_sub = null (); 7233 7234 if array_name > 0 7235 then if addr (rands (array_name)) -> node.node_type = array_ref_node 7236 then if addr (rands (array_name)) -> array_ref.ref_count = 1 7237 then if addr (rands (array_name)) -> array_ref.variable_offset 7238 then if addr (rands (array_name)) -> array_ref.data_type ^= cmpx_mode 7239 then if addr (rands (addr (rands (array_name)) -> array_ref.v_offset)) -> node.value_in.eaq 7240 then own_sub = addr (rands (addr (rands (array_name)) -> array_ref.v_offset)); 7241 7242 if machine_state.eaq (IND).number > 0 7243 then call use_ind (); 7244 7245 do r = 1 to hbound (machine_state.eaq, 1) - 1; /* A, Q, EAQ */ 7246 7247 do i = 1 to machine_state.eaq (r).number; 7248 7249 p = addr (rands (machine_state.eaq (r).variable (i))); 7250 if p -> node.node_type = temporary_node 7251 then do; 7252 if p -> temporary.dont_update /* really temporary.subs_in_q */ 7253 then if p = own_sub & p -> temporary.ref_count = 1 & r = Q 7254 then ; 7255 else do; 7256 bit6 = xr_man_load_any_xr (p); 7257 p -> temporary.dont_update = "0"b; 7258 /* really temporary.subs_in_q */ 7259 end; 7260 7261 else if p -> temporary.not_in_storage & ^p -> temporary.value_in.x 7262 then do; 7263 if ^do_rounding | machine_state.rounded 7264 then mac = store_no_round_inst (machine_state.eaq (r).name); 7265 else mac = store_inst (machine_state.eaq (r).name); 7266 call emit_temp_store (mac, (machine_state.eaq (r).variable (i))); 7267 end; 7268 end; 7269 7270 if p -> node.node_type = symbol_node & p ^= own_sub 7271 then p -> symbol.dont_update = "0"b; /* really symbol.subs_in_q */ 7272 7273 p -> node.value_in.eaq = "0"b; 7274 end; 7275 7276 machine_state.eaq (r).name = 0; /* mark register empty */ 7277 machine_state.eaq (r).number = 0; 7278 7279 end; 7280 7281 machine_state.rounded = "0"b; 7282 7283 end use_eaq; 7284 7285 use_ind: 7286 procedure (); 7287 7288 /* Empties the indicators, saving logical values in the 7289* A register if necessary */ 7290 /* NOTE if anything in EAQ then it too has to go. */ 7291 7292 dcl var fixed binary (18); 7293 7294 if machine_state.eaq (IND).number > 0 7295 then if addr (rands (machine_state.eaq (IND).variable (1))) -> node.not_in_storage 7296 then do; 7297 call save_logical_temps (); 7298 call emit_zero ((ind_to_a (machine_state.eaq (IND).name - in_ind))); 7299 7300 /* Update machine state */ 7301 7302 var = machine_state.eaq (IND).variable (1); 7303 call reset_eaq (IND); 7304 machine_state.eaq (A).number = 1; 7305 machine_state.eaq (A).name = in_a; 7306 machine_state.eaq (A).variable (1) = var; 7307 addr (rands (var)) -> node.value_in.eaq = "1"b; 7308 end; 7309 7310 machine_state.indicators_valid = 0; 7311 7312 save_logical_temps: 7313 procedure (); 7314 7315 /* This procedure is analogous to use_eaq, but is used to save 7316* temps in the A and EAQ registers only. It is called by use_ind to 7317* avoid recursion with use_eaq. */ 7318 7319 dcl (mac, i) fixed binary (18); 7320 dcl bit6 bit (6) aligned; 7321 dcl p ptr; 7322 7323 do i = 1 by 1 while (i <= machine_state.eaq (A).number); 7324 7325 if addr (rands (machine_state.eaq (A).variable (i))) -> node.not_in_storage 7326 then call emit_temp_store (sta, (machine_state.eaq (A).variable (i))); 7327 end; 7328 7329 /* The following code is more or less taken from use_eaq. */ 7330 7331 do i = 1 to machine_state.eaq (EAQ).number; 7332 p = addr (rands (machine_state.eaq (EAQ).variable (i))); 7333 if p -> node.node_type = temporary_node 7334 then do; 7335 if p -> temporary.dont_update /* really temporary.subs_in_q */ 7336 then do; 7337 bit6 = xr_man_load_any_xr (p); 7338 p -> temporary.dont_update = "0"b; /* really temporary.subs_in_q */ 7339 end; 7340 7341 else if p -> temporary.not_in_storage & ^p -> temporary.value_in.x 7342 then do; 7343 if ^do_rounding | machine_state.rounded 7344 then mac = store_no_round_inst (machine_state.eaq (EAQ).name); 7345 else mac = store_inst (machine_state.eaq (EAQ).name); 7346 call emit_temp_store (mac, (machine_state.eaq (EAQ).variable (i))); 7347 end; 7348 end; 7349 7350 if p -> node.node_type = symbol_node 7351 then p -> symbol.dont_update = "0"b; /* really symbol.subs_in_q */ 7352 7353 p -> node.value_in.eaq = "0"b; 7354 end; 7355 7356 call reset_eaq (A); 7357 7358 end save_logical_temps; 7359 end use_ind; 7360 7361 load: 7362 procedure (vp, name); 7363 7364 dcl vp fixed binary (18), /* Operand to be loaded */ 7365 name fixed binary (18); /* Eaq_name to be loaded */ 7366 dcl (var, eaq_name, regno, i) fixed binary (18); 7367 7368 eaq_name = name; 7369 7370 if eaq_name <= 0 | eaq_name > in_ind 7371 then do; 7372 call print_message (421, vp); 7373 return; 7374 end; 7375 7376 var = vp; 7377 7378 /* If we are trying to load some register other than the 7379* indicators, and there are logical values in the indicators, 7380* we must get the indicators into the A now, before the load 7381* takes place. This is a kludge, and a holdover from the old 7382* EAQ management scheme. */ 7383 7384 if eaq_name ^= in_ind & machine_state.eaq (IND).number > 0 7385 then call use_ind (); 7386 7387 if addr (rands (var)) -> node.value_in.eaq 7388 then do; 7389 7390 /* Search the machine state; the operand may already be 7391* in the desired register. */ 7392 7393 do regno = 1 to hbound (machine_state.eaq, 1); 7394 /* A, Q, EAQ, IND */ 7395 7396 do i = 1 by 1 while (i <= machine_state.eaq (regno).number); 7397 if var = machine_state.eaq (regno).variable (i) 7398 then do; 7399 7400 if eaq_name = in_tq | eaq_name = in_q 7401 then if machine_state.eaq (regno).name = in_tq | machine_state.eaq (regno).name = in_q 7402 then machine_state.eaq (regno).name = eaq_name; 7403 7404 if eaq_name = machine_state.eaq (regno).name 7405 then return; 7406 7407 if eaq_name = in_ind 7408 then do; 7409 if regno = IND 7410 then return; 7411 7412 if machine_state.eaq (regno).name = in_a 7413 then if machine_state.indicators_valid = A 7414 then do; 7415 call flush_ref (var); 7416 call in_reg (var, tnz); 7417 return; 7418 end; 7419 end; 7420 7421 else if eaq_name = in_a & regno = IND 7422 & addr (rands (var)) -> node.node_type = temporary_node 7423 then do; 7424 call use_ind (); 7425 machine_state.indicators_valid = A; 7426 return; 7427 end; 7428 7429 end; 7430 7431 end; 7432 7433 end; 7434 7435 end; 7436 7437 call use_eaq (var); 7438 7439 call emit_single ((load_inst (eaq_name)), var); 7440 7441 if eaq_name = in_ind 7442 then eaq_name = tnz; 7443 7444 call in_reg (var, eaq_name); 7445 7446 machine_state.rounded = "1"b; 7447 7448 end load; 7449 7450 check_negative: 7451 procedure (opnd) returns (bit (1) aligned); 7452 7453 /* return true if operand is "negative" for its data type */ 7454 7455 dcl opnd fixed bin (18); 7456 dcl (p, val_ptr) ptr; 7457 dcl based_integer fixed bin (35) aligned based; 7458 dcl based_real float bin (27) aligned based; 7459 dcl 1 based_double aligned based, 7460 2 based_dp float bin (63) unaligned; 7461 7462 if opnd < 0 /* a count */ 7463 then return (opnd < -bias); 7464 7465 p = addr (rands (opnd)); 7466 if p -> node.data_type < 1 | p -> node.data_type > 4 7467 then return ("0"b); /* cannot be neg if not numeric */ 7468 val_ptr = addr (p -> constant.value); 7469 goto return_neg (p -> node.data_type); 7470 7471 return_neg (1): /* INTEGER */ 7472 return (val_ptr -> based_integer < 0); 7473 7474 return_neg (2): /* REAL */ 7475 return_neg (4): /* COMPLEX */ 7476 return (val_ptr -> based_real < 0.0); 7477 7478 return_neg (3): /* DOUBLE PRECISION */ 7479 return (val_ptr -> based_dp < 0.0); 7480 7481 end check_negative; 7482 7483 reset_eaq: 7484 procedure (reg_number); 7485 7486 /* Resets the specified eaq register to the empty state */ 7487 7488 dcl reg_number fixed binary (18); 7489 7490 if reg_number ^= IND 7491 then call reset (EAQ); /* Only IND does not affect EAQ */ 7492 7493 if reg_number = EAQ 7494 then do; /* EAQ affects both A and Q */ 7495 call reset (A); 7496 call reset (Q); 7497 end; 7498 else call reset (reg_number); 7499 7500 machine_state.rounded = "0"b; 7501 7502 return; 7503 7504 end reset_eaq; 7505 7506 reset: 7507 procedure (r); 7508 7509 /* Resets a single eaq register */ 7510 7511 dcl (i, r, regno) fixed binary (18); 7512 dcl p pointer; 7513 7514 regno = r; 7515 7516 do i = 1 by 1 while (i <= machine_state.eaq (regno).number); 7517 p = addr (rands (machine_state.eaq (regno).variable (i))); 7518 p -> node.dont_update, /* really node.subs_in_q */ 7519 p -> node.value_in.eaq = "0"b; 7520 end; 7521 7522 machine_state.eaq (regno).name = 0; 7523 machine_state.eaq (regno).number = 0; 7524 7525 end reset; 7526 7527 store: 7528 procedure (vp, name, update_flag); 7529 7530 dcl vp fixed binary (18); /* Operand to be stored */ 7531 dcl name fixed binary (18); /* Eaq_name from which storing takes place */ 7532 dcl update_flag fixed binary (18); /* =0 if store should update ms */ 7533 7534 dcl (var, eaq_name, inst_number, reg) fixed binary (18); 7535 dcl v pointer; 7536 7537 eaq_name = name; 7538 var = vp; 7539 v = addr (rands (var)); 7540 7541 if do_rounding & ^machine_state.rounded 7542 then inst_number = store_inst (eaq_name); 7543 else inst_number = store_no_round_inst (eaq_name); 7544 7545 call emit_single (inst_number, var); 7546 7547 if eaq_name = in_q 7548 then if string (v -> node.value_in) 7549 then call flush_ref (var); 7550 7551 if update_flag = 0 7552 then do; 7553 v -> node.not_in_storage = "0"b; 7554 reg = eaq_name_to_reg (eaq_name); 7555 if eaq_name = machine_state.eaq (reg).name 7556 then call also_in_reg (var, eaq_name); 7557 else call in_reg (var, eaq_name); 7558 end; 7559 7560 end store; 7561 7562 lock_eaq: 7563 procedure (reg); 7564 7565 /* Locks an EAQ register for use in addressing */ 7566 7567 dcl reg fixed binary (18); 7568 7569 machine_state.eaq (reg).reserved = "1"b; 7570 end lock_eaq; 7571 7572 /**** REL CONSTANTS ****/ 7573 7574 alloc_label: 7575 procedure (stack_sub, value); 7576 7577 dcl stack_sub fixed binary (18), /* Subscript of operand in stack */ 7578 value fixed binary (18); /* Value to be assigned to operand */ 7579 7580 dcl p pointer; 7581 7582 p = addr (rands (stack (stack_sub))); 7583 7584 p -> label.location = value; 7585 p -> label.allocated = "1"b; 7586 7587 end alloc_label; 7588 7589 /**** BUILD PROFILE ENTRY ****/ 7590 7591 build_profile_entry: 7592 procedure (); 7593 7594 /* modified to produce both long and short profile. */ 7595 7596 if generate_long_profile 7597 then do; /* long_profile */ 7598 call emit_operator_call (long_profile); 7599 7600 /* emit internal static relative offset to long_profile_header */ 7601 7602 text_halfs (text_pos).left = profile_start; 7603 reloc (text_pos).left_rel = rc_is18; 7604 7605 /* emit relative offset from long_profile_header to entry */ 7606 7607 text_halfs (text_pos).right = profile_pos; 7608 reloc (text_pos).right_rel = rc_a; 7609 text_pos = text_pos + 1; 7610 profile_pos = profile_pos + size (long_profile_entry); 7611 end; 7612 else do; /* short profile */ 7613 call use_ind; /* aos sets indicators */ 7614 call emit_c_a (aos, c_a (profile_pos + 1, 5)); 7615 reloc (text_pos - 1).left_rel = rc_is15; 7616 7617 profile_pos = profile_pos + size (profile_entry); 7618 end; 7619 7620 end build_profile_entry; 7621 7622 setup_message_structure: 7623 procedure (); 7624 7625 /* Sets up message_structure for print & error macros */ 7626 7627 dcl i fixed binary (18); 7628 7629 message_structure.message_number = left; 7630 message_structure.number_of_operands = macro_dt_inst (imac).data_type; 7631 7632 do i = 1 to message_structure.number_of_operands; 7633 imac = imac + 1; 7634 7635 left = macro_instruction (imac).left; 7636 if left = 0 7637 then do; 7638 7639 /* have an operand as argument */ 7640 7641 message_structure.is_string (i) = "0"b; 7642 message_structure.operand_index (i) = stack (get_operand ((macro_instruction (imac).operand))); 7643 end; 7644 7645 else do; 7646 7647 /* have a string as argument */ 7648 7649 message_structure.is_string (i) = "1"b; 7650 message_structure.string_length (i) = macro_dt_inst (imac).data_type; 7651 message_structure.string_ptr (i) = addrel (mac_base, macro_instruction (imac).left); 7652 end; 7653 end; 7654 7655 end setup_message_structure; 7656 7657 create_integer_constant: 7658 procedure (value) returns (fixed binary (18)); 7659 7660 dcl value fixed binary (35) aligned; 7661 dcl bvalue bit (72) aligned; 7662 7663 bvalue = unspec (value); 7664 return (create_constant (int_mode, bvalue)); 7665 7666 end create_integer_constant; 7667 7668 /**** SUBSCRIPTING CODE ****/ 7669 7670 next_subscript: 7671 procedure (); 7672 7673 /* Generates code to check the range of the subscript 7674* at the top of the stack. The following stack format 7675* is expected: 7676* 7677* array variable 7678* number of subscripts 7679* sub1 7680* sub2 7681* . 7682* . 7683* . 7684* subn 7685* */ 7686 7687 dcl (d, p, s) pointer; 7688 dcl (isub, csub, bound) fixed binary (18); 7689 7690 s = addr (rands (stack (base))); 7691 d = addr (rands (s -> symbol.dimension)); 7692 p = addr (rands (stack (top))); 7693 isub = top - base - 1; 7694 7695 /* Do compile time range checking if the subscript is constant */ 7696 7697 if p -> node.operand_type = constant_type 7698 then do; 7699 unspec (csub) = p -> constant.value; 7700 7701 if ^d -> dimension.v_bound (isub).lower 7702 then if csub < d -> dimension.lower_bound (isub) 7703 then call print_message (422, stack (top), stack (base)); 7704 /* Warning if lower bound exceeded */ 7705 7706 if ^d -> dimension.v_bound (isub).upper 7707 then if csub > d -> dimension.upper_bound (isub) 7708 then if s -> symbol.parameter 7709 then do; 7710 7711 /* Warning if upper bound is exceeded and array is a parameter */ 7712 7713 call print_message (431, stack (top), stack (base)); 7714 end; 7715 else do; 7716 7717 /* Severity 3 error if upper bound is exceeded and array is not a parameter */ 7718 7719 call print_message (422, stack (top), stack (base)); 7720 call signal_error (); 7721 return; 7722 end; 7723 7724 end; 7725 7726 /* Emit code to check subscript range (if necessary) */ 7727 7728 if cs -> subprogram.options.subscriptrange 7729 then if (isub < d -> dimension.number_of_dims | ^d -> dimension.assumed_size) 7730 then if (p -> node.operand_type ^= constant_type | string (d -> dimension.v_bound (isub)) ^= "00"b) 7731 then do; 7732 7733 if d -> dimension.v_bound (isub).lower 7734 then bound = d -> dimension.lower_bound (isub); 7735 else bound = create_integer_constant ((d -> dimension.lower_bound (isub))); 7736 call copy (bound); 7737 7738 if d -> dimension.v_bound (isub).upper 7739 then bound = d -> dimension.upper_bound (isub); 7740 else bound = create_integer_constant ((d -> dimension.upper_bound (isub))); 7741 call copy (bound); 7742 7743 call interpreter_proc (check_subscript, r1); 7744 r1: 7745 end; 7746 7747 end next_subscript; 7748 7749 finish_subscript: 7750 procedure (); 7751 7752 /* Puts out code to compute offset of subscripted reference 7753* and creates an array ref. A similar stack format 7754* to that expected by next_subscript is expected */ 7755 7756 dcl (a, d, p, s) pointer; 7757 dcl csum fixed bin (24); 7758 dcl (vsum, i, a_ref, zsub, cvalue) fixed binary (18); 7759 dcl (first_time, have_vsum, code_emitted, char_77_mode, big_offset) bit (1) aligned; 7760 7761 7762 s = addr (rands (stack (base))); 7763 d = addr (rands (s -> symbol.dimension)); 7764 7765 first_time = "1"b; 7766 code_emitted, have_vsum, big_offset = "0"b; 7767 char_77_mode = (s -> symbol.units = char_units); 7768 csum = 0; 7769 zsub = base + 1; 7770 7771 do i = d -> dimension.number_of_dims to 1 by -1; 7772 if ^first_time 7773 then do; 7774 7775 /* multiply by dimension.size (i) */ 7776 7777 if string (d -> dimension.v_bound (i)) = "00"b 7778 then do; 7779 csum = csum * d -> dimension.size (i); 7780 if have_vsum 7781 then call mult (d -> dimension.size (i) - bias); 7782 end; 7783 7784 else do; 7785 if csum ^= 0 7786 then do; 7787 if have_vsum 7788 then call add_csum; 7789 else do; 7790 have_vsum = "1"b; 7791 vsum = create_integer_constant ((csum)); 7792 end; 7793 7794 csum = 0; 7795 end; 7796 7797 if have_vsum /* PREVIOUSLY FORGOTTEN */ 7798 then call mult ((d -> dimension.size (i))); 7799 end; 7800 end; 7801 7802 first_time = "0"b; 7803 7804 /* add ith subscript */ 7805 7806 p = addr (rands (stack (zsub + i))); 7807 7808 if p -> node.operand_type = constant_type 7809 then do; 7810 unspec (cvalue) = p -> constant.value; 7811 csum = csum + cvalue; 7812 end; 7813 else do; 7814 if have_vsum 7815 then call add ((stack (zsub + i))); 7816 else do; 7817 have_vsum = "1"b; 7818 vsum = stack (zsub + i); 7819 end; 7820 end; 7821 end; 7822 7823 /* multiply by element size */ 7824 7825 if s -> symbol.v_length ^= 0 7826 then do; 7827 if csum ^= 0 7828 then do; 7829 if have_vsum 7830 then call add_csum; 7831 else do; 7832 have_vsum = "1"b; 7833 vsum = create_integer_constant ((csum)); 7834 end; 7835 csum = 0; 7836 end; 7837 if have_vsum 7838 then call mult ((s -> symbol.v_length)); 7839 else do; 7840 vsum = s -> symbol.v_length; 7841 have_vsum = "1"b; 7842 end; 7843 end; 7844 else if s -> symbol.element_size ^= 1 7845 then do; 7846 csum = csum * s -> symbol.element_size; 7847 if have_vsum 7848 then call mult (s -> symbol.element_size - bias); 7849 end; 7850 7851 /* subtract the virtual origin */ 7852 7853 if ^d -> dimension.variable_virtual_origin 7854 then csum = csum - d -> dimension.virtual_origin; 7855 else do; 7856 7857 /* we must have_vsum since one of the checked 7858* bounds must be a variable */ 7859 7860 call sub ((d -> dimension.virtual_origin)); 7861 end; 7862 7863 /* If we are addressing in units of characters, the variable 7864* offset may not fit in an index register (big_offset = "1"b). 7865* For vsum to be placed in an index register, we must have 7866* 0 <= vsum <= 262143. Since we know 0 <= csum + vsum <= 7867* array_size - 1, we can derive these two conditions for the 7868* use of index registers: 7869* csum <= 0 AND array_size - csum <= 262144 7870* If either of these conditions is not met, vsum cannot be kept 7871* in an index register. */ 7872 7873 if char_77_mode 7874 then if have_vsum 7875 then if s -> symbol.variable_extents | s -> symbol.star_extents | csum > 0 7876 | d -> dimension.array_size - csum > 262144 7877 then big_offset = "1"b; 7878 7879 /* if symbol has large address, add into csum */ 7880 7881 if s -> symbol.large_address & ^s -> symbol.VLA 7882 then if char_77_mode 7883 then csum = csum + (s -> symbol.location * chars_per_word); 7884 else csum = csum + s -> symbol.location; 7885 7886 /* create and initialize an array_ref node */ 7887 7888 a_ref = create_array_ref ((stack (base))); 7889 a = addr (rands (a_ref)); 7890 a -> array_ref.large_offset = big_offset; 7891 7892 /* Include address of parent in csum */ 7893 7894 if char_77_mode 7895 then do; 7896 csum = csum + a -> array_ref.address.char_num; 7897 a -> array_ref.address.char_num = mod (csum, chars_per_word); 7898 if (csum < 0) & (a -> array_ref.address.char_num ^= 0) 7899 then csum = divide (csum, chars_per_word, 18, 0) - 1; 7900 else csum = divide (csum, chars_per_word, 18, 0); 7901 end; 7902 7903 if s -> symbol.VLA 7904 then do; 7905 7906 /* add the packed pointer to the subscript, and add the offset from the pointer 7907* to the start of the array. */ 7908 7909 a -> array_ref.large_offset, big_offset = "1"b; 7910 csum = csum + s -> symbol.offset; /* Add offset in block */ 7911 7912 /* If code emitted, then subscript is in Q already. So add a possible constant 7913* offset, then add the packed pointer to the storage section and leave in Q. */ 7914 7915 if code_emitted 7916 then do; 7917 call add_csum; /* add offset */ 7918 call add_pointer (stack (base)); /* add pointer */ 7919 end; 7920 7921 /* no code emitted - may have to load vsum then add offset and pointer. */ 7922 7923 else if have_vsum /* vsum exists */ 7924 then do; 7925 call add_csum; /* add offset */ 7926 call add_pointer (stack (base)); /* add pointer */ 7927 end; 7928 7929 /* load constant and add pointer. */ 7930 7931 else do; 7932 call load_vsum; /* forces constant gen and load */ 7933 call add_pointer (stack (base)); 7934 end; 7935 csum = 0; 7936 7937 if ^VLA_is_256K /* Convert logical address to packed ptr. */ 7938 then do; 7939 unspec (inst_address) = ""b; 7940 inst_address.offset = VLA_words_per_seg; 7941 inst_address.ext_base = "1"b; 7942 call emit_c_a ((div), unspec (inst_address)); 7943 /* seg to Q, word to A */ 7944 call emit_single (als, 18 - bias); /* word to high A */ 7945 call emit_single (llr, 18 - bias); /* full packed pointer in Q */ 7946 end; 7947 7948 have_vsum = "1"b; 7949 end; 7950 else csum = csum + a -> array_ref.address.offset; 7951 7952 if have_vsum 7953 then call finalize_vsum (); 7954 else a -> array_ref.is_addressable = ^a -> array_ref.needs_pointer; 7955 7956 call set_address_offset (a, (csum), (s -> symbol.element_size), (s -> symbol.units)); 7957 7958 /* If the symbol node had large_addressing then the base in the array_ref 7959* node will be incorrect if the array ref is a ^large_address. Therefore 7960* or large_address flags to cause base re-evaluation if required. */ 7961 7962 a -> array_ref.large_address = a -> array_ref.large_address | s -> symbol.large_address; 7963 7964 a -> array_ref.has_address = "1"b; 7965 7966 7967 /* push the final result on top of the stack */ 7968 7969 call push (a_ref); 7970 7971 return; 7972 7973 add_csum: 7974 proc (); 7975 7976 /* add csum, either through creating a constant, or through simple instruction. */ 7977 if ^code_emitted /* load vsum if needed */ 7978 then call load_vsum; 7979 7980 if csum = 0 7981 then return; 7982 7983 if csum > max_fixed_bin_18 | csum < 0 7984 then call add (create_integer_constant ((csum))); 7985 else call add (csum - bias); 7986 return; 7987 end add_csum; 7988 7989 7990 add_pointer: 7991 proc (op); 7992 7993 dcl op fixed bin (18); 7994 7995 dcl d ptr; 7996 dcl s ptr; 7997 dcl v ptr; 7998 7999 if ^code_emitted 8000 then call load_vsum; 8001 8002 s = addr (rands (op)); 8003 d = addr (rands (s -> symbol.dimension)); 8004 v = addr (rands (d -> dimension.VLA_base_addressor)); 8005 call emit_c_a_var (adfx1, v); 8006 call reset_eaq (Q); /* Value has been modified */ 8007 8008 end add_pointer; 8009 8010 make_substring: 8011 entry (); 8012 8013 /* Emits code to compute the length and offset of a substring 8014* reference. The following stack format is expected: 8015* 8016* substring parent (symbol or array_ref) 8017* index of first character in substring 8018* index of last character in substring 8019* 8020* An array_ref node representing the substring reference is 8021* filled in and pushed on the operand stack. */ 8022 8023 dcl (p1, p2, v) pointer; 8024 dcl (v_length, indx1_constant, indx2_constant) bit (1) aligned; 8025 dcl (substr_size, csize) fixed binary (18); 8026 dcl xr fixed binary (3); 8027 dcl (indx1_value, indx2_value) fixed binary (35); 8028 8029 /* Get pointers to operands */ 8030 8031 p = addr (rands (stack (base))); 8032 p1 = addr (rands (stack (base + 1))); 8033 p2 = addr (rands (stack (base + 2))); 8034 8035 if p1 -> node.operand_type = constant_type 8036 then do; 8037 indx1_constant = "1"b; 8038 indx1_value = addr (p1 -> constant.value) -> int_image; 8039 end; 8040 else indx1_constant = "0"b; 8041 8042 if p2 -> node.operand_type = constant_type 8043 then do; 8044 indx2_constant = "1"b; 8045 indx2_value = addr (p2 -> constant.value) -> int_image; 8046 end; 8047 else indx2_constant = "0"b; 8048 8049 /* Get address information from parent */ 8050 8051 if p -> node.node_type = array_ref_node 8052 then do; 8053 have_vsum = p -> array_ref.variable_offset; 8054 vsum = p -> array_ref.v_offset; 8055 big_offset = p -> array_ref.large_offset; 8056 s = addr (rands (p -> array_ref.parent)); 8057 v = addr (rands (vsum)); 8058 8059 /* If temporary.dont_update was set for vsum, then it will 8060* not have been stored. We must either store it from the 8061* index register which now holds it, or prevent it from 8062* getting into an index register if it is still in the Q. 8063* Note that storing from the index register only works 8064* because EIS instruction offsets in index registers must 8065* be positive. */ 8066 8067 if v -> node.node_type = temporary_node 8068 then if v -> temporary.not_in_storage 8069 then if v -> temporary.value_in.x 8070 then do; 8071 do xr = first_index to last_index while (index_regs (xr).variable ^= vsum); 8072 end; 8073 call emit_temp_store (stz, vsum); 8074 call emit_temp_store (sxl0 + xr, vsum); 8075 end; 8076 else v -> temporary.dont_update = "0"b; 8077 end; 8078 else do; 8079 have_vsum = "0"b; 8080 vsum = 0; 8081 big_offset = "0"b; 8082 s = p; 8083 end; 8084 8085 /* Do stringrange checking */ 8086 8087 csize = get_char_size (p); 8088 8089 if cs -> subprogram.options.stringrange 8090 then if ^indx1_constant | ^indx2_constant 8091 then do; 8092 call push (csize); 8093 call copy ((stack (base + 1))); 8094 call copy ((stack (base + 2))); 8095 call interpreter_proc (check_stringrange, r4); 8096 r4: 8097 end; 8098 8099 /* Check constant indices */ 8100 8101 if indx1_constant 8102 then if indx1_value <= 0 | (csize < 0 & indx1_value > csize + bias) 8103 then do; 8104 call print_message (457, stack (base + 1), stack (base)); 8105 go to substring_error; 8106 end; 8107 8108 if indx2_constant 8109 then if indx2_value <= 0 | (csize < 0 & indx2_value > csize + bias) 8110 then do; 8111 call print_message (457, stack (base + 2), stack (base)); 8112 go to substring_error; 8113 end; 8114 8115 /* Compute the length of the substring */ 8116 8117 if indx1_constant 8118 then if indx2_constant 8119 then do; 8120 8121 /* Both indices are constant */ 8122 8123 v_length = "0"b; 8124 substr_size = indx2_value - indx1_value + 1; 8125 if substr_size <= 0 8126 then do; 8127 call print_message (460, stack (base)); 8128 go to substring_error; 8129 end; 8130 end; 8131 8132 else do; 8133 8134 /* Only the first index is constant */ 8135 8136 v_length = "1"b; 8137 if indx1_value = 1 & addr (rands (stack (base + 2))) -> node.node_type ^= array_ref_node 8138 then do; 8139 code_emitted = "0"b; 8140 substr_size = stack (base + 2); 8141 if addr (rands (substr_size)) -> node.node_type = temporary_node 8142 then addr (rands (substr_size)) -> temporary.ref_count = 8143 addr (rands (substr_size)) -> temporary.ref_count + 1; 8144 8145 end; 8146 else do; 8147 code_emitted = "1"b; 8148 call load ((stack (base + 2)), in_q); 8149 if indx1_value ^= 1 8150 then call sub (indx1_value - 1 - bias); 8151 end; 8152 end; 8153 8154 else if indx2_constant 8155 then do; 8156 8157 /* Only the second index is constant */ 8158 8159 v_length, code_emitted = "1"b; 8160 call load (indx2_value + 1 - bias, in_q); 8161 call sub ((stack (base + 1))); 8162 end; 8163 8164 else do; 8165 8166 /* Neither index is constant */ 8167 8168 v_length, code_emitted = "1"b; 8169 call load ((stack (base + 2)), in_q); 8170 call sub ((stack (base + 1))); 8171 call add (1 - bias); 8172 end; 8173 8174 /* If code was emitted to compute the length, assign a temp */ 8175 8176 if v_length & code_emitted 8177 then do; 8178 substr_size = assign_temp (int_mode); 8179 call in_reg (substr_size, in_q); 8180 end; 8181 8182 /* Now compute the offset of the substring reference */ 8183 8184 code_emitted = "0"b; 8185 8186 csum = p -> node.address.char_num + (chars_per_word * p -> node.address.offset); 8187 8188 /* Figure first character index into the offset */ 8189 8190 if indx1_constant 8191 then csum = csum + indx1_value - 1; 8192 else do; 8193 if have_vsum 8194 then call add ((stack (base + 1))); 8195 else do; 8196 have_vsum = "1"b; 8197 vsum = stack (base + 1); 8198 end; 8199 csum = csum - 1; 8200 end; 8201 8202 /* If parent has a large address, add in the base location */ 8203 8204 if p -> node.large_address 8205 then csum = csum + (chars_per_word * p -> node.location); 8206 8207 /* Make sure the variable offset fits in an index register. 8208* This is only an issue if we take a substring of an array 8209* element (since the maximum offset into a scalar is 8210* max_char_length - 1), there is a variable offset, and the 8211* substring offset is not purely constant. */ 8212 8213 if p -> node.node_type = array_ref_node 8214 then if ^s -> symbol.variable_extents & ^s -> symbol.star_extents 8215 then if have_vsum 8216 then if ^indx1_constant 8217 then do; 8218 8219 /* Derive the total constant offset due to the combined 8220* substring and subscript operations. */ 8221 8222 cvalue = s -> symbol.address.offset; 8223 if s -> symbol.large_address 8224 then cvalue = cvalue + s -> symbol.location; 8225 cvalue = chars_per_word * cvalue + s -> symbol.address.char_num; 8226 cvalue = csum - cvalue; 8227 8228 big_offset = 8229 (cvalue > 0) 8230 | (addr (rands (s -> symbol.dimension)) -> dimension.array_size - cvalue > 262144); 8231 end; 8232 8233 /* Create and initialize an array_ref node */ 8234 8235 a_ref = create_array_ref (fixed (rel (s), 18)); 8236 a = addr (rands (a_ref)); 8237 8238 a -> array_ref.variable_length = v_length; 8239 a -> array_ref.length = substr_size; 8240 a -> array_ref.large_offset = big_offset; 8241 8242 /* Convert constant offset back to words */ 8243 8244 a -> array_ref.address.char_num = mod (csum, chars_per_word); 8245 if (csum < 0) & (a -> array_ref.address.char_num ^= 0) 8246 then csum = divide (csum, chars_per_word, 18, 0) - 1; 8247 else csum = divide (csum, chars_per_word, 18, 0); 8248 8249 if have_vsum 8250 then call finalize_vsum (); 8251 else a -> array_ref.is_addressable = ^a -> array_ref.needs_pointer; 8252 8253 if s -> node.node_type = symbol_node 8254 then do; 8255 8256 /* If the symbol node had large_addressing then the base in the array_ref 8257* node will be incorrect if the array ref is a ^large_address. Therefore 8258* or large_address flags to cause base re-evaluation if required. */ 8259 8260 call set_address_offset (a, (csum), (s -> symbol.element_size), (s -> symbol.units)); 8261 a -> array_ref.large_address = a -> array_ref.large_address | s -> symbol.large_address; 8262 end; 8263 else do; 8264 a -> node.offset = csum; 8265 if s -> node.node_type = char_constant_node 8266 then a -> node.units = char_units; /* prevent m_a making a pointer */ 8267 end; 8268 8269 a -> array_ref.has_address = "1"b; 8270 8271 call push (a_ref); 8272 8273 return; 8274 8275 8276 substring_error: 8277 imac = fixed (rel (addr (fort_cg_macros_$error_macro)), 18); 8278 go to loop; 8279 8280 get_param_array_size: 8281 entry (sym); 8282 8283 /* Figures out the size of parameter arrays of star or 8284* expression extents. Emits code to compute the array_size 8285* and virtual_origin, and initializes the array descriptor. */ 8286 8287 dcl sym pointer; 8288 8289 dcl (virtual_origin, array_size, c_virtual_origin, c_multiplier, ndims, c_mult_offset, desc) fixed binary (18); 8290 dcl v_multiplier bit (1) aligned; 8291 8292 s = sym; 8293 8294 if ^s -> symbol.variable_extents & ^s -> symbol.star_extents 8295 then return; 8296 8297 desc = s -> symbol.hash_chain; 8298 8299 /* If there is a descriptor template node, but it has not been 8300* assigned storage, then it is only needed to build the entry 8301* point definitions and we can ignore it. */ 8302 8303 if desc ^= 0 8304 then if ^addr (rands (desc)) -> symbol.allocated 8305 then desc = 0; 8306 8307 d = addr (rands (s -> symbol.dimension)); 8308 8309 ndims = d -> dimension.number_of_dims; 8310 8311 /* Allocate array_size */ 8312 8313 if ^d -> dimension.has_array_size 8314 then do; 8315 array_size, d -> dimension.array_size = create_var (1); 8316 addr (rands (array_size)) -> symbol.data_type = int_mode; 8317 d -> dimension.has_array_size = "1"b; 8318 d -> dimension.variable_array_size = "1"b; 8319 end; 8320 else array_size = d -> dimension.array_size; 8321 8322 /* Copy descriptor template to automatic storage, but only 8323* if get_param_char_size has not done so already. */ 8324 8325 if desc ^= 0 & s -> symbol.v_length = 0 8326 then call copy_array_desc_template (s); 8327 8328 /* The rest of the code concerns itself with computing 8329* the array_size and virtual origin, and with initializing 8330* the bound information in the descriptor. */ 8331 8332 /* For some 1 dimensional arrays, we can emit a more efficient 8333* code sequence than is possible in the general case. */ 8334 8335 if ndims = 1 & desc = 0 & s -> symbol.v_length = 0 & ^d -> dimension.v_bound (1).lower 8336 then do; 8337 d -> dimension.virtual_origin = s -> symbol.element_size * d -> dimension.lower_bound (1); 8338 d -> dimension.has_virtual_origin = "1"b; 8339 d -> dimension.variable_virtual_origin = "0"b; 8340 8341 code_emitted = "1"b; 8342 call compute_dimension_size (1); 8343 8344 if ^d -> dimension.assumed_size 8345 then do; 8346 call load ((d -> dimension.size (1)), in_q); 8347 call mult (s -> symbol.element_size - bias); 8348 call store (array_size, in_q, 0); 8349 end; 8350 return; 8351 end; 8352 8353 /* The more general code sequence must be used. */ 8354 8355 code_emitted = "0"b; 8356 virtual_origin = 0; 8357 c_virtual_origin = 0; 8358 8359 if s -> symbol.v_length = 0 8360 then do; 8361 c_multiplier = s -> symbol.element_size; 8362 v_multiplier = "0"b; 8363 end; 8364 else do; 8365 c_multiplier = 1; 8366 v_multiplier = "1"b; 8367 end; 8368 8369 if s -> symbol.units = char_units & desc ^= 0 & v_multiplier & shared_globals.user_options.table 8370 then c_mult_offset = ndims * 3; /* possible variable dims */ 8371 else c_mult_offset = 0; /* constant dims */ 8372 8373 do i = 1 to ndims; 8374 8375 /* This section of code accumulates the virtual origin 8376* and array size as long as the dimension bounds remain 8377* constant. When a variable bound is encountered, code 8378* is emitted to initialize the virtual origin and array 8379* size to the accumulated partial result. */ 8380 8381 /* If we start with a variable multiplier (i.e. symbol.v_length 8382* ^= 0 then ALL MULTIPLIERS MUST BE CALCULATED, not just the 8383* LAST one. */ 8384 8385 if ^code_emitted 8386 then do; 8387 if string (d -> dimension.v_bound (i)) = "00"b & i < ndims & ^v_multiplier 8388 then do; 8389 c_virtual_origin = c_virtual_origin + c_multiplier * d -> dimension.lower_bound (i); 8390 c_multiplier = c_multiplier * d -> dimension.size (i); 8391 end; 8392 else do; 8393 code_emitted = "1"b; 8394 if i = ndims & ^v_multiplier & ^d -> dimension.v_bound (i).lower 8395 then do; 8396 8397 /* The virtual origin is constant. */ 8398 8399 d -> dimension.virtual_origin = 8400 c_virtual_origin + c_multiplier * d -> dimension.lower_bound (i); 8401 d -> dimension.has_virtual_origin = "1"b; 8402 d -> dimension.variable_virtual_origin = "0"b; 8403 end; 8404 else do; 8405 8406 /* The virtual origin is variable. */ 8407 8408 if ^d -> dimension.has_virtual_origin 8409 then do; 8410 virtual_origin, d -> dimension.virtual_origin = create_var (1); 8411 addr (rands (virtual_origin)) -> symbol.data_type = int_mode; 8412 d -> dimension.has_virtual_origin = "1"b; 8413 d -> dimension.variable_virtual_origin = "1"b; 8414 end; 8415 else virtual_origin = d -> dimension.virtual_origin; 8416 8417 /* Initialize the virtual origin. */ 8418 8419 if c_virtual_origin = 0 8420 then call emit_single (stz, virtual_origin); 8421 else do; 8422 if v_multiplier 8423 then do; 8424 call load ((s -> symbol.v_length), in_q); 8425 call mult (c_virtual_origin - bias); 8426 end; 8427 else call load (create_integer_constant ((c_virtual_origin)), in_q); 8428 call store (virtual_origin, in_q, 0); 8429 end; 8430 end; 8431 8432 /* Initialize the array size. */ 8433 8434 if v_multiplier 8435 then do; 8436 call load ((s -> symbol.v_length), in_q); 8437 call mult (c_multiplier - bias); 8438 end; 8439 else call load (create_integer_constant ((c_multiplier)), in_q); 8440 8441 /* The array size is left in the Q register. */ 8442 8443 call in_reg (array_size, in_q); 8444 end; 8445 end; 8446 8447 /* The following block of code is executed once a variable 8448* array bound has been encountered. */ 8449 8450 if code_emitted 8451 then do; 8452 8453 /* Store the multiplier for this dimension in the 8454* descriptor if appropriate. */ 8455 /* If we will generate a runtime symbol entry and we have 8456* star_extents in a character string then save the byte 8457* length in the runtime multiplier and the bit length will 8458* be concocted later and stored in the true descriptor. */ 8459 8460 if desc ^= 0 & v_multiplier 8461 then if c_mult_offset ^= 0 8462 then call emit_single_with_inc (store_inst (in_q), desc, c_mult_offset + i); 8463 else call emit_single_with_inc (store_inst (in_q), desc, 3 * i); 8464 8465 /* Store the array size if necessary. If the lower 8466* bound is known to be 1, we do not need to store the 8467* array size because (1) multiplying it by 1 to compute 8468* the virtual origin doesn't change it and (2) the Q 8469* is left intact by compute_dimension_size in this 8470* particular case. */ 8471 8472 if d -> dimension.v_bound (i).lower | d -> dimension.lower_bound (i) ^= 1 8473 then call store (array_size, in_q, 1); 8474 8475 /* Update the virtual origin. */ 8476 8477 if virtual_origin ^= 0 8478 then do; 8479 if d -> dimension.v_bound (i).lower 8480 then call mult ((d -> dimension.lower_bound (i))); 8481 else if d -> dimension.lower_bound (i) ^= 1 8482 then call mult (d -> dimension.lower_bound (i) - bias); 8483 8484 call emit_single (asq, virtual_origin); 8485 end; 8486 8487 /* Compute the size of this dimension, and store 8488* the bounds in the array's descriptor. */ 8489 8490 call compute_dimension_size (i); 8491 8492 /* Update the array size to include the size of this 8493* dimension. One of two code sequences is chosen 8494* depending on what is in the Q register. This need 8495* not be done if this is the last dimension of an 8496* assumed size array. */ 8497 8498 if (i < ndims) | ^d -> dimension.assumed_size 8499 then do; 8500 if get_eaq_name (array_size) = in_q 8501 then do; 8502 8503 /* Multiply by dimension size. */ 8504 8505 call load (array_size, in_q); 8506 if string (d -> dimension.v_bound (i)) = "00"b 8507 then call mult (d -> dimension.size (i) - bias); 8508 else call mult ((d -> dimension.size (i))); 8509 end; 8510 else do; 8511 8512 /* Multiply by array size. */ 8513 8514 if string (d -> dimension.v_bound (i)) = "00"b 8515 then call load (create_integer_constant ((d -> dimension.size (i))), in_q); 8516 else call load ((d -> dimension.size (i)), in_q); 8517 call mult (array_size); 8518 end; 8519 8520 /* The updated array_size is left in the Q. */ 8521 8522 call in_reg (array_size, in_q); 8523 end; 8524 8525 /* If bounds are variable, so is multiplier. */ 8526 8527 v_multiplier = v_multiplier | (string (d -> dimension.v_bound (i)) ^= "00"b); 8528 end; 8529 8530 end; 8531 8532 /* Store the array size. */ 8533 8534 if ^d -> dimension.assumed_size 8535 then call store (array_size, in_q, 1); 8536 8537 /* If the array is in character units and there is a descriptor, 8538* the multipliers must be converted from characters to bits. */ 8539 8540 if s -> symbol.units = char_units & desc ^= 0 8541 then do; 8542 if s -> symbol.v_length ^= 0 8543 then i = 1; 8544 else i = 2; 8545 8546 do i = i to ndims; 8547 if c_mult_offset ^= 0 8548 then call emit_single_with_inc (load_inst (in_q), desc, c_mult_offset + i); 8549 else call emit_single_with_inc (load_inst (in_q), desc, 3 * i); 8550 call emit_single (mpy, bits_per_char - bias); 8551 call emit_single_with_inc (store_inst (in_q), desc, 3 * i); 8552 end; 8553 8554 call reset_eaq (Q); 8555 end; 8556 8557 return; 8558 8559 compute_dimension_size: 8560 procedure (dim_no); 8561 8562 /* Emits code to compute the number of elements in a given 8563* dimension. Also stores variable array bounds in the array 8564* descriptor. */ 8565 8566 dcl dim_no fixed binary (18); 8567 dcl i fixed binary (3); 8568 8569 i = dim_no; 8570 8571 /* If this is the last dimension of an assumed size array, 8572* the dimension size must not be calculated. Simply copy 8573* the lower bound to the descriptor if necessary. */ 8574 8575 if (i = ndims) & d -> dimension.assumed_size 8576 then do; 8577 if (desc ^= 0) & d -> dimension.v_bound (i).lower 8578 then do; 8579 call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i))); 8580 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2); 8581 end; 8582 return; 8583 end; 8584 8585 /* The dimension size must be computed. */ 8586 8587 if string (d -> dimension.v_bound (i)) = "01"b 8588 then do; 8589 if d -> dimension.lower_bound (i) = 1 8590 then do; 8591 8592 /* Lower bound is the constant 1. The dimension size 8593* is already correct. If the upper bound needs to be 8594* copied to the descriptor, we use the A register, as 8595* the main loop in get_param_array_size depends on 8596* the Q register remaining intact. */ 8597 8598 if desc ^= 0 8599 then do; 8600 call emit_single (load_inst (in_a), (d -> dimension.upper_bound (i))); 8601 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 1); 8602 end; 8603 end; 8604 else do; 8605 8606 /* Lower bound is some constant other than 1. */ 8607 8608 call load ((d -> dimension.upper_bound (i)), in_q); 8609 if desc ^= 0 8610 then call emit_single_with_inc (store_inst (in_q), desc, 3 * i - 1); 8611 call sub (d -> dimension.lower_bound (i) - 1 - bias); 8612 call store ((d -> dimension.size (i)), in_q, 0); 8613 end; 8614 end; 8615 8616 else if string (d -> dimension.v_bound (i)) = "10"b 8617 then do; 8618 if desc ^= 0 8619 then do; 8620 call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i))); 8621 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2); 8622 end; 8623 call load (create_integer_constant (1 + d -> dimension.upper_bound (i)), in_q); 8624 call sub ((d -> dimension.lower_bound (i))); 8625 call store ((d -> dimension.size (i)), in_q, 0); 8626 end; 8627 8628 else if string (d -> dimension.v_bound (i)) = "11"b 8629 then do; 8630 if desc ^= 0 8631 then do; 8632 call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i))); 8633 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2); 8634 end; 8635 call load ((d -> dimension.upper_bound (i)), in_q); 8636 if desc ^= 0 8637 then call emit_single_with_inc (store_inst (in_q), desc, 3 * i - 1); 8638 call sub ((d -> dimension.lower_bound (i))); 8639 call add (1 - bias); 8640 call store ((d -> dimension.size (i)), in_q, 0); 8641 end; 8642 8643 end compute_dimension_size; 8644 8645 finalize_vsum: 8646 procedure (); 8647 8648 /* Ensures that the variable offset is addressable or 8649* in a register. Called by finish_subscript and 8650* make_substring. Uses the following variables globally: 8651* code_emitted, vsum, a, big_offset */ 8652 8653 dcl v pointer; 8654 dcl i fixed binary (18); 8655 8656 if code_emitted 8657 then do; 8658 vsum = assign_temp (int_mode); 8659 v = addr (rands (vsum)); 8660 call in_reg (vsum, in_q); 8661 end; 8662 else do; 8663 v = addr (rands (vsum)); 8664 if v -> node.node_type = temporary_node 8665 then v -> temporary.ref_count = v -> temporary.ref_count + 1; 8666 end; 8667 8668 a -> array_ref.variable_offset = "1"b; 8669 a -> array_ref.v_offset = vsum; 8670 8671 /* If the single subscript is an array reference, 8672* get it into a register by temporarily pretending 8673* it is the associated temp. (explicitly call m_a 8674* to prevent recursion.) */ 8675 8676 if v -> node.node_type = array_ref_node 8677 then do; 8678 if big_offset 8679 then do; 8680 i = get_eaq_name (vsum); 8681 if i ^= in_ia & i ^= in_q 8682 then call m_a (v); 8683 a -> array_ref.address.tag = eaq_man_load_a_or_q (v); 8684 if a -> array_ref.address.tag = QL_mod 8685 then i = in_q; 8686 else i = in_ia; 8687 vsum = assign_temp (int_mode); 8688 a -> array_ref.v_offset = vsum; 8689 call flush_ref (fixed (rel (v), 18)); 8690 call in_reg (vsum, i); 8691 end; 8692 8693 else do; 8694 if ^v -> node.value_in.x 8695 then call m_a (v); 8696 a -> array_ref.address.tag = xr_man_load_any_xr (v); 8697 i = fixed (a -> array_ref.address.tag, 18) - 8; 8698 vsum = assign_temp (int_mode); 8699 a -> array_ref.v_offset, index_regs (i).variable = vsum; 8700 addr (rands (vsum)) -> temporary.value_in.x = "1"b; 8701 v -> node.value_in.x = "0"b; 8702 end; 8703 end; 8704 8705 else if ^big_offset 8706 then if get_eaq_name (vsum) = in_q 8707 then v -> node.dont_update = "1"b; /* really node.subs_in_q */ 8708 8709 end finalize_vsum; 8710 8711 /* Miscellaneous code emission procedures use by finish_subscript, make_substring, and get_param_array_size */ 8712 8713 add: 8714 procedure (op); 8715 8716 /* Emits code to add op to the variable sum in the Q */ 8717 8718 dcl (mac, op) fixed binary (18); 8719 8720 mac = adfx1; 8721 go to join; 8722 8723 8724 sub: 8725 entry (op); 8726 8727 /* Emits code to subtract op from the variable sum in the Q */ 8728 8729 mac = sbfx1; 8730 8731 join: 8732 if ^code_emitted 8733 then call load_vsum; 8734 8735 if op + bias < 0 8736 then call emit_single (mac, create_integer_constant (op + bias)); 8737 else call emit_single (mac, op); 8738 8739 call reset_eaq (Q); /* Value has been modified */ 8740 8741 end add; 8742 8743 load_vsum: 8744 procedure (); 8745 8746 /* Emits code to load the variable sum into the Q */ 8747 8748 if ^have_vsum 8749 then do; 8750 have_vsum = "1"b; 8751 vsum = create_integer_constant ((csum)); 8752 csum = 0; 8753 end; 8754 8755 call load (vsum, in_q); 8756 call use_eaq (0); 8757 code_emitted = "1"b; 8758 8759 end load_vsum; 8760 8761 mult: 8762 procedure (op); 8763 8764 /* Emits code to multiply the variable sum by op */ 8765 8766 dcl op fixed binary (18); 8767 8768 if ^code_emitted 8769 then call load_vsum; 8770 8771 /* Bug 513: Use an indirect addressing code for referencing, when (op + bias) 8772* is greater than 262143 which is the largest 18 bit value */ 8773 8774 if (op + bias < 0) | (op + bias > 262143) 8775 then call copy (create_integer_constant (op + bias)); 8776 else call copy (op); 8777 call interpreter_proc (subscript_mpy, r2); 8778 r2: 8779 call reset_eaq (Q); /* Value has been modified */ 8780 8781 end mult; 8782 8783 end finish_subscript; 8784 8785 start_subscript: 8786 procedure (); 8787 8788 /* Checks number of subscripts */ 8789 8790 dcl (s, d) pointer; 8791 8792 s = addr (rands (stack (base))); 8793 d = addr (rands (s -> symbol.dimension)); 8794 8795 if d -> dimension.number_of_dims ^= stack (base + 1) + bias 8796 then do; 8797 call print_message (423, stack (base)); 8798 call signal_error; 8799 end; 8800 8801 end start_subscript; 8802 8803 signal_error: 8804 procedure (); 8805 8806 /* Aborts from a subscript or FLD builtin error */ 8807 8808 imac = fixed (rel (addr (fort_cg_macros_$abort_list)), 18); 8809 go to loop; 8810 8811 end signal_error; 8812 8813 /**** ARRAY REF MANAGEMENT ****/ 8814 8815 create_array_ref: 8816 procedure (sym) returns (fixed binary (18)); 8817 8818 /* Creates an array_ref node with sym as its parent */ 8819 8820 dcl (a_ref, sym, csize) fixed binary (18); 8821 dcl (a, s) pointer; 8822 8823 if next_free_array_ref = 0 8824 then do; 8825 a_ref = create_node (array_ref_node, size (array_ref)); 8826 a = addr (rands (a_ref)); 8827 end; 8828 else do; 8829 a_ref = next_free_array_ref; 8830 a = addr (rands (a_ref)); 8831 next_free_array_ref = a -> array_ref.next; 8832 unspec (a -> array_ref) = "0"b; 8833 a -> array_ref.node_type = array_ref_node; 8834 end; 8835 8836 8837 a -> array_ref.parent = sym; 8838 s = addr (rands (sym)); 8839 a -> array_ref.operand_type = array_ref_type; 8840 a -> array_ref.data_type = s -> symbol.data_type; 8841 a -> array_ref.units = s -> symbol.units; 8842 if s -> symbol.data_type = char_mode 8843 then do; 8844 csize = get_char_size (s); 8845 if csize > 0 8846 then do; 8847 a -> array_ref.variable_length = "1"b; 8848 a -> array_ref.length = csize; 8849 end; 8850 else a -> array_ref.length = csize + bias; 8851 end; 8852 a -> array_ref.needs_pointer = s -> symbol.needs_pointer; 8853 unspec (a -> array_ref.address) = unspec (s -> symbol.address); 8854 a -> array_ref.reloc = s -> symbol.reloc; 8855 a -> array_ref.ref_count = 1; 8856 8857 return (a_ref); 8858 8859 end create_array_ref; 8860 8861 free_array_ref: 8862 procedure (pt); 8863 8864 /* Frees an array_ref. The variable length and offset 8865* temporaries are also freed if necessary. */ 8866 8867 dcl (pt, p, t) pointer; 8868 dcl (a_ref, n) fixed binary (18); 8869 8870 p = pt; 8871 a_ref = fixed (rel (p), 18); 8872 8873 if p -> array_ref.ref_count < 0 8874 then do; 8875 call print_message (415, a_ref); 8876 return; 8877 end; 8878 8879 if p -> array_ref.v_offset ^= 0 8880 then do; 8881 t = addr (rands (p -> array_ref.v_offset)); 8882 if t -> node.node_type = temporary_node 8883 then do; 8884 n, t -> temporary.ref_count = t -> temporary.ref_count - 1; 8885 if n <= 0 8886 then call free_temp (t); 8887 end; 8888 end; 8889 8890 if p -> array_ref.variable_length 8891 then do; 8892 t = addr (rands (p -> array_ref.length)); 8893 if t -> node.node_type = temporary_node 8894 then do; 8895 n, t -> temporary.ref_count = t -> temporary.ref_count - 1; 8896 if n <= 0 8897 then call free_temp (t); 8898 end; 8899 end; 8900 8901 call flush_ref (a_ref); 8902 call flush_addr (a_ref); 8903 8904 p -> array_ref.next = next_free_array_ref; 8905 next_free_array_ref = a_ref; 8906 8907 end free_array_ref; 8908 8909 /**** CONCATENATION CODE ****/ 8910 8911 start_cat: 8912 procedure (reallocated); 8913 8914 /* Expects the stack to contain only the two concatenation operands. 8915* Computes the length of the result (emitting code if necessary), 8916* and allocates the temporary for the result (which is pushed on 8917* the stack.) The parameter reallocated is turned on in the case 8918* where the first operand of the concatenation is the most recently 8919* allocated dynamic temporary. (In this case the result temporary 8920* is merely an extension of the first operand). */ 8921 8922 dcl reallocated bit (1) aligned; /* (Output) */ 8923 8924 dcl op (2) fixed binary (18); /* The two operands */ 8925 dcl csize (2) fixed binary (18); /* Actual lengths of operands */ 8926 dcl result fixed binary (18); /* Result temporary (pushed on operand stack) */ 8927 dcl asize (2) fixed binary (18); /* Number of characters allocated to operand */ 8928 dcl tv_offset fixed binary (14); /* Operator offset */ 8929 dcl i fixed binary; /* Loop variable */ 8930 8931 /* Get current and allocated lengths of operands */ 8932 8933 do i = 1 to 2; 8934 op (i) = stack (base + i - 1); 8935 call get_cat_lengths (op (i), csize (i), asize (i)); 8936 end; 8937 8938 /* If neither operand was of star extent, allocate a normal character 8939* temporary and compute its length */ 8940 8941 if (asize (1) > 0) & (asize (2) > 0) 8942 then do; 8943 result = assign_char_temp (asize (1) + asize (2)); 8944 call compute_cat_result_length (result, csize); 8945 call push (result); 8946 reallocated = "0"b; 8947 return; 8948 end; 8949 8950 /* At least one of the operands was of star extent */ 8951 8952 reallocated = (op (1) = machine_state.last_dynamic_temp); 8953 8954 if reallocated 8955 then tv_offset = reallocate_char_string; 8956 else tv_offset = allocate_char_string; 8957 8958 result = assign_dynamic_temp (); 8959 call compute_cat_result_length (result, csize); 8960 call allocate_dynamic_temp (result, tv_offset); 8961 call push (result); 8962 8963 end start_cat; 8964 8965 continue_cat: 8966 procedure (); 8967 8968 /* Adds the length of the first concatenation operand into the 8969* address of the result. Expects the stack to be as start_cat 8970* left it (opnd1, opnd2, result). */ 8971 8972 dcl (p, p1) pointer; /* To result, opnd1 */ 8973 dcl csize fixed binary (18); /* Length of opnd1 */ 8974 dcl off fixed binary (18); /* Total char offset */ 8975 dcl lreg bit (6) aligned; /* Register length tag */ 8976 8977 p = addr (rands (stack (top))); 8978 p1 = addr (rands (stack (base))); 8979 8980 /* Save the address of the result temporary in the global variable 8981* saved_cat_address. It will be restored when the concatenation 8982* is finished by finish_cat. */ 8983 8984 saved_cat_address = p -> temporary.address; 8985 8986 csize = get_char_size (p1); 8987 if csize < 0 8988 then do; 8989 8990 /* Length of opnd1 is constant. Try adding length to the 8991* address of the result, avoiding large address. Note that 8992* opnd1 cannot be a dynamic temp in this case. */ 8993 8994 off = (p -> temporary.address.offset * chars_per_word) + (csize + bias); 8995 if off < 16384 * chars_per_word 8996 then do; 8997 p -> temporary.address.char_num = mod (off, chars_per_word); 8998 if (off < 0) & (p -> temporary.address.char_num ^= 0) 8999 then p -> temporary.address.offset = divide (off, chars_per_word, 18, 0) - 1; 9000 else p -> temporary.address.offset = divide (off, chars_per_word, 18, 0); 9001 return; 9002 end; 9003 9004 lreg = xr_man_load_const (csize + bias); 9005 end; 9006 9007 else if get_eaq_name (csize) > 0 9008 then lreg = eaq_man_load_a_or_q (addr (rands (csize))); 9009 else lreg = xr_man_load_any_xr (addr (rands (csize))); 9010 9011 call lock_tag_register (lreg); 9012 9013 p -> temporary.address.tag = p -> temporary.address.tag | lreg; 9014 9015 end continue_cat; 9016 9017 finish_cat: 9018 procedure (); 9019 9020 /* Restores the original address of the result temporary. The same 9021* stack format as continue_cat is expected. */ 9022 9023 addr (rands (stack (top))) -> temporary.address = saved_cat_address; 9024 9025 call free_regs (); 9026 9027 end finish_cat; 9028 9029 get_cat_lengths: 9030 procedure (opnd, actual_length, alloc_length); 9031 9032 /* Gets the actual length and the allocated length for one operand. 9033* The actual length is either a count or an operand offset as 9034* returned by get_char_size. The allocated length is a positive 9035* integer (the length in characters), or zero if the operand is 9036* of star extent. */ 9037 9038 dcl opnd fixed binary (18); /* Operand offset */ 9039 dcl actual_length fixed binary (18); /* (Output) Real char length */ 9040 dcl alloc_length fixed binary (18); /* (Output) Length for allocation */ 9041 9042 dcl p pointer; /* To operand */ 9043 dcl csize fixed binary (18); /* Character length */ 9044 dcl psize fixed binary (18); /* Parent's length */ 9045 9046 p = addr (rands (opnd)); 9047 9048 csize = get_char_size (p); 9049 if csize < 0 9050 then do; 9051 9052 /* Constant length */ 9053 9054 actual_length = csize; 9055 alloc_length = csize + bias; 9056 return; 9057 end; 9058 9059 /* If the operand is not of constant length, but is a substring or 9060* array reference whose parent is of constant length, return the 9061* parent's length as the length for allocation. */ 9062 9063 if p -> node.node_type = array_ref_node 9064 then do; 9065 psize = get_char_size (addr (rands (p -> array_ref.parent))); 9066 if psize < 0 9067 then do; 9068 actual_length = csize; 9069 alloc_length = psize + bias; 9070 return; 9071 end; 9072 end; 9073 9074 /* If the operand is a variable length temporary that is not of 9075* star extent, use the allocated length of the temporary as the 9076* length for allocation. */ 9077 9078 else if p -> node.node_type = temporary_node 9079 then if ^p -> temporary.stack_indirect 9080 then do; 9081 actual_length = csize; 9082 alloc_length = p -> temporary.size * chars_per_word; 9083 return; 9084 end; 9085 9086 /* The operand must be of star extent. */ 9087 9088 actual_length = csize; 9089 alloc_length = 0; 9090 9091 end get_cat_lengths; 9092 9093 compute_cat_result_length: 9094 procedure (result, op_length); 9095 9096 /* Computes the length of concatenation result, emitting code if 9097* necessary, and updates the result temporary appropriately. */ 9098 9099 dcl result fixed binary (18); /* Result temp */ 9100 dcl op_length (2) fixed binary (18); /* Operand lengths */ 9101 9102 dcl p pointer; /* To result temp */ 9103 dcl temp fixed binary (18); /* Length temp */ 9104 dcl op1 fixed binary (18); /* Length of first opnd */ 9105 9106 p = addr (rands (result)); 9107 9108 if (op_length (1) < 0) & (op_length (2) < 0) 9109 then do; 9110 9111 /* Both operands are of constant length */ 9112 9113 p -> temporary.length = (op_length (1) + bias) + (op_length (2) + bias); 9114 p -> temporary.variable_length = "0"b; 9115 return; 9116 end; 9117 9118 /* At least one of the operand lengths is non-constant. Emit code 9119* to compute the length of the result. */ 9120 9121 if op_length (1) < 0 9122 then op1 = create_integer_constant (op_length (1) + bias); 9123 else op1 = op_length (1); 9124 9125 call load (op1, in_q); 9126 call use_eaq (0); 9127 call emit_single (adfx1, (op_length (2))); 9128 9129 temp, p -> temporary.length = assign_temp (int_mode); 9130 call in_reg (temp, in_q); 9131 9132 p -> temporary.variable_length = "1"b; 9133 9134 end compute_cat_result_length; 9135 9136 /**** DESCRIPTOR RELATED CODE ****/ 9137 9138 get_param_char_size: 9139 procedure (sym, arg_no); 9140 9141 /* This procedure generates code to extract the length of a 9142* star extent character string from the argument list 9143* descriptor and store it in the symbol.v_length variable 9144* allocated by the parse. Also, if the character string is 9145* passed as an argument and requires a descriptor of its own, 9146* code is generated to initialize the automatic descriptor 9147* from the template in the text section and to fill in the 9148* length field. */ 9149 9150 dcl (s, sym) pointer; 9151 dcl arg_no fixed binary (18); 9152 9153 dcl desc fixed binary (18); 9154 dcl mask fixed binary (18); /* mask off high bits of Q register */ 9155 9156 s = sym; 9157 desc = s -> symbol.hash_chain; 9158 9159 /* If there is a descriptor template node, but it has not been 9160* assigned storage, then it is only needed to build the entry 9161* point definitions and we can ignore it. */ 9162 9163 if desc ^= 0 9164 then if ^addr (rands (desc)) -> symbol.allocated 9165 then desc = 0; 9166 9167 /* Initialize the automatic descriptor if array */ 9168 9169 if desc ^= 0 & s -> symbol.dimensioned 9170 then call copy_array_desc_template (s); 9171 9172 /* Extract length from descriptor and store it in symbol.v_length */ 9173 9174 addr (rands (builtins (11))) -> symbol.location = 2 * arg_no - 2; 9175 call emit_single ((load_inst (in_q)), (builtins (11))); 9176 call emit_c_a (anq, descriptor_mask_addr); 9177 call emit_single ((store_inst (in_q)), (s -> symbol.v_length)); 9178 9179 /* Put length into automatic descriptor */ 9180 9181 if desc ^= 0 9182 then do; 9183 mask = create_constant (int_mode, "777700000000"b3); 9184 if s -> symbol.dimensioned 9185 then do; 9186 call emit_single (orq, mask); 9187 call emit_single (anq, desc); 9188 call emit_single (stq, desc); 9189 end; 9190 9191 else do; 9192 9193 /* Get type bits while we're at it */ 9194 call emit_single (orq, mask); 9195 call emit_single (anq, (addr (rands (desc)) -> symbol.general)); 9196 call emit_single ((store_inst (in_q)), desc); 9197 end; 9198 end; 9199 9200 call reset_eaq (Q); 9201 9202 return; 9203 9204 end get_param_char_size; 9205 9206 copy_array_desc_template: 9207 procedure (sym); 9208 9209 /* Generates code to copy the descriptor template for an array 9210* from the text into automatic storage. */ 9211 9212 dcl (s, sym) pointer; 9213 dcl desc fixed binary (18); 9214 9215 s = sym; 9216 desc = s -> symbol.hash_chain; 9217 9218 call push ((addr (rands (desc)) -> symbol.general)); 9219 call push (desc); 9220 call interpreter_proc (move_eis, r3); 9221 r3: 9222 return; 9223 9224 end copy_array_desc_template; 9225 9226 make_descriptor: 9227 procedure (var) returns (fixed binary (18)); 9228 9229 /* Builds a descriptor for var, which must be either a temporary, 9230* an array reference, or a symbol of constant extent (variable- 9231* and star-extent symbols have been dealt with at storage 9232* allocation time.) If the temporary or array_ref is a character 9233* string of star extent, code is emitted to fill in the length 9234* field of the descriptor. */ 9235 9236 dcl var fixed binary (18); /* Argument that needs a descriptor */ 9237 dcl p pointer; 9238 dcl (desc, const, dt, csize) fixed binary (18); 9239 dcl v_length bit (1) aligned; 9240 9241 dcl 1 descriptor aligned, /* Scalars only */ 9242 2 type_word aligned, 9243 3 bit_type unaligned, 9244 4 flag bit (1) unaligned, 9245 4 type bit (6) unaligned, 9246 4 packed bit (1) unaligned, 9247 3 number_dims fixed binary (3) unaligned, 9248 3 size fixed binary (23) unaligned; 9249 9250 p = addr (rands (var)); 9251 unspec (descriptor) = "0"b; 9252 v_length = "0"b; 9253 9254 /* Handle symbols */ 9255 9256 if p -> node.node_type = symbol_node 9257 then if p -> symbol.hash_chain ^= 0 9258 then return (p -> symbol.hash_chain); 9259 else return (make_symbol_descriptor ((var))); 9260 9261 /* Initialize the descriptor's type word */ 9262 9263 if p -> node.operand_type >= bif 9264 then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7)); 9265 else do; 9266 dt = p -> node.data_type; 9267 unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt)); 9268 if dt = char_mode 9269 then do; 9270 if p -> node.units = char_units 9271 then descriptor.packed = "1"b; 9272 csize = get_char_size (p); 9273 if csize < 0 9274 then descriptor.size = csize + bias; 9275 else v_length = "1"b; 9276 end; 9277 end; 9278 9279 /* Create a constant node for the descriptor */ 9280 9281 const = create_constant (int_mode, unspec (descriptor.type_word)); 9282 9283 /* If the descriptor must be filled in at runtime, allocate a 9284* temporary for it, and emit code to initialize it. */ 9285 9286 if v_length 9287 then do; 9288 desc = assign_temp (int_mode); 9289 call load (get_char_size (p), in_q); 9290 call emit_c_a (anq, descriptor_mask_addr); 9291 call emit_single (orq, const); 9292 call emit_single (store_inst (in_q), desc); 9293 call reset_eaq (Q); 9294 9295 /* Chain this descriptor so that it can be freed after 9296* the call has been compiled */ 9297 9298 addr (rands (desc)) -> temporary.next = desc_temp_chain; 9299 desc_temp_chain = desc; 9300 end; 9301 else desc = const; 9302 9303 return (desc); 9304 9305 end make_descriptor; 9306 9307 set_itp_addr: 9308 procedure (pt, pos); 9309 9310 /* Sets one element of an ITP list to contain the 9311* address of the operand pointed to by pt. */ 9312 9313 dcl (pt, p) pointer; 9314 dcl (pos, i) fixed binary (18); 9315 9316 p = pt; 9317 i = pos; 9318 9319 string (itp_list (i)) = "0"b; 9320 9321 if p -> node.ext_base 9322 then do; 9323 itp_list (i).pr_no = p -> node.base; 9324 itp_list (i).itp_mod = ITP_mod; 9325 itp_list (i).offset = bit (fixed (p -> node.address.offset, 18), 18); 9326 itp_list (i).bit_offset = bit (fixed (p -> node.address.char_num * bits_per_char, 6), 6); 9327 9328 /* Bug 344 - If is indirect entry manufactured by the compiler to stack then we 9329* need to indirect through ITP. */ 9330 9331 if p -> node.stack_indirect & ^(p -> node.node_type = symbol_node & p -> symbol.VLA) 9332 then itp_list (i).mod = RI_mod; /* RI (*n) */ 9333 end; 9334 else addr (itp_list (i)) -> ind_word = unspec (p -> node.address); 9335 9336 end set_itp_addr; 9337 9338 check_arg_list: 9339 procedure (); 9340 9341 /* Checks argument lists for consistency, using subprogram 9342* definition if possible otherwise using the first invoction 9343* of each subprogram as a model for checking. If the call is 9344* to an external (descriptors) procedure, consistency is not 9345* checked, but assumed size arrays as arguments are diagnosed. 9346* The stack looks like: 9347* 9348* external reference 9349* count 9350* arg1 9351* arg2 9352* . 9353* . 9354* . 9355* argn 9356* */ 9357 9358 dcl (adesc, i) fixed binary (18); 9359 dcl (a, p, s) pointer; 9360 9361 num_args = stack (base + 1) + bias; 9362 s = addr (rands (stack (base))); 9363 9364 if s -> symbol.variable_arglist 9365 then do; 9366 9367 /* Must diagnose assumed size arrays as arguments */ 9368 9369 do i = 1 to num_args; 9370 p = addr (rands (stack (base + i + 1))); 9371 if p -> node.node_type = symbol_node 9372 then if p -> symbol.dimensioned 9373 then if addr (rands (p -> symbol.dimension)) -> dimension.assumed_size 9374 then call print_message (468, stack (base), stack (base + i + 1)); 9375 end; 9376 end; 9377 9378 else do; 9379 if s -> symbol.general = 0 9380 then call find_arg_desc (s); 9381 if s -> symbol.general = 0 9382 then do; /* couldn't find arg_desc node, probably an external procedure */ 9383 9384 /* first time, set up arg_desc structure */ 9385 9386 9387 adesc, s -> symbol.general = create_node (arg_desc_node, size (arg_desc)); 9388 a = addr (rands (adesc)); 9389 a -> arg_desc.n_args = num_args; 9390 9391 do i = 1 to num_args; 9392 p = addr (rands (stack (base + i + 1))); 9393 a -> arg_desc.data_type (i) = p -> node.data_type; 9394 if p -> node.node_type = symbol_node 9395 then if p -> symbol.dimensioned 9396 then do; 9397 a -> arg_desc.must_be.array (i) = "1"b; 9398 if p -> symbol.ext_attributes.VLA 9399 then a -> arg_desc.must_be.VLA (i) = "1"b; 9400 end; 9401 else a -> arg_desc.must_be.scalar (i) = "1"b; 9402 else if p -> node.node_type ^= array_ref_node 9403 then a -> arg_desc.must_be.scalar (i) = "1"b; 9404 end; 9405 end; 9406 9407 else do; 9408 9409 /* not the first time, compare args with arg_desc structure */ 9410 9411 a = addr (rands (s -> symbol.general)); 9412 9413 if num_args ^= a -> arg_desc.n_args 9414 then do; 9415 call print_message (400, stack (base)); 9416 if num_args > a -> arg_desc.n_args 9417 then num_args = a -> arg_desc.n_args; 9418 end; 9419 9420 do i = 1 to num_args; 9421 p = addr (rands (stack (base + i + 1))); 9422 9423 /* When a program calls an internal subroutine with arguments 9424* that are declared as different data types in the included 9425* routine, it will raise an error except in the case of 9426* passing a character constant. */ 9427 9428 if (p -> node.node_type ^= char_constant_node) 9429 then do; 9430 if (p -> node.data_type ^= a -> arg_desc.data_type (i)) 9431 & 9432 ^(p -> node.node_type = temporary_node 9433 & addr (rands (a -> arg_desc.arg (i).symbol)) -> symbol.external) 9434 then call bad_arg; 9435 9436 else if p -> node.node_type = symbol_node 9437 then do; 9438 if p -> symbol.dimensioned 9439 then do; 9440 if a -> arg_desc.must_be.scalar (i) 9441 then call bad_arg; 9442 else if p -> symbol.ext_attributes.VLA 9443 then if ^a -> arg_desc.must_be.VLA (i) 9444 then call bad_arg; 9445 end; 9446 else if a -> arg_desc.must_be.array (i) 9447 then call bad_arg; 9448 end; 9449 else if p -> node.node_type ^= array_ref_node 9450 then if a -> arg_desc.must_be.array (i) 9451 then call bad_arg; 9452 end; 9453 end; 9454 end; 9455 end; 9456 9457 9458 bad_arg: 9459 procedure (); 9460 9461 call print_message (401, stack (base + i + 1), stack (base)); 9462 9463 end bad_arg; 9464 9465 /* This procedure finds an arg_desc node that corresponds to an entry node. 9466* It looks up the entry node that corresponds to the actual declaration of 9467* a subprogram (if one exists), and looks in its symbol.general field to 9468* find its arg_desc node. It returns the location of the arg_desc node by 9469* setting the referencing entry node's general field. It also makes sure 9470* that the arg_desc node contains the data_type associated with each 9471* parameter. */ 9472 find_arg_desc: 9473 proc (sp); 9474 dcl (e, i, ii) fixed bin; 9475 dcl (sp, ap, ep, symp) ptr; 9476 9477 /* find the entry node with the same name */ 9478 e = shared_globals.first_entry_name; 9479 do while (addr (rands (e)) -> symbol.name ^= sp -> symbol.name & e ^= shared_globals.last_entry_name); 9480 e = addr (rands (e)) -> symbol.next_symbol; 9481 end; 9482 ep = addr (rands (e)); 9483 9484 if ep -> symbol.name ^= sp -> symbol.name 9485 then return; /* couldn't find it */ 9486 if ep -> symbol.general = 0 9487 then return; /* no arg_desc node */ 9488 9489 sp -> symbol.general = ep -> symbol.general; 9490 9491 /* make sure that the data_type fields are set. If there are any * arguments 9492* (indicated by there being no symbol node accociated with the argument), then 9493* remove all of these args and place one * arg at the end of the list. Set 9494* its data_type to 1. */ 9495 9496 ap = addr (rands (ep -> symbol.general)); 9497 ii = 1; 9498 do i = 1 to ap -> arg_desc.n_args; 9499 if ap -> arg_desc.arg (i).symbol ^= 0 9500 then do; 9501 ap -> arg_desc.arg (ii) = ap -> arg_desc.arg (i); 9502 if ap -> arg_desc.arg (ii).data_type = 0 9503 then do; 9504 symp = addr (rands (ap -> arg_desc.arg (ii).symbol)); 9505 ap -> arg_desc.arg (ii).data_type = symp -> symbol.data_type; 9506 if symp -> node.node_type = symbol_node 9507 then if symp -> symbol.dimensioned 9508 then do; 9509 ap -> arg_desc.arg (ii).must_be.array = "1"b; 9510 if symp -> symbol.ext_attributes.VLA 9511 then ap -> arg_desc.must_be.VLA (ii) = "1"b; 9512 end; 9513 else ap -> arg_desc.arg (ii).must_be.scalar = "1"b; 9514 else if symp -> node.node_type ^= array_ref_node 9515 then ap -> arg_desc.arg (ii).must_be.scalar = "1"b; 9516 end; 9517 ii = ii + 1; 9518 end; 9519 end; 9520 if ii ^= i 9521 then do; 9522 9523 /* at least one asterisk arg was removed */ 9524 9525 ap -> arg_desc.n_args = ii; 9526 unspec (ap -> arg_desc.arg (ii)) = "0"b; 9527 ap -> arg_desc.arg (ii).data_type = 1; 9528 end; 9529 end find_arg_desc; 9530 9531 end check_arg_list; 9532 9533 /**** FLD BUILTIN CODE ****/ 9534 one_word_dt: 9535 procedure (opnd) returns (bit (1)); 9536 9537 /* Returns true if "opnd" has a data type that takes up exactly one word 9538* of aligned storage. */ 9539 9540 dcl opnd fixed bin (18); 9541 dcl p pointer; 9542 9543 p = addr (rands (opnd)); 9544 if (p -> node.data_type = int_mode) | (p -> node.data_type = real_mode) | (p -> node.data_type = typeless_mode) 9545 then return ("1"b); 9546 else if (p -> node.data_type = char_mode) 9547 then if (p -> node.node_type = symbol_node) 9548 then return (p -> symbol.char_size = 3 & ^p -> symbol.aliasable); 9549 else if (p -> node.node_type = char_constant_node) 9550 then return (p -> char_constant.length = 4); 9551 else return ("0"b); 9552 else return ("0"b); 9553 end one_word_dt; 9554 9555 generate_mask: 9556 procedure (start, len) returns (fixed bin (18)); 9557 9558 /* Creates an integer constant mask */ 9559 9560 dcl (start, len) fixed bin (18); 9561 dcl mask fixed bin (35); 9562 9563 9564 mask = 0; 9565 substr (unspec (mask), start + 1, len) = "111111111111111111111111111111111111"b; 9566 9567 return (create_integer_constant (mask)); 9568 end generate_mask; 9569 9570 rhs_fld: 9571 procedure; 9572 9573 /* emits the code for the case of the fld intrinsic on the right hand 9574* side of an assignement statement. The code is emitted manually as the macros are 9575* are not general enough to allow computed bit masks. */ 9576 9577 dcl shift fixed bin; 9578 dcl (arg1, arg2, arg3, start, len) fixed bin (18); 9579 dcl (found_error, arg1_is_const, arg2_is_const) bit (1) init ("0"b); 9580 9581 arg1 = stack (get_operand (5)); 9582 if addr (rands (arg1)) -> node.data_type ^= int_mode 9583 then do; 9584 call print_message (359, arg1); 9585 found_error = "1"b; 9586 end; 9587 arg2 = stack (get_operand (6)); 9588 if addr (rands (arg2)) -> node.data_type ^= int_mode 9589 then do; 9590 call print_message (359, arg2); 9591 found_error = "1"b; 9592 end; 9593 arg3 = stack (get_operand (7)); 9594 if ^one_word_dt (arg3) 9595 then do; 9596 call print_message (360, arg3); 9597 found_error = "1"b; 9598 end; 9599 if found_error 9600 then call signal_error; 9601 9602 if addr (rands (arg2)) -> node.node_type = constant_node 9603 then do; 9604 arg2_is_const = "1"b; 9605 len = addr (addr (rands (arg2)) -> constant.value) -> based_integer; 9606 if len < 1 | len > 36 9607 then call print_message (364); 9608 if len = 0 9609 then do; 9610 call load (create_integer_constant (0), in_tq); 9611 return; 9612 end; 9613 end; 9614 if addr (rands (arg1)) -> node.node_type = constant_node 9615 then do; 9616 arg1_is_const = "1"b; 9617 start = addr (addr (rands (arg1)) -> constant.value) -> based_integer; 9618 if start < 0 | start > 35 9619 then call print_message (363); 9620 end; 9621 9622 if arg1_is_const & arg2_is_const 9623 then do; 9624 start = min (max (start, 0), 35); 9625 len = min (max (len, 0), 36 - start); 9626 shift = 36 - (start + len); 9627 9628 call load (arg3, in_tq); 9629 9630 if start = 0 9631 then do; 9632 if len = 36 9633 then return; 9634 call emit_single (qrl, shift - bias); 9635 end; 9636 9637 else if shift = 0 9638 then call emit_single (anq, generate_mask (start, len)); 9639 9640 else do; 9641 call emit_single (qls, start - bias); 9642 call emit_single (qrl, (36 - len) - bias); 9643 end; 9644 call reset_eaq (Q); 9645 return; 9646 end; 9647 else do; 9648 call load (arg3, in_tq); 9649 9650 if arg1_is_const 9651 then do; 9652 if start ^= 0 9653 then call emit_single (qls, start - bias); 9654 call emit_single (lca, arg2); 9655 call emit_with_tag (qrl, 36, AL_mod); 9656 call reset_eaq (A); 9657 end; 9658 else if arg2_is_const 9659 then do; 9660 call load (arg1, in_ia); 9661 call emit_with_tag (qls, 0, AL_mod); 9662 call emit_single (qrl, (36 - len) - bias); 9663 end; 9664 else do; 9665 call load (arg1, in_ia); 9666 call emit_with_tag (qls, 0, AL_mod); 9667 call emit_single (lca, arg2); 9668 call emit_with_tag (qrl, 36, AL_mod); 9669 call reset_eaq (A); 9670 end; 9671 call reset_eaq (Q); 9672 return; 9673 end; 9674 return; 9675 end rhs_fld; 9676 9677 lhs_fld: 9678 procedure; 9679 9680 /* emits the code for the case of the fld intrinsic on the left hand side 9681* of an assignment statement. The code is emitted manually as the macros 9682* are not general enough to allow certain optimizations (such as bit 9683* masks. */ 9684 9685 dcl shift fixed bin; 9686 dcl RHS fixed bin (35); 9687 dcl (arg1, arg2, arg3, arg4, start, len) fixed bin (18); 9688 dcl (found_error, arg1_is_const, arg2_is_const) bit (1) init ("0"b); 9689 dcl copy builtin; 9690 9691 arg1 = stack (get_operand (1)); 9692 if addr (rands (arg1)) -> node.data_type ^= int_mode 9693 then do; 9694 call print_message (359, arg1); 9695 found_error = "1"b; 9696 end; 9697 arg2 = stack (get_operand (2)); 9698 if addr (rands (arg2)) -> node.data_type ^= int_mode 9699 then do; 9700 call print_message (359, arg2); 9701 found_error = "1"b; 9702 end; 9703 arg3 = stack (get_operand (3)); 9704 if ^one_word_dt (arg3) 9705 then do; 9706 call print_message (360, arg3); 9707 found_error = "1"b; 9708 end; 9709 arg4 = stack (get_operand (4)); 9710 if ^one_word_dt (arg4) 9711 then do; 9712 call print_message (361); 9713 found_error = "1"b; 9714 end; 9715 if found_error 9716 then call signal_error; 9717 9718 if addr (rands (arg2)) -> node.node_type = constant_node 9719 then do; 9720 arg2_is_const = "1"b; 9721 len = addr (addr (rands (arg2)) -> constant.value) -> based_integer; 9722 if len < 1 | len > 36 9723 then call print_message (364); 9724 if len = 0 9725 then return; 9726 end; 9727 if addr (rands (arg1)) -> node.node_type = constant_node 9728 then do; 9729 arg1_is_const = "1"b; 9730 start = addr (addr (rands (arg1)) -> constant.value) -> based_integer; 9731 if start < 0 | start > 35 9732 then call print_message (363); 9733 end; 9734 9735 if arg1_is_const & arg2_is_const 9736 then do; 9737 start = min (max (start, 0), 35); 9738 len = min (max (len, 0), 36 - start); 9739 9740 if start = 0 & len = 36 9741 then do; 9742 call load (arg4, in_tq); 9743 call store (arg3, in_tq, 0); 9744 return; 9745 end; 9746 9747 if addr (rands (arg4)) -> node.node_type = constant_node 9748 then do; 9749 unspec (RHS) = 9750 copy ("0"b, start) || substr (addr (rands (arg4)) -> constant.value, 36 - len + 1, len); 9751 call load (create_integer_constant (RHS), in_tq); 9752 end; 9753 else do; 9754 call load (arg4, in_tq); 9755 shift = 36 - start - len; 9756 if shift > 0 9757 then call emit_single (qls, shift - bias); 9758 end; 9759 call emit_single (erq, arg3); 9760 call emit_single (anq, generate_mask (start, len)); 9761 call emit_single (ersq, arg3); 9762 call reset_eaq (Q); 9763 end; 9764 9765 else if arg1_is_const 9766 then do; 9767 call use_eaq (0); 9768 call reserve_regs (("1"b)); 9769 9770 call emit_single (lxl0, arg2); 9771 call emit_single (load_inst (in_ia), arg3); 9772 call emit_with_tag (alr, start, X0_mod); 9773 call emit_single (era, arg4); 9774 call emit_with_tag (load_inst (in_iq), 0, DL_mod); 9775 call emit_with_tag (lrs, 0, X0_mod); 9776 if start ^= 0 9777 then call emit_single (qrl, start - bias); 9778 call emit_single (ersq, arg3); 9779 end; 9780 9781 else if arg2_is_const 9782 then do; 9783 call use_eaq (0); 9784 call reserve_regs (("1"b)); 9785 9786 call emit_single (lxl0, arg1); 9787 call emit_single (load_inst (in_ia), arg3); 9788 call emit_with_tag (alr, len, X0_mod); 9789 call emit_single (era, arg4); 9790 call emit_with_tag (load_inst (in_iq), 0, DL_mod); 9791 call emit_single (lrs, len - bias); 9792 call emit_with_tag (qrl, 0, X0_mod); 9793 call emit_single (ersq, arg3); 9794 end; 9795 9796 else do; 9797 call use_eaq (0); 9798 call reserve_regs (("11"b)); 9799 9800 call emit_single (lxl0, arg1); 9801 call emit_single (lxl1, arg2); 9802 call emit_single (load_inst (in_ia), arg3); 9803 call emit_with_tag (alr, 0, X0_mod); 9804 call emit_with_tag (alr, 0, X1_mod); 9805 call emit_single (era, arg4); 9806 call emit_with_tag (load_inst (in_iq), 0, DL_mod); 9807 call emit_with_tag (lrs, 0, X1_mod); 9808 call emit_with_tag (qrl, 0, X0_mod); 9809 call emit_single (ersq, arg3); 9810 end; 9811 return; 9812 end lhs_fld; 9813 9814 start_subprogram: 9815 procedure (); 9816 9817 /* Initializes global variables for a subprogram. */ 9818 9819 dcl i fixed binary; 9820 dcl (last, temp) fixed binary (18); 9821 9822 cs = addr (rands (cur_subprogram)); 9823 call get_subr_options (cs); 9824 9825 if cs -> subprogram.subprogram_type ^= main_program 9826 then do; 9827 last_auto_loc = last_auto_loc + mod (last_auto_loc, 2); 9828 cs -> subprogram.entry_info = last_auto_loc; 9829 call set_address_offset (addr (rands (builtins (8))), last_auto_loc, entry_info_size, word_units); 9830 last_auto_loc = last_auto_loc + entry_info_size; 9831 if last_auto_loc > max_stack_size 9832 then call print_message (414, 9833 "making subroutine entry for " || addr (rands (cs -> subprogram.symbol)) -> symbol.name 9834 || " has exceeded the stack frame", max_stack_size - bias); 9835 end; 9836 9837 ipol = cs -> subprogram.first_polish; 9838 9839 do i = 1 to hbound (free_temps, 1); 9840 if free_temps (i) ^= 0 9841 then do; 9842 do temp = free_temps (i) repeat (addr (rands (temp)) -> temporary.next) while (temp ^= 0); 9843 last = temp; 9844 end; 9845 addr (rands (last)) -> temporary.next = next_free_temp; 9846 next_free_temp = free_temps (i); 9847 free_temps (i) = 0; 9848 end; 9849 end; 9850 9851 end start_subprogram; 9852 9853 9854 end interpreter; 9855 9856 get_char_size: 9857 procedure (pt) returns (fixed binary (18)); 9858 9859 /* Procedure to return the size of a character string. 9860* The size is returned as a count (if it is constant) 9861* or as an operand index. */ 9862 9863 dcl (p, pt) pointer; /* Pointer to character node */ 9864 9865 p = pt; 9866 9867 if p -> node.data_type ^= char_mode 9868 then call print_message (412, fixed (rel (p), 18)); 9869 9870 if p -> node.node_type = char_constant_node 9871 then return (p -> char_constant.length - bias); 9872 9873 if p -> node.node_type = symbol_node 9874 then do; 9875 if p -> symbol.v_length ^= 0 9876 then return (p -> symbol.v_length); 9877 else return (p -> symbol.char_size + 1 - bias); 9878 end; 9879 9880 if p -> node.node_type = array_ref_node 9881 then do; 9882 if p -> array_ref.variable_length 9883 then return (p -> array_ref.length); 9884 else return (p -> array_ref.length - bias); 9885 end; 9886 9887 if p -> node.node_type = temporary_node 9888 then do; 9889 if p -> temporary.variable_length 9890 then return (p -> temporary.length); 9891 else return (p -> temporary.length - bias); 9892 end; 9893 9894 call print_message (412, fixed (rel (p), 18)); 9895 9896 end get_char_size; 9897 9898 make_symbol_descriptor: 9899 procedure (var) returns (fixed binary (18)); 9900 9901 /* Builds a descriptor for the symbol var. If var is a parameter 9902* of star or expression extents, the appropriate fields of the 9903* descriptor are filled in later by get_param_array_size or 9904* get_param_char_size. */ 9905 9906 dcl var fixed binary (18); /* Symbol that needs a descriptor */ 9907 9908 dcl (p, d, cs) pointer; 9909 dcl (i, cm, desc, dt, const, ndims, char_star_ndims, csize) fixed binary (18); 9910 dcl v_length bit (1) aligned; 9911 9912 dcl 1 descriptor aligned, 9913 2 type_word aligned, 9914 3 bit_type unaligned, 9915 4 flag bit (1) unaligned, 9916 4 type bit (6) unaligned, 9917 4 packed bit (1) unaligned, 9918 3 number_dims fixed binary (3) unaligned, 9919 3 size fixed binary (23) unaligned, 9920 2 array_info (7) aligned, 9921 3 l_bound fixed binary (18), 9922 3 h_bound fixed binary (18), 9923 3 multiplier fixed binary (18); 9924 9925 dcl desc_image character (chars_per_word * (1 + char_star_ndims + 3 * ndims)) unaligned based (addr (descriptor)); 9926 9927 dcl (length, size) builtin; 9928 9929 p = addr (rands (var)); 9930 unspec (descriptor) = "0"b; 9931 v_length = "0"b; 9932 ndims, char_star_ndims = 0; 9933 9934 /* If the symbol already has a descriptor, return it */ 9935 9936 if p -> symbol.hash_chain ^= 0 9937 then return (p -> symbol.hash_chain); 9938 9939 /* Initialize the descriptor's type word */ 9940 9941 if p -> symbol.operand_type >= bif 9942 then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7)); 9943 else do; 9944 dt = p -> symbol.data_type; 9945 unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt)); 9946 if dt = char_mode 9947 then do; 9948 if p -> symbol.units = char_units 9949 then descriptor.packed = "1"b; 9950 csize = get_char_size (p); 9951 if csize < 0 9952 then descriptor.size = csize + bias; 9953 else do; 9954 v_length = "1"b; 9955 unspec (descriptor.size) = "77777777"b3; 9956 end; 9957 end; 9958 end; 9959 9960 /* If symbol is dimensioned, add the dimension info */ 9961 /* If we would have to concoct runtime character*(*) lengths for a 9962* runtime symbol table, reserve space for the character multipliers. */ 9963 9964 if p -> symbol.dimensioned 9965 then do; 9966 d = addr (rands (p -> symbol.dimension)); 9967 ndims = d -> dimension.number_of_dims; 9968 descriptor.number_dims = ndims; 9969 9970 if v_length & shared_globals.user_options.table 9971 then char_star_ndims = ndims; /* count char*(*) multiplier extras */ 9972 9973 if descriptor.packed 9974 then cm = get_size_in_bits ((p -> symbol.element_size), (p -> symbol.units)); 9975 else cm = get_size_in_words ((p -> symbol.element_size), (p -> symbol.units)); 9976 9977 do i = 1 to ndims; 9978 9979 if ^v_length 9980 then descriptor.multiplier (i) = cm; 9981 9982 if string (d -> dimension.v_bound (i)) = "00"b 9983 then do; 9984 descriptor.l_bound (i) = d -> dimension.lower_bound (i); 9985 descriptor.h_bound (i) = d -> dimension.upper_bound (i); 9986 if ^v_length 9987 then cm = cm * d -> dimension.size (i); 9988 end; 9989 else do; 9990 v_length = "1"b; 9991 9992 /* if no specific bounds are seen, fill in '*' bounds in the static descriptor. 9993* This requires variable descriptor math to over-write the bounds in auto 9994* when called. */ 9995 9996 if ^d -> dimension.v_bound (i).lower 9997 then descriptor.l_bound (i) = d -> dimension.lower_bound (i); 9998 else unspec (descriptor.l_bound (i)) = "400000000000"b3; 9999 /* '*' bound */ 10000 10001 if ^d -> dimension.v_bound (i).upper 10002 then descriptor.h_bound (i) = d -> dimension.upper_bound (i); 10003 else if (i = ndims) & d -> dimension.assumed_size 10004 then unspec (descriptor.h_bound (i)) = "377777777777"b3; 10005 else unspec (descriptor.h_bound (i)) = "400000000000"b3; 10006 /* '*' bound */ 10007 end; 10008 end; 10009 end; 10010 10011 /* Create a constant node for the descriptor */ 10012 10013 if ndims = 0 10014 then const = create_constant (int_mode, unspec (descriptor.type_word)); 10015 else const = create_char_constant (desc_image); 10016 10017 /* If the descriptor must be filled in at runtime, allocate a 10018* symbol node for it. */ 10019 10020 if v_length 10021 then do; 10022 desc = create_node (symbol_node, size (symbol)); 10023 d = addr (rands (desc)); 10024 d -> symbol.data_type = char_mode; 10025 d -> symbol.by_compiler = "1"b; 10026 d -> symbol.character = "1"b; 10027 d -> symbol.allocate = "1"b; 10028 d -> symbol.automatic = "1"b; 10029 d -> symbol.char_size = length (desc_image) - 1; 10030 d -> symbol.element_size = 1 + char_star_ndims + 3 * ndims; 10031 d -> symbol.general = const; 10032 10033 /* Thread in the new symbol, so its storage is allocated */ 10034 10035 cs = addr (rands (cur_subprogram)); 10036 addr (rands (cs -> subprogram.last_symbol)) -> node.next = desc; 10037 cs -> subprogram.last_symbol = desc; 10038 end; 10039 else desc = const; 10040 10041 /* Remember that we made this descriptor */ 10042 10043 p -> symbol.hash_chain = desc; 10044 10045 /* Return the descriptor node */ 10046 10047 return (desc); 10048 10049 end make_symbol_descriptor; 10050 10051 make_entry_descriptor: 10052 procedure (var) returns (fixed binary (18)); 10053 10054 dcl var fixed binary (18); /* Symbol that needs a descriptor */ 10055 10056 dcl (p, d) pointer; 10057 dcl (i, cm, dt, const, ndims, char_star_ndims, csize) fixed binary (18); 10058 dcl v_length bit (1) aligned; 10059 10060 dcl 1 descriptor aligned, 10061 2 type_word aligned, 10062 3 bit_type unaligned, 10063 4 flag bit (1) unaligned, 10064 4 type bit (6) unaligned, 10065 4 packed bit (1) unaligned, 10066 3 number_dims fixed binary (3) unaligned, 10067 3 size fixed binary (23) unaligned, 10068 2 array_info (7) aligned, 10069 3 l_bound fixed binary (18), 10070 3 h_bound fixed binary (18), 10071 3 multiplier fixed binary (18); 10072 10073 dcl desc_image character (chars_per_word * (1 + char_star_ndims + 3 * ndims)) unaligned based (addr (descriptor)); 10074 10075 10076 10077 p = addr (rands (var)); 10078 unspec (descriptor) = "0"b; 10079 v_length = "0"b; 10080 ndims, char_star_ndims = 0; 10081 10082 /* If the symbol already has a descriptor, return it. */ 10083 if p -> symbol.hash_chain ^= 0 10084 then do; 10085 d = addr (rands (p -> symbol.hash_chain)); 10086 10087 /* return only constant nodes */ 10088 if d -> node.node_type = symbol_node 10089 then d = addr (rands (d -> symbol.general)); 10090 10091 /* make sure the constant is allocated */ 10092 d -> node.allocate = "1"b; 10093 return (fixed (rel (d), 18)); 10094 end; 10095 10096 /* Initialize the descriptor's type word */ 10097 10098 if p -> symbol.operand_type >= bif 10099 then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7)); 10100 else do; 10101 dt = p -> symbol.data_type; 10102 unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt)); 10103 if dt = char_mode 10104 then do; 10105 if p -> symbol.units = char_units 10106 then descriptor.packed = "1"b; 10107 csize = get_char_size (p); 10108 if csize < 0 10109 then descriptor.size = csize + bias; 10110 else do; 10111 v_length = "1"b; 10112 unspec (descriptor.size) = "77777777"b3; 10113 end; 10114 end; 10115 end; 10116 10117 /* If symbol is dimensioned, add the dimension info */ 10118 /* If we would have to concoct runtime character*(*) lengths for a 10119* runtime symbol table, reserve space for the character multipliers. */ 10120 10121 if p -> symbol.dimensioned 10122 then do; 10123 d = addr (rands (p -> symbol.dimension)); 10124 ndims = d -> dimension.number_of_dims; 10125 descriptor.number_dims = ndims; 10126 10127 if v_length & shared_globals.user_options.table 10128 then char_star_ndims = ndims; /* count char*(*) multiplier extras */ 10129 10130 if descriptor.packed 10131 then cm = get_size_in_bits ((p -> symbol.element_size), (p -> symbol.units)); 10132 else cm = get_size_in_words ((p -> symbol.element_size), (p -> symbol.units)); 10133 10134 do i = 1 to ndims; 10135 10136 if ^v_length 10137 then descriptor.multiplier (i) = cm; 10138 10139 if string (d -> dimension.v_bound (i)) = "00"b 10140 then do; 10141 descriptor.l_bound (i) = d -> dimension.lower_bound (i); 10142 descriptor.h_bound (i) = d -> dimension.upper_bound (i); 10143 if ^v_length 10144 then cm = cm * d -> dimension.size (i); 10145 end; 10146 else do; 10147 v_length = "1"b; 10148 10149 /* if no specific bounds are seen, fill in '*' bounds in the static descriptor. 10150* This requires variable descriptor math to over-write the bounds in auto 10151* when called. */ 10152 10153 if ^d -> dimension.v_bound (i).lower 10154 then descriptor.l_bound (i) = d -> dimension.lower_bound (i); 10155 else unspec (descriptor.l_bound (i)) = "400000000000"b3; 10156 /* '*' bound */ 10157 10158 if ^d -> dimension.v_bound (i).upper 10159 then descriptor.h_bound (i) = d -> dimension.upper_bound (i); 10160 else if (i = ndims) & d -> dimension.assumed_size 10161 then unspec (descriptor.h_bound (i)) = "377777777777"b3; 10162 else unspec (descriptor.h_bound (i)) = "400000000000"b3; 10163 /* '*' bound */ 10164 end; 10165 end; 10166 end; 10167 10168 /* Create a constant node for the descriptor */ 10169 10170 if ndims = 0 10171 then const = create_constant (int_mode, unspec (descriptor.type_word)); 10172 else const = create_char_constant (desc_image); 10173 10174 /* Remember that we made this descriptor */ 10175 10176 p -> symbol.hash_chain = const; 10177 10178 /* Make sure the constant is allocated. */ 10179 10180 addr (rands (const)) -> node.allocate = "1"b; 10181 10182 /* Return the descriptor node */ 10183 10184 return (const); 10185 10186 end make_entry_descriptor; 10187 10188 /**** DATA INITIALIZATION ****/ 10189 10190 initialize_static: 10191 procedure (); 10192 10193 dcl (cur_subr, hdr) fixed binary (18); 10194 dcl (csp, h, s) pointer; 10195 10196 dcl base ptr; 10197 dcl full_pointer ptr based (base); 10198 dcl packed_pointer ptr unaligned based (base); 10199 10200 10201 do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0); 10202 csp = addr (rands (cur_subr)); 10203 10204 /* Do static Large Arrays - full null pointer. */ 10205 10206 do hdr = csp -> subprogram.storage_info.first (14) repeat h -> node.next while (hdr > 0); 10207 h = addr (rands (hdr)); 10208 base = addrel (link_base, h -> header.location); 10209 full_pointer = null (); 10210 end; 10211 10212 /* Do static Very Large Arrays - packed null pointer. */ 10213 10214 do hdr = csp -> subprogram.storage_info.first (16) repeat h -> node.next while (hdr > 0); 10215 h = addr (rands (hdr)); 10216 s = addr (rands (h -> header.VLA_base_addressor)); 10217 if ^s -> symbol.large_address 10218 then base = addrel (link_base, s -> symbol.address.offset); 10219 else base = addrel (link_base, s -> symbol.address.offset + s -> symbol.location); 10220 packed_pointer = null (); 10221 end; 10222 10223 /* Do Very Large Common - packed null pointer. */ 10224 10225 do hdr = csp -> subprogram.storage_info.first (17) repeat h -> node.next while (hdr > 0); 10226 h = addr (rands (hdr)); 10227 s = addr (rands (h -> header.VLA_base_addressor)); 10228 if ^s -> symbol.large_address 10229 then base = addrel (link_base, s -> symbol.address.offset); 10230 else base = addrel (link_base, s -> symbol.address.offset + s -> symbol.location); 10231 packed_pointer = null (); 10232 end; 10233 end; 10234 10235 10236 /* Initialize normal static. */ 10237 10238 do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0); 10239 csp = addr (rands (cur_subr)); 10240 call initialize (link_base, 5); 10241 end; 10242 10243 /* initialize long_profile_header */ 10244 10245 if generate_profile & generate_long_profile 10246 then do; 10247 base = addrel (link_base, profile_start); 10248 unspec (base -> long_profile_header) = "0"b; 10249 end; 10250 return; 10251 10252 10253 initialize_auto: 10254 entry (); 10255 10256 auto_template = text_pos; 10257 10258 do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0); 10259 csp = addr (rands (cur_subr)); 10260 call initialize (addrel (object_base, text_pos - first_auto_var_loc), 1); 10261 end; 10262 10263 text_pos = text_pos + (csp -> subprogram.next_loc (2) - first_auto_var_loc); 10264 10265 return; 10266 10267 initialize: 10268 procedure (pt, start); 10269 10270 dcl pt pointer, /* Base of section to place initialized vars */ 10271 start fixed binary (18); /* First bucket to initialize */ 10272 10273 dcl (base, h, s) pointer; 10274 dcl (sym, hdr, i) fixed binary (18); 10275 10276 base = pt; 10277 10278 do i = start to start + 1; 10279 do hdr = csp -> subprogram.storage_info.first (i) repeat h -> node.next while (hdr > 0); 10280 h = addr (rands (hdr)); 10281 if h -> node.node_type = header_node 10282 then do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 10283 s = addr (rands (sym)); 10284 if s -> symbol.initialed 10285 then call initialize_symbol (s, base); 10286 end; 10287 else call initialize_symbol (h, base); 10288 end; 10289 end; 10290 10291 end initialize; 10292 10293 end initialize_static; 10294 10295 list_initialize: 10296 procedure (pt, hdr, words); 10297 10298 dcl pt pointer, /* Base of section to place initialized vars */ 10299 /* left at last point of init */ 10300 hdr fixed binary (18), /* header to init from */ 10301 words fixed bin (18); /* words used for init info + original value */ 10302 10303 dcl (h, s) pointer; 10304 dcl sym fixed binary (18); 10305 dcl start_offset fixed bin (18); 10306 dcl end_offset fixed bin (35); 10307 10308 h = addr (rands (hdr)); 10309 if ^h -> header.initialed 10310 then return; /* No work to do */ 10311 end_offset = 0; 10312 start_offset = fixed (rel (pt), 18); 10313 10314 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 10315 s = addr (rands (sym)); 10316 10317 if s -> symbol.initialed 10318 then call list_initialize_symbol (s, pt, end_offset); 10319 end; 10320 pt -> create_init_entry.length = 0; /* END */ 10321 pt = addrel (pt, 1); 10322 10323 /* calculate words taken for initialization list data */ 10324 10325 words = words + fixed (rel (pt), 18) - start_offset; 10326 return; 10327 end list_initialize; 10328 10329 initialize_symbol: 10330 procedure (sym_pt, init_pt); 10331 10332 dcl (sym_pt, init_pt) pointer; 10333 10334 dcl (s, address) pointer; 10335 dcl (index, case, csize, limit, off) fixed binary (18); 10336 10337 dcl 1 initial aligned automatic, 10338 2 next fixed binary (18), 10339 2 limit fixed binary (18), 10340 2 value fixed binary (18); 10341 10342 dcl 1 initial_in_polish aligned based, 10343 2 next fixed binary (17) aligned, 10344 2 limit fixed binary (17) aligned, 10345 2 value fixed binary (17) aligned; 10346 10347 dcl single_target (10000) bit (36) aligned based (address); 10348 10349 dcl double_target (10000) bit (72) aligned based (address); 10350 10351 dcl char_target (10000) character (csize) aligned based (address); 10352 10353 dcl char77_target (10000) character (csize) unaligned based (address); 10354 10355 dcl char_overlay (0:3) character (1) unaligned based; 10356 10357 s = sym_pt; 10358 address = init_pt; 10359 index = 1; 10360 10361 /* Develop a full pointer to the initial template for the symbol */ 10362 10363 off = s -> symbol.address.offset; 10364 if s -> symbol.large_address 10365 then off = off + s -> symbol.location; 10366 10367 address = addrel (address, off); 10368 10369 if s -> symbol.units = char_units 10370 then do; 10371 off = s -> symbol.address.char_num; 10372 address = addr (address -> char_overlay (off)); 10373 end; 10374 10375 if s -> symbol.character 10376 then if s -> symbol.units = char_units 10377 then do; 10378 csize = s -> symbol.char_size + 1; 10379 case = 4; 10380 end; 10381 else do; 10382 csize = s -> symbol.char_size + 1; 10383 case = 3; 10384 end; 10385 else case = data_type_size (s -> symbol.data_type); 10386 10387 if ^s -> symbol.dimensioned 10388 then do; 10389 initial.value = addr (polish (s -> symbol.initial)) -> initial_in_polish.value; 10390 if initial.value ^= gap_value 10391 then call assign_value; 10392 return; 10393 end; 10394 10395 initial.next = s -> symbol.initial; 10396 limit = 0; 10397 10398 do while (initial.next > 0); 10399 10400 /* can't use aggregate assignment because of bug 1466 */ 10401 10402 initial.value = addr (polish (initial.next)) -> initial_in_polish.value; 10403 initial.limit = addr (polish (initial.next)) -> initial_in_polish.limit; 10404 initial.next = addr (polish (initial.next)) -> initial_in_polish.next; 10405 limit = limit + initial.limit; 10406 10407 do while (index <= limit); 10408 if initial.value ^= gap_value 10409 then call assign_value; 10410 index = index + 1; 10411 end; 10412 10413 end; 10414 10415 assign_value: 10416 procedure (); 10417 10418 go to action (case); 10419 10420 action (1): 10421 single_target (index) = addr (rands (initial.value)) -> constant.value; 10422 return; 10423 10424 action (2): 10425 double_target (index) = addr (rands (initial.value)) -> constant.value; 10426 return; 10427 10428 action (3): 10429 char_target (index) = addr (rands (initial.value)) -> char_constant.value; 10430 return; 10431 10432 action (4): 10433 char77_target (index) = addr (rands (initial.value)) -> char_constant.value; 10434 return; 10435 10436 end assign_value; 10437 10438 end initialize_symbol; 10439 10440 list_initialize_symbol: 10441 procedure (sym_pt, init_pt, end_offset); 10442 10443 dcl ( 10444 sym_pt, /* pointer to symbol */ 10445 init_pt 10446 ) pointer; /* pointer to template storage */ 10447 10448 dcl end_offset fixed bin (35); /* offset end of last stored */ 10449 10450 /* end_offset will be the last offset value assigned, and used as both input 10451* and output. The difference between the end_offset input and the first 10452* offset calculated will be a null filler. end_offset output will be the 10453* end of the area initialized to this point. */ 10454 10455 dcl boffset fixed bin (35); 10456 dcl s pointer; 10457 dcl (index, case, bsize, csize) fixed binary (18); 10458 dcl off fixed bin (35); 10459 10460 dcl 1 initial aligned automatic, 10461 2 next fixed binary (35), 10462 2 limit fixed binary (35), 10463 2 value fixed binary (35); 10464 10465 dcl 1 initial_in_polish aligned based, 10466 2 next fixed binary (35) aligned, 10467 2 limit fixed binary (35) aligned, 10468 2 value fixed binary (35) aligned; 10469 10470 dcl single_target (10000) bit (36) aligned based; 10471 10472 dcl double_target (10000) bit (72) aligned based; 10473 10474 dcl char_target (10000) character (csize) aligned based; 10475 10476 dcl char77_target (10000) character (csize) unaligned based; 10477 10478 10479 s = sym_pt; 10480 index = 1; 10481 10482 /* Develop an offset to the start of the variable area to be initialized */ 10483 10484 if s -> symbol.VLA 10485 then off = s -> symbol.location; 10486 else do; 10487 off = s -> symbol.address.offset; 10488 if s -> symbol.large_address 10489 then off = off + s -> symbol.location; 10490 end; 10491 10492 boffset = off * 36; 10493 10494 if s -> symbol.units = char_units 10495 then boffset = boffset + 9 * s -> symbol.address.char_num; 10496 10497 if s -> symbol.character 10498 then if s -> symbol.units = char_units 10499 then do; 10500 csize = s -> symbol.char_size + 1; 10501 case = 4; 10502 end; 10503 else do; 10504 csize = s -> symbol.char_size + 1; 10505 case = 3; 10506 end; 10507 else case = data_type_size (s -> symbol.data_type); 10508 10509 if ^s -> symbol.dimensioned 10510 then do; 10511 initial.value = addr (polish (s -> symbol.initial)) -> initial_in_polish.value; 10512 call list_assign_value (1); 10513 return; 10514 end; 10515 10516 initial.next = s -> symbol.initial; 10517 10518 do while (initial.next > 0); 10519 10520 /* can't use aggregate assignment because of bug 1466 */ 10521 10522 initial.value = addr (polish (initial.next)) -> initial_in_polish.value; 10523 initial.limit = addr (polish (initial.next)) -> initial_in_polish.limit; 10524 initial.next = addr (polish (initial.next)) -> initial_in_polish.next; 10525 call list_assign_value (initial.limit); 10526 index = index + initial.limit; 10527 10528 end; 10529 return; 10530 10531 list_assign_value: 10532 procedure (repeat); 10533 10534 dcl repeat fixed bin (35); 10535 10536 if initial.value = gap_value /* skip */ 10537 then return; 10538 10539 go to size_it (case); 10540 10541 size_it (1): /* single precision */ 10542 bsize = 36; 10543 off = (divide (boffset + bsize - 1, bsize, 35) + (index - 1)) * bsize; 10544 goto list_assign_create; 10545 10546 size_it (2): /* double precision */ 10547 bsize = 72; 10548 off = (divide (boffset + bsize - 1, bsize, 35) + (index - 1)) * bsize; 10549 goto list_assign_create; 10550 10551 size_it (3): /* ansi66 character aligned target */ 10552 bsize = divide (csize + 3, 4, 35) * 36; /* round up to word */ 10553 off = divide (boffset + 35, 36, 35) * 36 + (index - 1) * bsize; 10554 goto list_assign_create; 10555 10556 size_it (4): /* ansi77 character unaligned */ 10557 bsize = csize * 9; 10558 off = boffset + (index - 1) * bsize; 10559 goto list_assign_create; 10560 10561 10562 /* create the initialization entry at the specified pointer. */ 10563 10564 list_assign_create: 10565 if end_offset ^= off /* see if we formed a gap */ 10566 then do; /* filler */ 10567 init_pt -> create_init_entry.repeat = 0; /* skip */ 10568 init_pt -> create_init_entry.length = off - end_offset; 10569 init_pt = addrel (init_pt, 2); 10570 end; 10571 init_pt -> create_init_entry.length = bsize; 10572 init_pt -> create_init_entry.repeat = repeat; 10573 go to action (case); 10574 10575 action (1): 10576 addr (init_pt -> create_init_entry.datum) -> single_target (1) = addr (rands (initial.value)) -> constant.value; 10577 goto list_assign_finish; 10578 10579 action (2): 10580 addr (init_pt -> create_init_entry.datum) -> double_target (1) = addr (rands (initial.value)) -> constant.value; 10581 goto list_assign_finish; 10582 10583 action (3): 10584 addr (init_pt -> create_init_entry.datum) -> char_target (1) = 10585 addr (rands (initial.value)) -> char_constant.value; 10586 goto list_assign_finish; 10587 10588 action (4): 10589 addr (init_pt -> create_init_entry.datum) -> char77_target (1) = 10590 addr (rands (initial.value)) -> char_constant.value; 10591 goto list_assign_finish; 10592 10593 list_assign_finish: 10594 init_pt = addrel (init_pt, currentsize (init_pt -> create_init_entry)); 10595 end_offset = off + bsize * repeat; 10596 return; 10597 10598 end list_assign_value; 10599 10600 end list_initialize_symbol; 10601 10602 /**** LINKAGE SECTION GENERATION ****/ 10603 10604 init_linkage: 10605 procedure (); 10606 10607 /* This procedure is called to initialize the linkage generator. 10608* It builds the linkage_header and generates the class 3 10609* segname definition and the definition for "symbol_table". */ 10610 10611 dcl 1 def_header based aligned, 10612 2 forward bit (18) unaligned, 10613 2 backward bit (18) unaligned, 10614 2 skip bit (18) unaligned, 10615 2 flags bit (18) unaligned; 10616 24 1 /* BEGIN INCLUDE FILE segname_def.incl.pl1 */ 24 2 24 3 dcl 1 segname_def aligned based, 24 4 2 forward unal bit(18), /* offset of next def */ 24 5 2 backward unal bit(18), /* offset of previous def */ 24 6 2 next unal bit(18), /* offset of next segname def */ 24 7 2 flags unal, 24 8 3 new bit(1), 24 9 3 ignore bit(1), 24 10 3 entry bit(1), 24 11 3 retain bit(1), 24 12 3 descriptors bit(1), 24 13 3 unused bit(10), 24 14 2 class unal bit(3), 24 15 2 symbol unal bit(18), /* offset of ACC for symbol */ 24 16 2 defblock unal bit(18); /* offset of head of this defblock */ 24 17 24 18 /* END INCLUDE FILE segname_def.incl.pl1 */ 10617 10618 10619 /* initialize linkage header */ 10620 10621 link_base -> virgin_linkage_header.def_offset = bit (defrel, 18); 10622 link_base -> virgin_linkage_header.link_begin = bit (begin_links, 18); 10623 link_base -> virgin_linkage_header.linkage_section_lng = bit (link_pos, 18); 10624 link_base -> virgin_linkage_header.static_length = 10625 bit (fixed (begin_links - size (virgin_linkage_header), 18), 18); 10626 10627 link_reloc_base -> reloc (1) = rc_t; 10628 10629 /* generate definition header. the word of zeros terminating 10630* the definition chain will be at location 2 */ 10631 10632 def_base -> def_header.flags = "11"b; /* new,ignore */ 10633 def_reloc_base -> reloc (0) = rc_dp; 10634 zero_def = "000000000000000010"b; 10635 last_def = (18)"0"b; 10636 def_pos = 3; 10637 10638 /* generate definition for segname, class 3 */ 10639 10640 call generate_definition (segname, 3, zero_def); 10641 10642 /* generate definition for "symbol_table" */ 10643 10644 call generate_definition ("symbol_table", 2, "0"b); 10645 10646 addrel (def_base, seg_def) -> segname_def.defblock = last_def; 10647 10648 return; 10649 10650 end init_linkage; 10651 10652 gen_linkage: 10653 procedure (); 10654 10655 /* Generate the links for common and external references */ 10656 10657 dcl i fixed binary (18); 10658 dcl position fixed binary (15); 10659 dcl s pointer; 10660 10661 do i = begin_external_list to end_external_list - 1 by 3; 10662 s = ext_ref (i); 10663 if s -> node.allocated 10664 then if s -> node.node_type = symbol_node 10665 then if s -> symbol.initial = 0 10666 then do; 10667 position = s -> symbol.address.offset; 10668 if s -> symbol.large_address 10669 then position = position + s -> symbol.location; 10670 call compile_link (s -> symbol.name, "0"b, 0, position); 10671 end; 10672 else ; 10673 else do; 10674 10675 /* the following code is affected by PL/I bug 1599 */ 10676 /* This bug is fixed by release 23 of PL/I */ 10677 10678 if index (s -> header.block_name, "$") = 0 10679 then call compile_link (s -> header.block_name, initialize_common (s, (polish (i + 1))), 1, 10680 (s -> header.location)); 10681 else if ^s -> header.initialed 10682 then call compile_link (s -> header.block_name, "0"b, 1, (s -> header.location)); 10683 else call print_message (429, s -> header.block_name); 10684 end; 10685 end; 10686 10687 return; 10688 10689 end gen_linkage; 10690 10691 compile_link: 10692 procedure (string, grow, type, link_pos); 10693 10694 dcl string character (*) aligned, 10695 grow bit (18) aligned, 10696 type fixed binary (18), 10697 link_pos fixed binary (15); 10698 10699 dcl (seg_name, ent_name, block_type) bit (18) aligned; 10700 10701 dcl (def_ptr, link_ptr, def_reloc_ptr, link_reloc_ptr) pointer; 10702 dcl head_address fixed binary (35) based aligned; 10703 10704 dcl k fixed binary (18); 10705 10706 dcl dollar_name character (32) aligned; 10707 10708 dcl length builtin; 10709 10710 if length (string) = 0 10711 then do; 10712 10713 /* <*symbol>|0 link */ 10714 10715 block_type = "000001"b3; 10716 seg_name = "000002"b3; 10717 ent_name = "000000"b3; 10718 end; 10719 10720 else do; 10721 10722 /* ordinary link */ 10723 10724 if grow 10725 then block_type = "000005"b3; 10726 else block_type = "000004"b3; 10727 10728 k = index (string, "$"); 10729 10730 if k ^= 0 10731 then do; /* name of the form a$b */ 10732 10733 dollar_name = substr (string, 1, k - 1);/* get segment part of dollar name */ 10734 seg_name = name_assign (dollar_name); 10735 10736 /* different link required if common block name ends with $; it is illegal for */ 10737 /* external reference names to end with $. */ 10738 10739 if k = length (string) /* name ends with $ */ 10740 then do; 10741 ent_name = zero_def; /* there is no entry name */ 10742 block_type = "000003"b3; /* valid only for common block links */ 10743 end; 10744 else do; /* reference of the form a$b; get entry name */ 10745 dollar_name = substr (string, k + 1); 10746 ent_name = name_assign (dollar_name); 10747 end; 10748 end; 10749 10750 else do; /* no $ in name */ 10751 10752 ent_name = name_assign (string); 10753 10754 if type = 0 10755 then seg_name = ent_name; 10756 else seg_name = "000005"b3; 10757 end; 10758 end; 10759 10760 def_ptr = addrel (def_base, def_pos); 10761 def_reloc_ptr = addrel (def_reloc_base, def_pos); 10762 10763 link_ptr = addrel (link_base, link_pos); 10764 link_reloc_ptr = addrel (link_reloc_base, link_pos); 10765 10766 def_ptr -> type_pair.type = block_type; 10767 10768 def_ptr -> type_pair.trap_ptr = grow; 10769 if grow 10770 then def_reloc_ptr -> reloc (0) = rc_a_dp; 10771 10772 def_ptr -> type_pair.seg_ptr = seg_name; 10773 def_ptr -> type_pair.ext_ptr = ent_name; 10774 if type = 0 10775 then def_reloc_ptr -> reloc (1) = rc_a_dp; 10776 else def_reloc_ptr -> reloc (1) = rc_dp_dp; 10777 10778 addrel (def_ptr, 2) -> exp_word.type_ptr = bit (def_pos, 18); 10779 def_reloc_ptr -> reloc (2) = rc_dp; 10780 10781 link_ptr -> head_address = -link_pos * binary (262144, 19); 10782 link_ptr -> link.ft2 = FT2_mod; /* 46 octal */ 10783 link_reloc_ptr -> reloc (0) = rc_nlb; 10784 10785 link_ptr -> link.exp_ptr = bit (fixed (def_pos + 2, 18), 18); 10786 link_reloc_ptr -> reloc (1) = rc_dp; 10787 10788 def_pos = def_pos + 3; 10789 10790 return; 10791 10792 end compile_link; 10793 10794 name_assign: 10795 procedure (name) returns (bit (18) aligned); 10796 10797 dcl name character (*) aligned; 10798 dcl vname character (32) varying; 10799 10800 dcl 1 acc aligned based, 10801 2 count bit (9) unaligned, 10802 2 string character (n) unaligned; 10803 10804 dcl n fixed binary (9); 10805 dcl (i, old_pos) fixed binary (18); 10806 dcl p pointer; 10807 10808 dcl 1 st aligned based (polish_base), 10809 2 acc_ptrs (0:next_free_polish - 1) pointer unaligned; 10810 10811 dcl length builtin; 10812 10813 /* trim the blanks from name */ 10814 10815 vname = substr (name, 1, length (name) - verify (reverse (name), " ") + 1); 10816 10817 /* see if this acc string has already been used */ 10818 10819 do i = begin_forward_refs to hbound (acc_ptrs, 1); 10820 p = acc_ptrs (i); 10821 n = fixed (p -> acc.count, 9); 10822 if length (vname) = n 10823 then if vname = p -> acc.string 10824 then do; 10825 old_pos = fixed (rel (p), 18) - defrel; 10826 return (bit (old_pos, 18)); 10827 end; 10828 end; 10829 10830 /* build a new acc string */ 10831 10832 n = length (vname); 10833 p = addrel (def_base, def_pos); 10834 10835 if next_free_polish < polish_max_len 10836 then do; 10837 next_free_polish = next_free_polish + 1; 10838 acc_ptrs (next_free_polish - 1) = p; 10839 end; 10840 10841 p -> acc.count = bit (n, 9); 10842 p -> acc.string = vname; 10843 10844 old_pos = def_pos; 10845 def_pos = def_pos + divide (n + chars_per_word, chars_per_word, 17, 0); 10846 10847 return (bit (old_pos, 18)); 10848 10849 end name_assign; 10850 10851 initialize_common: 10852 procedure (pt, len) returns (bit (18) aligned); 10853 10854 dcl (h, s, pt, grow_pt, init_pt) pointer; 10855 dcl (len, init_val, sym) fixed binary (18); 10856 dcl ( 10857 m, /* length of LIST_TEMPLATE_INIT */ 10858 n /* length of TEMPLATE_INIT */ 10859 ) fixed bin (18); 10860 dcl grow_info bit (18) aligned; 10861 dcl use_pool bit (1) aligned; 10862 10863 dcl max_template_init_size fixed bin (18) static options (constant) init (256); 10864 25 1 /* Begin include file ... system_link_init_info.incl.pl1 ... 5/6/80 MRJ */ 25 2 25 3 25 4 25 5 /****^ HISTORY COMMENTS: 25 6* 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), 25 7* audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): 25 8* Modified to declare DEFERRED_INIT type constant. 25 9* 2) change(86-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-11-12,Zwick), 25 10* install(86-11-20,MR12.0-1222): 25 11* added the external pointer initialization structure and the constants 25 12* required to use them. 25 13* END HISTORY COMMENTS */ 25 14 25 15 25 16 /* Modified: 82-11-17 by T. Oke to add list_init_info and LIST_TEMPLATE_INIT. */ 25 17 25 18 /* format: style3,idind25 */ 25 19 25 20 /* NOTE -------------------------------------------------- 25 21* the following structures defining initialization information can also 25 22* be found in fortran_storage.incl.pl1 definition_dcls.incl.pl1 25 23* and should be kept equivalent 25 24* ------------------------------------------------------- 25 25**/ 25 26 25 27 dcl init_info_ptr ptr; /* ptr to structure below */ 25 28 dcl init_size fixed bin (35); /* size (in words) of initialization template */ 25 29 25 30 dcl 1 init_info aligned based (init_info_ptr), 25 31 2 size fixed bin (35), /* size (in words) of data */ 25 32 2 type fixed bin, /* type of initialization: see below */ 25 33 2 init_template (init_size refer (init_info.size)) fixed bin (35); 25 34 25 35 dcl 1 init_info_single_word aligned based (init_info_ptr), 25 36 /* for convenience of people like ssi */ 25 37 2 size fixed bin (19), /* = 1 */ 25 38 2 type fixed bin, /* = TEMPLATE_INIT */ 25 39 2 init_template (1) fixed bin (35); /* = value */ 25 40 25 41 dcl 1 list_init_info aligned based, 25 42 2 size fixed bin (35), /* length of variable */ 25 43 2 type fixed bin, /* LIST_TEMPLATE_INIT */ 25 44 2 pad bit (18) unaligned, 25 45 2 list_size fixed bin (18) unsigned unaligned, 25 46 /* size in words of template */ 25 47 2 template (0 refer (list_init_info.list_size)) bit (36); 25 48 /* first create_entry position */ 25 49 25 50 /* A list template consists of a series of entries with the following 25 51* description, concatenated together. n_bits and datum are bit items, 25 52* to permit a wide range of inputs. 25 53* 25 54* 1. A 'repeat' of '0' signifies skipping of 'n_bits' bits. 25 55* 2. A 'n_bits' of '0' signifies the last item of the list. 25 56* 25 57* COMMON, VLA's, and LA's are presumed to start at the base pointer 25 58* of their particular storage section. */ 25 59 25 60 dcl 1 list_template_entry aligned based, 25 61 2 n_bits fixed bin (35) aligned, /* size of datum */ 25 62 2 mbz bit (3) unaligned, /* future expansion */ 25 63 2 init_type fixed bin (3) unsigned unaligned, /* 0 normal init, 1 ptr init, 2 packed ptr init */ 25 64 2 repeat fixed bin (30) unsigned unaligned, 25 65 /* number of times to repeat datum */ 25 66 2 datum bit (init_n_bits_in_datum refer (list_template_entry.n_bits)); 25 67 25 68 /* list_template_entry_ptr is defined such that it can be used as an 25 69* automatic definition overlay with a fixed size datum. it has a declared 25 70* size of 72 to allow for the its pointer sixe of 72 bits. 25 71**/ 25 72 25 73 dcl 1 list_template_entry_ptr aligned based, 25 74 2 n_bits fixed bin (35) aligned, 25 75 2 mbz bit(3) unaligned, 25 76 2 init_type fixed bin (3) unsigned unaligned, 25 77 2 repeat fixed bin (30) unsigned unaligned, 25 78 2 datum bit(72); 25 79 25 80 /* the pointer_init_template represents the initialization information 25 81* for ITS and packed pointers. Both pointer types require the entire 25 82* 72 bit structure. 25 83**/ 25 84 25 85 dcl 1 pointer_init_template based, 25 86 2 ptr_type fixed bin (18) unsigned unaligned, /* 0 text section, 1 linkage section, 2 static section */ 25 87 2 section_offset fixed bin (18) unsigned unaligned, /* offset to item in specified section */ 25 88 2 word_offset fixed bin (18) unsigned unaligned, /* word offset from section item to target */ 25 89 2 mbz bit (12) unaligned, 25 90 2 bit_offset fixed bin (6) unsigned unaligned; /* bit offset from section item|word offset to target */ 25 91 25 92 25 93 dcl init_n_bits_in_datum fixed bin (35); 25 94 25 95 dcl NO_INIT fixed bin static options (constant) init (0); 25 96 dcl TEMPLATE_INIT fixed bin static options (constant) init (3); 25 97 dcl EMPTY_AREA_INIT fixed bin static options (constant) init (4); 25 98 dcl LIST_TEMPLATE_INIT fixed bin static options (constant) init (5); 25 99 dcl INIT_DEFERRED fixed bin static options (constant) init (6); 25 100 dcl ITS_PTR_INIT fixed bin (3) unsigned static options (constant) init(1); 25 101 dcl PACKED_PTR_INIT fixed bin (3) unsigned static options (constant) init(2); 25 102 dcl PTR_INIT_TEXT fixed bin (17) static options (constant) init(0); 25 103 dcl PTR_INIT_LOT fixed bin (17) static options (constant) init(1); 25 104 dcl PTR_INIT_ISOT fixed bin (17) static options (constant) init(2); 25 105 25 106 25 107 /* End include file ... system_link_init_info.incl.pl1 */ 10865 10866 10867 10868 10869 h = pt; 10870 n = len; 10871 10872 if h -> header.alignment.character 10873 then n = divide (n + chars_per_word - 1, chars_per_word, 18, 0); 10874 10875 if h -> header.initialed & n <= max_template_init_size 10876 then if fixed (rel (addrel (def_base, def_pos + n + mod (def_pos, 2)))) > max_linkage_size 10877 then do; /* CANNOT INIT ON PAIN OF DEATH */ 10878 call print_message (469, h -> header.block_name, max_linkage_size - bias); 10879 h -> header.initialed = "0"b; /* PULL OUT THE RUG */ 10880 end; 10881 10882 10883 if h -> header.initialed 10884 then def_pos = def_pos + mod (def_pos, 2); 10885 10886 grow_info = bit (def_pos, 18); 10887 grow_pt = addrel (def_base, grow_info); 10888 init_pt = addrel (grow_pt, 2); 10889 10890 init_val = NO_INIT; 10891 10892 if h -> header.initialed 10893 then if n > max_template_init_size 10894 then do; 10895 m = 0; /* presume no template generated */ 10896 init_val = LIST_TEMPLATE_INIT; 10897 call list_initialize (addrel (init_pt, 1), fixed (rel (h), 18), m); 10898 grow_pt -> list_init_info.list_size = m; 10899 end; 10900 else do; 10901 init_val = TEMPLATE_INIT; 10902 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 10903 s = addr (rands (sym)); 10904 if s -> symbol.initial ^= 0 10905 then call initialize_symbol (s, init_pt); 10906 end; 10907 end; 10908 10909 use_pool = init_val = NO_INIT & n <= hbound (def_pool, 1); 10910 if use_pool 10911 then if def_pool (n) ^= 0 10912 then return (bit (def_pool (n), 18)); 10913 10914 grow_pt -> init_info.size = n; 10915 grow_pt -> init_info.type = init_val; 10916 10917 if use_pool 10918 then def_pool (n) = def_pos; 10919 10920 def_pos = def_pos + 2; 10921 if init_val = TEMPLATE_INIT 10922 then def_pos = def_pos + n; 10923 else if init_val = LIST_TEMPLATE_INIT 10924 then def_pos = def_pos + m + 1; 10925 return (grow_info); 10926 10927 end initialize_common; 10928 10929 /**** DEFINITION SECTION ****/ 10930 10931 generate_definition: 10932 procedure (name, class, value); 10933 10934 dcl name character (*) aligned, /* Symbol for definition */ 10935 class fixed binary (3), /* Class of definition */ 10936 value bit (18) aligned; /* Value of definition */ 10937 10938 dcl (def_ptr, def_reloc_ptr) pointer; 10939 dcl (b18, pos) bit (18) aligned; 10940 10941 dcl rel_code (0:3) aligned bit (18) internal static options (constant) initial ("000000000000010000"b, 10942 /* Text */ 10943 "000000000000010010"b, /* Link 18 */ 10944 "000000000000010110"b, /* Symbol */ 10945 "000000000000010101"b); /* Definition */ 10946 26 1 /* BEGIN INCLUDE FILE definition.incl.pl1 */ 26 2 26 3 26 4 26 5 /****^ HISTORY COMMENTS: 26 6* 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), 26 7* audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): 26 8* Modified to add indirect bit to definition flags. 26 9* END HISTORY COMMENTS */ 26 10 26 11 26 12 dcl 1 definition aligned based, 26 13 2 forward unal bit(18), /* offset of next def */ 26 14 2 backward unal bit(18), /* offset of previous def */ 26 15 2 value unal bit(18), 26 16 2 flags unal, 26 17 3 new bit(1), 26 18 3 ignore bit(1), 26 19 3 entry bit(1), 26 20 3 retain bit(1), 26 21 3 argcount bit(1), 26 22 3 descriptors bit(1), 26 23 3 indirect bit(1), 26 24 3 unused bit(8), 26 25 2 class unal bit(3), 26 26 2 symbol unal bit(18), /* offset of ACC for symbol */ 26 27 2 segname unal bit(18); /* offset of segname def */ 26 28 26 29 /* END INCLUDE FILE definition.incl.pl1 */ 10947 10948 10949 b18 = name_assign (name); 10950 10951 pos = bit (def_pos, 18); 10952 def_ptr = addrel (def_base, pos); 10953 def_reloc_ptr = addrel (def_reloc_base, pos); 10954 10955 if last_def 10956 then def_ptr -> definition.backward = last_def; 10957 else def_ptr -> definition.backward = zero_def; 10958 10959 addrel (def_base, last_def) -> definition.forward = pos; 10960 10961 def_ptr -> definition.forward = zero_def; 10962 10963 def_ptr -> definition.new = "1"b; 10964 def_ptr -> definition.symbol = b18; 10965 def_ptr -> definition.value = value; 10966 10967 def_ptr -> definition.class = bit (class, 3); 10968 10969 if class = 3 10970 then seg_def = pos; 10971 else do; 10972 def_ptr -> definition.segname = seg_def; 10973 def_ptr -> definition.entry = class = 0; 10974 end; 10975 10976 def_reloc_ptr -> reloc (0) = rc_dp_dp; 10977 def_reloc_ptr -> reloc (2) = rc_dp_dp; 10978 def_reloc_ptr -> reloc (1) = rel_code (class); 10979 10980 last_def = pos; 10981 def_pos = def_pos + 3; 10982 10983 end generate_definition; 10984 10985 gen_entry_defs: 10986 procedure (); 10987 10988 /* Generates entry definitions and finishes up entry sequences */ 10989 10990 dcl desc fixed bin (18); 10991 dcl (s, def_ptr) pointer; 10992 dcl (sym, stack_size) fixed binary (18); 10993 dcl text_pos fixed binary (18); 10994 27 1 /* BEGIN INCLUDE FILE definition.incl.pl1 */ 27 2 27 3 27 4 27 5 /****^ HISTORY COMMENTS: 27 6* 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), 27 7* audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): 27 8* Modified to add indirect bit to definition flags. 27 9* END HISTORY COMMENTS */ 27 10 27 11 27 12 dcl 1 definition aligned based, 27 13 2 forward unal bit(18), /* offset of next def */ 27 14 2 backward unal bit(18), /* offset of previous def */ 27 15 2 value unal bit(18), 27 16 2 flags unal, 27 17 3 new bit(1), 27 18 3 ignore bit(1), 27 19 3 entry bit(1), 27 20 3 retain bit(1), 27 21 3 argcount bit(1), 27 22 3 descriptors bit(1), 27 23 3 indirect bit(1), 27 24 3 unused bit(8), 27 25 2 class unal bit(3), 27 26 2 symbol unal bit(18), /* offset of ACC for symbol */ 27 27 2 segname unal bit(18); /* offset of segname def */ 27 28 27 29 /* END INCLUDE FILE definition.incl.pl1 */ 10995 10996 10997 stack_size = divide (last_auto_loc + 15, 16, 17, 0) * 16; 10998 10999 do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0); 11000 s = addr (rands (sym)); 11001 text_pos = s -> label.location; /* a slight kludge */ 11002 11003 /* fill in stack_size (must be multiple of 16) */ 11004 11005 text_halfs (text_pos).left = stack_size; 11006 11007 /* generate entry definition */ 11008 11009 call generate_definition (s -> symbol.name, 0, bit (text_pos, 18)); 11010 11011 reloc_halfs (text_pos - 1).left = rc_dp; 11012 11013 unspec (text_halfs (text_pos - 1).left) = last_def; 11014 def_ptr = addrel (def_base, last_def); 11015 11016 if assembly_list 11017 then a_name (text_pos - 1) = -1; /* tell listing generator this is not an inst */ 11018 11019 def_ptr -> definition.retain = "1"b; 11020 11021 /* process entry definitions */ 11022 11023 parm_desc_ptrsp = addr (text_halfs (text_halfs (text_pos - 2).left)); 11024 do i = 1 to parm_desc_ptrs.n_args; 11025 desc = parm_desc_ptrs.descriptor_relp (i); 11026 parm_desc_ptrs.descriptor_relp (i) = addr (rands (desc)) -> label.location; 11027 end; 11028 end; 11029 end gen_entry_defs; 11030 11031 effective_operand: 11032 proc (opnd) returns (fixed bin (18)); 11033 11034 /* Function to replace an operand by its effective value. */ 11035 11036 dcl opnd fixed bin (18); /* incoming operand */ 11037 11038 dcl op fixed bin (18); /* outgoing operand */ 11039 dcl p ptr; /* pointer to symbol */ 11040 11041 op = opnd; 11042 if op > 0 11043 then do; 11044 p = addr (rands (op)); 11045 if p -> node.node_type = label_node 11046 then if p -> label.format 11047 then do; 11048 op = p -> label.format_var; 11049 p = addr (rands (op)); 11050 end; 11051 if p -> node.node_type = symbol_node 11052 then if p -> symbol.named_constant 11053 then op = p -> symbol.initial; 11054 end; 11055 return (op); 11056 end effective_operand; 11057 end code_generator; 11058 11059 end ext_code_generator; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 12/11/91 2230.0 ext_code_generator.pl1 >spec>install>1004>ext_code_generator.pl1 47 1 11/10/88 1450.9 fort_nodes.incl.pl1 >ldd>incl>fort_nodes.incl.pl1 49 2 03/27/82 0439.3 fort_listing_nodes.incl.pl1 >ldd>incl>fort_listing_nodes.incl.pl1 51 3 08/04/86 2015.0 fort_system_constants.incl.pl1 >ldd>incl>fort_system_constants.incl.pl1 54 4 08/04/86 2015.0 fort_shared_vars.incl.pl1 >ldd>incl>fort_shared_vars.incl.pl1 56 5 08/06/87 1153.7 fort_options.incl.pl1 >ldd>incl>fort_options.incl.pl1 59 6 03/27/82 0439.4 fort_cg_vars.incl.pl1 >ldd>incl>fort_cg_vars.incl.pl1 62 7 03/27/82 0437.1 fort_symtab_parms.incl.pl1 >ldd>incl>fort_symtab_parms.incl.pl1 63 8 03/10/77 1345.4 long_profile.incl.pl1 >ldd>incl>long_profile.incl.pl1 83 9 03/27/82 0437.1 fort_utilities.incl.pl1 >ldd>incl>fort_utilities.incl.pl1 9-11 10 03/27/82 0437.8 fort_create_node.incl.pl1 >ldd>incl>fort_create_node.incl.pl1 9-37 11 10/30/80 1648.7 relocation_bits.incl.pl1 >ldd>incl>relocation_bits.incl.pl1 573 12 07/27/83 0910.0 linkdcl.incl.pl1 >ldd>incl>linkdcl.incl.pl1 574 13 08/05/77 1022.5 object_map.incl.pl1 >ldd>incl>object_map.incl.pl1 575 14 10/30/80 1648.7 relbts.incl.pl1 >ldd>incl>relbts.incl.pl1 576 15 10/30/80 1648.7 reloc_lower.incl.pl1 >ldd>incl>reloc_lower.incl.pl1 577 16 11/26/79 1320.6 its.incl.pl1 >ldd>incl>its.incl.pl1 578 17 10/30/80 1648.7 profile_entry.incl.pl1 >ldd>incl>profile_entry.incl.pl1 579 18 10/12/83 1515.6 fortran_storage.incl.pl1 >ldd>incl>fortran_storage.incl.pl1 580 19 10/26/88 1255.5 std_descriptor_types.incl.pl1 >ldd>incl>std_descriptor_types.incl.pl1 945 20 10/30/80 1648.7 relocation_bits.incl.pl1 >ldd>incl>relocation_bits.incl.pl1 2310 21 10/30/80 1648.7 relocation_bits.incl.pl1 >ldd>incl>relocation_bits.incl.pl1 2397 22 12/21/84 1237.8 fort_single_inst_names.incl.pl1 >ldd>incl>fort_single_inst_names.incl.pl1 2617 23 10/30/80 1648.7 relocation_bits.incl.pl1 >ldd>incl>relocation_bits.incl.pl1 10617 24 10/30/80 1648.7 segname_def.incl.pl1 >ldd>incl>segname_def.incl.pl1 10865 25 11/24/86 1226.9 system_link_init_info.incl.pl1 >ldd>incl>system_link_init_info.incl.pl1 10947 26 11/24/86 1226.9 definition.incl.pl1 >ldd>incl>definition.incl.pl1 10995 27 11/24/86 1226.9 definition.incl.pl1 >ldd>incl>definition.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. A 000374 constant fixed bin(18,0) initial dcl 2405 set ref 7049* 7087 7090 7094 7304 7305 7306 7323 7325 7325 7356* 7412 7425 7495* 9656* 9669* AL_mod 000604 constant bit(6) initial dcl 538 set ref 6169 7049 7080 7111 9655* 9661* 9666* 9668* AU_mod constant bit(6) initial dcl 538 ref 6171 Area_create_first 3144 based fixed bin(18,0) level 2 dcl 53 set ref 967* 2047 2048 2128 2128* 4134 4163 4170 Area_create_last 3145 based fixed bin(18,0) level 2 dcl 53 set ref 2134 2139* Area_init_first 3146 based fixed bin(18,0) level 2 dcl 53 set ref 967* 4174 4180 DL_mod 000605 constant bit(6) initial dcl 538 set ref 5235 5319 5365 5398 9774* 9790* 9806* DU_mod 056071 constant bit(6) initial dcl 538 ref 5331 5871 EAQ 000734 constant fixed bin(18,0) initial dcl 2405 set ref 3507* 6927* 7331 7332 7343 7345 7346 7490* 7493 ERROR 000721 constant fixed bin(18,0) initial dcl 2380 set ref 2635 2649 2952 2959* 3649* FT2_mod constant bit(6) initial dcl 538 ref 10782 IND 000730 constant fixed bin(18,0) initial dcl 2405 set ref 3140 3143 3154 3154 3406 3509* 6926* 7094 7175 7242 7294 7294 7298 7302 7303* 7384 7409 7421 7490 ITP_mod constant bit(6) initial dcl 538 ref 827 9324 K256 0(23) based bit(1) level 3 packed packed unaligned dcl 18-23 set ref 2115* LA 2(04) based bit(1) level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 2113 LA 4(01) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 5693 LA 0(21) based bit(1) level 3 in structure "create_entry" packed packed unaligned dcl 18-23 in procedure "code_generator" set ref 2113* LA_chain 57(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1015 LIST_TEMPLATE_INIT constant fixed bin(17,0) initial dcl 25-98 ref 10896 10923 NO_INIT constant fixed bin(17,0) initial dcl 25-95 ref 10890 10909 Q 000352 constant fixed bin(18,0) initial dcl 2405 set ref 3846* 7047* 7087 7092 7094 7252 7496* 8006* 8554* 8739* 8778* 9200* 9293* 9644* 9671* 9762* QL_mod constant bit(6) initial dcl 538 ref 5813 6163 7047 7070 7078 7109 8684 QU_mod constant bit(6) initial dcl 538 ref 6165 RHS 004305 automatic fixed bin(35,0) dcl 9686 set ref 9749* 9751* 9751* RI_mod constant bit(6) initial dcl 538 ref 1026 1370 1405 1494 9331 TEMPLATE_INIT constant fixed bin(17,0) initial dcl 25-96 ref 10901 10921 VLA 0(22) based bit(1) level 3 in structure "create_entry" packed packed unaligned dcl 18-23 in procedure "code_generator" set ref 2114* VLA 1(06) based bit(1) array level 4 in structure "arg_desc" packed packed unaligned dcl 1-130 in procedure "ext_code_generator" set ref 9398* 9442 9510* VLA 4 based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1302 1367 3753 3919 4145 5619 5671 5688 6031 6033 6244 6246 7881 7903 9331 9398 9442 9510 10484 VLA 003175 automatic bit(1) packed unaligned dcl 6234 in procedure "base_man_load_pr" set ref 6244* 6246* 6248* 6250 6283 VLA 2(03) based bit(1) level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1794 2114 VLA 000103 automatic bit(1) packed unaligned dcl 5989 in procedure "base_man_load_any_pr" set ref 6031* 6033* 6035* 6049 VLA_base_addressor 7 based fixed bin(18,0) level 2 in structure "header" dcl 1-436 in procedure "ext_code_generator" ref 1102 1989 1989 1995 1995 10216 10227 VLA_base_addressor 4 based fixed bin(18,0) level 2 in structure "dimension" dcl 1-383 in procedure "ext_code_generator" ref 1306 3761 8004 VLA_chain 57 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1083 VLA_is_256K 115(03) based bit(1) level 4 packed packed unaligned dcl 53 ref 1313 1797 1999 2115 3763 7937 VLA_words_per_seg constant fixed bin(14,0) initial dcl 2433 ref 3776 7940 X0_mod constant bit(6) initial dcl 538 set ref 9772* 9775* 9788* 9792* 9803* 9808* X1_mod 000603 constant bit(6) initial dcl 538 set ref 9804* 9807* a 004160 automatic pointer dcl 9359 in procedure "check_arg_list" set ref 9388* 9389 9393 9397 9398 9401 9402 9411* 9413 9416 9416 9430 9430 9440 9442 9446 9449 a 003764 automatic pointer dcl 8821 in procedure "create_array_ref" set ref 8826* 8830* 8831 8832 8833 8837 8839 8840 8841 8847 8848 8850 8852 8853 8854 8855 a 003566 automatic pointer dcl 7756 in procedure "finish_subscript" set ref 7889* 7890 7896 7897 7898 7909 7950 7954 7954 7956* 7962 7962 7964 8236* 8238 8239 8240 8244 8245 8251 8251 8260* 8261 8261 8264 8265 8269 8668 8669 8683 8684 8688 8696 8697 8699 a9bd 000512 constant fixed bin(18,0) initial dcl 22-16 set ref 6302* 6311* 6313* 6321* 6330* a_base 000212 automatic pointer dcl 438 set ref 593* 595* 1816 2025 3333 3342 3750 3766 3779 3789 3803 3818 3887 3916 3965 4157 4184 5148 5151 5255 5258 5502 5505 6130 11016 a_data_type 000100 automatic fixed bin(4,0) dcl 9-15 set ref 9-40* 9-43 9-43 9-43 9-45 9-45 9-47 9-65 9-81 a_name based fixed bin(18,0) array dcl 476 set ref 1816* 2025* 3333* 3342* 3750* 3766* 3779* 3789* 3803* 3818* 3887* 3916* 3965* 4157* 4184* 5148* 5151* 5255* 5258* 5502* 5505* 6130* 11016* a_ref 003762 automatic fixed bin(18,0) dcl 8820 in procedure "create_array_ref" set ref 8825* 8826 8829* 8830 8857 a_ref 004002 automatic fixed bin(18,0) dcl 8868 in procedure "free_array_ref" set ref 8871* 8875* 8901* 8902* 8905 a_ref 003601 automatic fixed bin(18,0) dcl 7758 in procedure "finish_subscript" set ref 7888* 7889 7969* 8235* 8236 8271* a_value 000102 automatic bit(72) dcl 9-16 set ref 9-41* 9-51 9-52 9-54 9-54 9-65 9-85 abs builtin function dcl 569 ref 865 acc based structure level 1 dcl 10800 acc_ptrs based pointer array level 2 packed packed unaligned dcl 10808 set ref 10819 10820 10838* actual_length parameter fixed bin(18,0) dcl 9039 set ref 9029 9054* 9068* 9081* 9088* add_base 000457 constant fixed bin(18,0) initial array dcl 22-16 ref 6085 6435 6463 addr builtin function dcl 9-18 in procedure "create_constant" ref 9-51 9-52 9-54 9-54 9-63 9-80 9-91 addr builtin function dcl 10-17 in procedure "create_node" ref 10-24 10-25 addr builtin function dcl 569 in procedure "code_generator" ref 593 632 652 653 706 706 771 776 795 978 994 1004 1017 1056 1067 1085 1102 1142 1157 1172 1187 1235 1246 1258 1290 1306 1307 1394 1470 1488 1507 1525 1538 1592 1598 1604 1610 1636 1756 1796 1812 1916 1989 1989 1995 1995 2024 2136 2160 2167 2173 2203 2207 2226 2287 2293 2313 2622 2637 2640 2643 2660 2666 2671 2679 2683 2690 2707 2708 2807 2807 2822 2824 2842 3016 3035 3053 3061 3070 3091 3101 3103 3125 3128 3137 3143 3166 3178 3178 3189 3253 3272 3283 3309 3333 3342 3373 3373 3378 3378 3406 3406 3416 3416 3425 3425 3425 3425 3478 3548 3582 3587 3594 3610 3611 3665 3665 3669 3705 3708 3738 3748 3761 3762 3799 3812 3828 3841 3843 3887 3910 3914 3932 3932 3934 3944 3948 3948 3951 3959 3965 3978 3985 4016 4022 4025 4028 4035 4038 4041 4045 4049 4056 4112 4119 4145 4145 4278 4399 4420 4566 4644 4645 4646 4650 4651 4673 4685 4687 4689 4689 4694 4705 4727 4728 4729 4776 4822 4891 4898 4921 4926 4926 4927 4950 4950 4955 4975 5004 5158 5183 5242 5300 5305 5342 5384 5449 5513 5556 5556 5556 5558 5558 5600 5609 5662 5698 5703 5727 6030 6033 6051 6051 6118 6121 6122 6163 6165 6169 6171 6196 6240 6246 6361 6719 6953 6957 6959 6978 7021 7125 7173 7194 7204 7234 7234 7234 7234 7234 7234 7234 7234 7249 7294 7307 7325 7332 7387 7421 7465 7468 7517 7539 7582 7690 7691 7692 7762 7763 7806 7889 8002 8003 8004 8031 8032 8033 8038 8045 8056 8057 8137 8141 8141 8141 8228 8236 8276 8303 8307 8316 8411 8659 8663 8700 8792 8793 8808 8826 8830 8838 8881 8892 8977 8978 9007 9007 9009 9009 9023 9046 9065 9065 9106 9163 9174 9195 9218 9250 9298 9334 9362 9370 9371 9388 9392 9411 9421 9430 9479 9480 9482 9496 9504 9543 9582 9588 9602 9605 9605 9614 9617 9617 9692 9698 9718 9721 9721 9727 9730 9730 9747 9749 9822 9829 9829 9831 9844 9845 9929 9966 10015 10023 10029 10035 10036 10077 10085 10088 10123 10172 10180 10202 10207 10215 10216 10226 10227 10239 10259 10280 10283 10308 10315 10372 10389 10402 10403 10404 10420 10424 10428 10432 10511 10522 10523 10524 10575 10575 10579 10579 10583 10583 10588 10588 10903 11000 11023 11026 11044 11049 addr_hold 2(18) based bit(18) level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 5638* 6212 addr_hold 2(18) based bit(18) level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 2010* 6142 addr_hold 2(18) based bit(18) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4870 4982* 5676 6571 addrel builtin function dcl 569 ref 644 645 664 665 672 673 713 733 776 806 825 1060 1060 1134 1134 2050 2100 2134 7651 10208 10217 10219 10228 10230 10247 10260 10260 10321 10367 10569 10593 10646 10760 10761 10763 10764 10778 10833 10875 10887 10888 10897 10897 10952 10953 10959 11014 address 1 based structure level 2 in structure "temporary" dcl 1-1005 in procedure "ext_code_generator" set ref 4783* 4870* 4982 4985* 5188 5188 8984 9023* address 000111 automatic bit(36) dcl 5993 in procedure "base_man_load_any_pr" set ref 6021* 6022* 6025* 6056* 6057* 6059* 6063* 6068* 6081* address 000110 automatic bit(36) dcl 6103 in procedure "base_man_load_VLA" set ref 6149* 6151* 6153* 6160* 6163 6164* 6165 6166* 6169 6170* 6171 6172* 6176* address 1 based structure level 2 in structure "symbol" dcl 1-844 in procedure "ext_code_generator" set ref 1105* 1263* 1310* 1758* 2010 5731* 5731 6142 8853 address 1 based structure level 2 in structure "char_constant" dcl 1-316 in procedure "ext_code_generator" address 1 based structure level 2 in structure "label" dcl 1-530 in procedure "ext_code_generator" address parameter bit(36) dcl 5120 in procedure "emit_c_a" ref 5114 5122 address parameter fixed bin(18,0) dcl 5089 in procedure "emit_with_tag" ref 5084 5097 address 1 based structure level 2 in structure "node" dcl 1-63 in procedure "ext_code_generator" set ref 5153 5153 5161 5251 5260 5487 5494 5516 5638 6212 9334 address 1 based structure level 2 in structure "header" dcl 1-436 in procedure "ext_code_generator" set ref 1021* 1090* 1105 1161* 1213* 1758 address 004454 automatic pointer dcl 10334 in procedure "initialize_symbol" set ref 10358* 10367* 10367 10372* 10372 10420 10424 10428 10432 address 003245 automatic bit(36) dcl 6805 in procedure "xr_man_add_const" set ref 6810* 6811* 6812* 6819* address 1 based structure level 2 in structure "constant" dcl 1-256 in procedure "ext_code_generator" address 1 based structure level 2 in structure "array_ref" dcl 1-155 in procedure "ext_code_generator" set ref 8853* address_in_base 107 001334 automatic bit(1) level 2 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 5012* 6037* 6921 address_in_base 0(21) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 5013* address_in_base 0(21) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 5592 6036* 6197* 7023 7030* addressing_bits 0(14) based structure level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1767* addressing_bits 0(14) based structure level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" addressing_bits 0(14) based structure level 2 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" addressing_bits 0(14) based structure level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" addressing_bits 0(14) based structure level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" addressing_bits 0(14) based structure level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1767 addressing_bits 0(14) based structure level 2 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" addressing_bits 0(14) based structure level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4779* adesc 004156 automatic fixed bin(18,0) dcl 9358 set ref 9387* 9388 adfx1 000523 constant fixed bin(18,0) initial dcl 22-16 set ref 3833 8005* 8720 9127* adq constant bit(10) initial dcl 5286 ref 5351 5354 aliasable 2(03) based bit(1) level 2 packed packed unaligned dcl 1-844 set ref 9546 alignment 0(30) based structure level 3 packed packed unaligned dcl 1-436 alloc_auto_adj constant fixed bin(14,0) initial dcl 2433 ref 3836 alloc_auto_cleanup 000147 automatic bit(1) dcl 424 set ref 969* 1535 2125* 4152 alloc_length parameter fixed bin(18,0) dcl 9040 set ref 9029 9055* 9069* 9082* 9089* alloc_ps 000135 automatic bit(1) dcl 943 set ref 969* 999* 999 1504 allocate 0(25) based bit(1) level 4 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4781* allocate 0(25) based bit(1) level 5 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1018 1086 1158 1188 allocate 0(25) based bit(1) level 4 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" ref 772 allocate 0(25) based bit(1) level 4 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 1258* 5373* 10092* 10180* allocate 0(25) based bit(1) level 4 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" ref 796 allocate 0(25) based bit(1) level 5 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1257* 1261 1491* 1510* 1541* 2289* 3813 10027* allocate_char_string constant fixed bin(14,0) initial dcl 2433 ref 8956 allocate_symbol_name 000121 automatic fixed bin(17,0) dcl 1-525 set ref 585* 1487 1487 1506 1506 1524 1524 1537 1537 2286 2286 2682 2682 2689 2689 4761 10022 10022 allocated 0(17) based bit(1) level 3 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" set ref 796 810* 2663* allocated 0(17) based bit(1) level 3 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" set ref 772 778* allocated 0(17) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" ref 3922 5375 10663 allocated 0(17) based bit(1) level 3 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" set ref 7585* allocated 0(17) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2674* allocated 0(17) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4781* allocated 0(17) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1104* 1247 1309* 1461* 1491* 1510* 1541* 1618* 2686* 5729 5732* 8303 9163 allocated 0(17) based bit(1) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1022* 1088* 1162* 1222* alr 000421 constant fixed bin(18,0) initial dcl 22-16 set ref 9772* 9788* 9803* 9804* als 000425 constant fixed bin(18,0) initial dcl 22-16 set ref 7944* amount parameter fixed bin(18,0) dcl 4743 in procedure "create_temp" ref 4736 4755 4764 amount parameter fixed bin(18,0) dcl 4662 in procedure "get_temp" ref 4657 4664 amt 002765 automatic fixed bin(18,0) dcl 4939 in procedure "push_variable" set ref 4941* 4943 4953* amt 000275 automatic fixed bin(18,0) dcl 470 in procedure "code_generator" set ref 804* 806 809 824 amt 002713 automatic fixed bin(18,0) dcl 4744 in procedure "create_temp" set ref 4764* 4768 4770 4788 4796* amt 002666 automatic fixed bin(18,0) dcl 4662 in procedure "get_temp" set ref 4664* 4666 4668 4685 4709* amt parameter fixed bin(17,0) dcl 766 in procedure "alloc_constants" ref 760 768 776 anq 000455 constant fixed bin(18,0) initial dcl 22-16 set ref 9176* 9187* 9195* 9290* 9637* 9760* ansi_77 11(30) based bit(1) level 3 packed packed unaligned dcl 1-753 ref 3073 4109 4651 aos 000640 constant fixed bin(18,0) initial dcl 22-16 set ref 7614* ap 004212 automatic pointer dcl 9475 set ref 9496* 9498 9499 9501 9501 9502 9504 9505 9509 9510 9513 9514 9525 9526 9527 arg parameter pointer array dcl 5884 in procedure "make_both_addressable" ref 5878 5891 arg 1 based structure array level 2 in structure "arg_desc" dcl 1-130 in procedure "ext_code_generator" set ref 9501* 9501 9526* arg 003070 automatic pointer array dcl 5423 in procedure "emit_eis" set ref 5449* 5456* 5487 5494 5500 5502 5502 5510 5514 5519 5519 5519* 5552 arg1 004265 automatic fixed bin(18,0) dcl 9578 in procedure "rhs_fld" set ref 9581* 9582 9584* 9614 9617 9660* 9665* arg1 004306 automatic fixed bin(18,0) dcl 9687 in procedure "lhs_fld" set ref 9691* 9692 9694* 9727 9730 9786* 9800* arg1_is_const 004273 automatic bit(1) initial packed unaligned dcl 9579 in procedure "rhs_fld" set ref 9579* 9616* 9622 9650 arg1_is_const 004315 automatic bit(1) initial packed unaligned dcl 9688 in procedure "lhs_fld" set ref 9688* 9729* 9735 9765 arg2 004307 automatic fixed bin(18,0) dcl 9687 in procedure "lhs_fld" set ref 9697* 9698 9700* 9718 9721 9770* 9801* arg2 004266 automatic fixed bin(18,0) dcl 9578 in procedure "rhs_fld" set ref 9587* 9588 9590* 9602 9605 9654* 9667* arg2_is_const 004274 automatic bit(1) initial packed unaligned dcl 9579 in procedure "rhs_fld" set ref 9579* 9604* 9622 9658 arg2_is_const 004316 automatic bit(1) initial packed unaligned dcl 9688 in procedure "lhs_fld" set ref 9688* 9720* 9735 9781 arg3 004310 automatic fixed bin(18,0) dcl 9687 in procedure "lhs_fld" set ref 9703* 9704* 9706* 9743* 9759* 9761* 9771* 9778* 9787* 9793* 9802* 9809* arg3 004267 automatic fixed bin(18,0) dcl 9578 in procedure "rhs_fld" set ref 9593* 9594* 9596* 9628* 9648* arg4 004311 automatic fixed bin(18,0) dcl 9687 set ref 9709* 9710* 9742* 9747 9749 9754* 9773* 9789* 9805* arg_count 001516 automatic fixed bin(17,0) level 3 packed packed unaligned dcl 2602 set ref 3941* arg_desc based structure level 1 dcl 1-130 set ref 9387 9387 arg_desc_node 000706 constant fixed bin(4,0) initial dcl 3-87 set ref 9387* arg_list 001516 automatic structure level 1 dcl 2602 set ref 3948 3948 arg_no parameter fixed bin(18,0) dcl 9151 ref 9138 9174 arg_ptr constant fixed bin(18,0) initial dcl 2385 ref 6499 array 1(04) based bit(1) array level 4 packed packed unaligned dcl 1-130 set ref 9397* 9446 9449 9509* array_info 1 000117 automatic structure array level 2 in structure "descriptor" dcl 9912 in procedure "make_symbol_descriptor" array_info 1 004354 automatic structure array level 2 in structure "descriptor" dcl 10060 in procedure "make_entry_descriptor" array_name parameter fixed bin(18,0) dcl 7225 ref 7219 7234 7234 7234 7234 7234 7234 7234 array_ref based structure level 1 dcl 1-155 set ref 2670 2670 8825 8825 8832* array_ref_node 000735 constant fixed bin(4,0) initial dcl 3-87 set ref 2670* 3070 4400 4427 5148 5158 5255 5502 5511 5598 5662 6033 6119 6246 7234 8051 8137 8213 8676 8825* 8833 9063 9402 9449 9514 9880 array_ref_type constant fixed bin(4,0) initial dcl 3-120 ref 2672 8839 array_size 003631 automatic fixed bin(18,0) dcl 8289 in procedure "finish_subscript" set ref 8315* 8316 8320* 8348* 8443* 8472* 8500* 8505* 8517* 8522* 8534* array_size 3 based fixed bin(24,0) level 2 in structure "dimension" dcl 1-383 in procedure "ext_code_generator" set ref 2230* 2232 3613 3615 7873 8228 8315* 8320 asize 004020 automatic fixed bin(18,0) array dcl 8927 set ref 8935* 8941 8941 8943 8943 asq 000521 constant fixed bin(18,0) initial dcl 22-16 set ref 3778 8484* assembly_list 000227 automatic bit(1) dcl 441 set ref 592* 593 1810 2022 3333 3342 3750 3766 3779 3789 3803 3818 3887 3916 3965 4157 4184 5148 5255 5502 6130 11016 assumed_size 0(28) based bit(1) level 2 packed packed unaligned dcl 1-383 ref 2258 7728 8344 8498 8534 8575 9371 10003 10160 attributes 10 based structure level 2 dcl 1-844 auto 0(18) based bit(1) level 3 packed packed unaligned dcl 18-23 set ref 2110* auto_template 000310 automatic fixed bin(18,0) dcl 485 set ref 2664 10256* auto_zero 11(29) based bit(1) level 3 packed packed unaligned dcl 1-753 ref 752 automatic 0(33) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1093 1101 2107 2110 2125 automatic 11 based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1510* 1541* 2289* 10028* b1 000632 automatic bit(1) dcl 2353 set ref 3021* 3047* 3054* 3056* 3065* 3068* 3070* 3073* 3075* 3077* 3094* 3096* 3098* 3160* 3166* 3172* 3178* 3183* 3189* 3194* 3215* 3219* 3223* 3227* 3231* 3235* 3238 3478* 3482 3499 3700* 3899* 3910* 3913 3919* 3922* 4067* 4069 4109* 4119* 4124* 4129* 4134* 4136* 4145* 4147* 4152* 4295* b18 004636 automatic bit(18) dcl 10939 set ref 10949* 10964 b2 000633 automatic bit(1) dcl 2353 set ref 3009* 3013* 3025* 3029* 3051* 3059* 3081* 3085* 3147* 3151* 3163* 3169* 3175* 3181* 3186* 3192* 3197* 3201* 3238 3698* 3895* 4107* 4116* 4122* 4127* 4132* 4139* 4150* 4293* backward 0(18) based bit(18) level 2 packed packed unaligned dcl 26-12 set ref 10955* 10957* base 1 based bit(3) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1036* 1046* 1093* 1095* 1217* 1220* base 000123 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 6564 in procedure "base_man_store_temp" set ref 6600* 6616* 6628* base 001330 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 2465 in procedure "interpreter" set ref 3769* 3775* base 003172 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 6231 in procedure "base_man_load_pr" set ref 6293* base 004432 automatic pointer dcl 10273 in procedure "initialize" set ref 10276* 10284* 10287* base 000101 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 5807 in procedure "c_a" set ref 5817* 5821* 5825* 5830* 5842* 5842 base 000110 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 6457 in procedure "base_man_load_large_base_no_flush" set ref 6460* base 000104 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 6406 in procedure "base_man_load_large_base" set ref 6432* base parameter bit(3) dcl 6402 in procedure "base_man_load_large_base" ref 6395 6410 6432 base 1 based bit(3) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2675* base 1 based bit(3) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1311* 1321* 1377* 1403* 1449* 1452* 1493* 1512* 1543* 2687* 5714* 5716* base 000562 automatic fixed bin(18,0) dcl 2328 in procedure "interpreter" set ref 2716* 2872* 2891 2892 2894 2896 2903* 2984* 3681 3715 3868 3897 3910 3939 3951 3954 3959 3985 4112 4253 4276 4446* 4462 4547* 7690 7693 7701 7713 7719 7762 7769 7888 7918 7926 7933 8031 8032 8033 8093 8094 8104 8104 8111 8111 8127 8137 8140 8148 8161 8169 8170 8193 8197 8792 8795 8797 8934 8978 9361 9362 9370 9371 9371 9392 9415 9421 9461 9461 base 4 based fixed bin(18,0) level 2 in structure "proc_frame" dcl 2510 in procedure "interpreter" set ref 3643* 4446 4547* base 004422 automatic pointer dcl 10196 in procedure "initialize_static" set ref 10208* 10209 10217* 10219* 10220 10228* 10230* 10231 10247* 10248 base 1 based bit(3) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 3922 3922 5594* 5640* 5690* 5736* 5770* 5772* 5909 6279 9323 base 1 based bit(3) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4784* 5014* 5681* base parameter bit(3) dcl 6454 in procedure "base_man_load_large_base_no_flush" ref 6446 6460 6465 base_regs 110 001334 automatic structure array level 2 dcl 2479 set ref 6023* 6038* 6061* 6073* 6427* 6496* 6535* 6611* based_double based structure level 1 dcl 7459 based_dp based float bin(63) level 2 packed packed unaligned dcl 7459 ref 7478 based_integer based fixed bin(35,0) dcl 7457 in procedure "check_negative" ref 7471 based_integer based fixed bin(35,0) dcl 2463 in procedure "interpreter" ref 9605 9617 9721 9730 based_real based float bin(27) dcl 7458 ref 7474 bases 000616 constant bit(3) initial array dcl 522 ref 827 827 1036 1036 1046 1046 1093 1093 1095 1095 1217 1217 1220 1220 1311 1311 1321 1321 1377 1377 1403 1403 1449 1449 1452 1452 1493 1493 1512 1512 1543 1543 2675 2675 2687 2687 3922 3922 3922 3922 4784 4784 5014 5763 5763 5764 5764 5817 5817 5821 5821 5825 5825 5830 5830 6010 6022 6093 6279 6293 6410 6410 6422 6442 6465 6465 6472 6492 6510 6531 6549 6600 6616 6616 6628 6628 begin_external_list 000173 automatic fixed bin(18,0) dcl 431 set ref 605* 1634 1634 1667 1674 10661 begin_forward_refs 000175 automatic fixed bin(18,0) dcl 433 set ref 611* 630 637 689 10819 begin_links 000163 automatic fixed bin(18,0) dcl 428 set ref 723 1589* 10622 10624 bias constant fixed bin(19,0) initial dcl 3-56 ref 1317 1338 1518 1550 2782 2814 2831 2837 2842 2892 2993 3206 3209 3249 3296 3303 3314 3315 3390 3476 3534 3535 3535 3538 3548 3593 3693 3726 3772 3774 3833 3834 3857 3881 3898 3940 3955 4025 4038 4276 4301 4323 4378 4468 4596 4768 5238 5553 7462 7780 7847 7944 7945 7985 8101 8108 8149 8160 8171 8347 8425 8437 8481 8506 8550 8611 8639 8735 8735 8735 8774 8774 8774 8774 8795 8850 8994 9004 9055 9069 9113 9113 9121 9273 9361 9634 9641 9642 9652 9662 9756 9776 9791 9831 9870 9877 9884 9891 9951 10108 10878 bif constant fixed bin(4,0) initial dcl 3-120 ref 1274 9263 9941 10098 big_offset 003610 automatic bit(1) dcl 7759 set ref 7766* 7873* 7890 7909* 8055* 8081* 8228* 8240 8678 8705 bin builtin function dcl 569 ref 561 binary builtin function dcl 9-19 in procedure "create_constant" ref 9-57 binary builtin function dcl 569 in procedure "code_generator" ref 2258 5151 6130 6301 6301 6746 10781 bit builtin function dcl 569 in procedure "code_generator" ref 684 684 717 718 719 720 721 722 723 724 725 733 3693 3705 6668 6700 6746 6761 6811 6812 6831 9325 9326 10621 10622 10623 10624 10778 10785 10826 10841 10847 10886 10910 10951 10967 11009 11009 bit builtin function dcl 5441 in procedure "emit_eis" ref 5498 bit3 000636 automatic bit(3) dcl 2354 set ref 3760* 3763 3769 3781 3788* 3791 bit6 003426 automatic bit(6) dcl 7228 in procedure "use_eaq" set ref 7256* bit6 000112 automatic bit(6) dcl 7320 in procedure "save_logical_temps" set ref 7337* bit_image based bit(72) dcl 2475 set ref 2807* 2807* bit_offset 3(21) 001516 automatic bit(6) array level 3 packed packed unaligned dcl 2602 set ref 9326* bit_type 004135 automatic structure level 3 in structure "descriptor" packed packed unaligned dcl 9241 in procedure "make_descriptor" bit_type 000117 automatic structure level 3 in structure "descriptor" packed packed unaligned dcl 9912 in procedure "make_symbol_descriptor" bit_type 004354 automatic structure level 3 in structure "descriptor" packed packed unaligned dcl 10060 in procedure "make_entry_descriptor" bits 0(25) based structure level 2 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" bits 3 based structure level 2 in structure "statement" packed packed unaligned dcl 1-721 in procedure "ext_code_generator" bits parameter structure array level 2 in structure "regs" packed packed unaligned dcl 5926 in procedure "get_free_reg" bits 0(25) based structure level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" bits 0(18) based bit(10) array level 2 in structure "macro_bits_inst" packed packed unaligned dcl 2553 in procedure "interpreter" ref 3019 3021 3038 3047 bits 0(25) based structure level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" bits 0(25) based structure level 2 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" bits 37 001334 automatic structure array level 3 in structure "machine_state" packed packed unaligned dcl 2479 in procedure "interpreter" bits 0(25) based structure level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" bits 110 001334 automatic structure array level 3 in structure "machine_state" packed packed unaligned dcl 2479 in procedure "interpreter" bits 0(25) based structure level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4779* bits 0(25) based structure level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" bits 0(25) based structure level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" bits_per_char constant fixed bin(9,0) initial dcl 3-68 ref 8550 9326 blank_common_name 000636 constant char(8) initial dcl 3-79 ref 1680 1886 block_name 10 based char level 2 in structure "header" dcl 1-436 in procedure "ext_code_generator" set ref 1675 1675 1680 1859 1859 1886 2120 10678 10678* 10681* 10683* 10878* block_name 3(18) based char level 2 in structure "create_entry" packed packed unaligned dcl 18-23 in procedure "code_generator" set ref 2120* block_size parameter fixed bin(18,0) dcl 4636 ref 4631 4638 block_type 004526 automatic bit(18) dcl 10699 set ref 10715* 10724* 10726* 10742* 10766 boffset 000116 automatic fixed bin(35,0) dcl 10455 set ref 10492* 10494* 10494 10543 10548 10553 10558 bool builtin function dcl 9-20 ref 9-54 bound 003556 automatic fixed bin(18,0) dcl 7688 set ref 7733* 7735* 7736* 7738* 7740* 7741* bsize 000124 automatic fixed bin(18,0) dcl 10457 set ref 10541* 10543 10543 10543 10546* 10548 10548 10548 10551* 10553 10556* 10558 10571 10595 build_profile_after_label 000635 automatic bit(1) dcl 2353 set ref 2702* 3287 3290* 3708* builtin 10(32) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1272 builtins 000232 automatic fixed bin(18,0) array dcl 444 set ref 703 1487* 1488 1498* 1506* 1507 1524* 1525 1531* 1531* 2627* 2628* 2629* 2630* 2631* 2636 2650 2659* 2660 2670* 2671 2679 2682* 2683 2689* 2690 2847 9174 9175 9829 9829 bvalue 003536 automatic bit(72) dcl 7661 set ref 7663* 7664* by_compiler 0(35) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 1490* 1509* 1540* 2289* 2685* 2693* 10025* byte builtin function dcl 569 ref 4049 c 003242 automatic fixed bin(18,0) dcl 6803 in procedure "xr_man_add_const" set ref 6809* 6811 c 003220 automatic fixed bin(18,0) dcl 6739 in procedure "xr_man_load_const" set ref 6741* 6743* 6755* 6755* 6758 c 003230 automatic fixed bin(18,0) dcl 6774 in procedure "const_in_xr" set ref 6778* 6783 c 000150 automatic pointer dcl 426 in procedure "code_generator" set ref 653* 654 655 771* 772 772 772 775 776 778 780 795* 796 796 796 799 804 805 806 810 812 c parameter fixed bin(18,0) dcl 5805 in procedure "c_a" ref 5800 5809 5842 c_mult_offset 003635 automatic fixed bin(18,0) dcl 8289 set ref 8369* 8371* 8460 8460 8547 8547 c_multiplier 003633 automatic fixed bin(18,0) dcl 8289 set ref 8361* 8365* 8389 8390* 8390 8399 8437 8439 8439 c_virtual_origin 003632 automatic fixed bin(18,0) dcl 8289 set ref 8357* 8389* 8389 8399 8419 8425 8427 8427 case 000123 automatic fixed bin(18,0) dcl 10457 in procedure "list_initialize_symbol" set ref 10501* 10505* 10507* 10539 10573 case 004457 automatic fixed bin(18,0) dcl 10335 in procedure "initialize_symbol" set ref 10379* 10383* 10385* 10418 cdt 000621 automatic fixed bin(4,0) dcl 2349 set ref 2824* 2826 ceil builtin function dcl 1662 ref 1684 1696 cg_globals based structure level 1 dcl 58 cg_struc_ptr 000102 automatic pointer dcl 43 set ref 69* 590 641 646 651 706* 3622 3636 3948 7629 7630 7632 7641 7642 7649 7650 7651 chain 2 based pointer level 2 in structure "entry" dcl 1846 in procedure "create_storage_entry" set ref 1898 1899 1905* 1905 1906* 1921 1925 1926 1928 1937* 1937 1940* 1992 1997 2028 2074 2088* chain parameter fixed bin(18,0) dcl 4914 in procedure "thread_temp" ref 4908 4921 4922 chain_head 000106 automatic pointer dcl 1836 set ref 1879* 1898 1913* 1920 1963* 1963* 1967 1983 1985 1986 1986 1989 1989 1992 2032* 2032* 2033 2070* 2072 char builtin function dcl 9-21 in procedure "create_constant" ref 9-45 9-45 char builtin function dcl 569 in procedure "code_generator" ref 1582 1582 1636 1636 1705 1705 1708 1708 1740 1740 1746 1746 1886 1886 2207 2207 4571 4571 5381 5381 char builtin function dcl 10-17 in procedure "create_node" ref 10-29 10-29 char1 000625 automatic char(1) packed unaligned dcl 2350 set ref 4049* 4050* 4050* char77_target based char array packed unaligned dcl 10476 in procedure "list_initialize_symbol" set ref 10588* char77_target based char array packed unaligned dcl 10353 in procedure "initialize_symbol" set ref 10432* char_77_mode 003607 automatic bit(1) dcl 7759 set ref 7767* 7873 7881 7894 char_constant based structure level 1 dcl 1-316 set ref 2659 2659 char_constant_length 000120 automatic fixed bin(18,0) unsigned dcl 1-378 set ref 2658* 2659 2659 char_constant_node 000732 constant fixed bin(4,0) initial dcl 3-87 set ref 2659* 3425 4058 5302 8265 9428 9549 9870 char_image based char dcl 466 set ref 806* char_length parameter fixed bin(18,0) dcl 4623 ref 4618 4626 char_mode constant fixed bin(4,0) initial dcl 3-106 ref 9-43 1358 2662 2673 4625 4648 4977 5633 8842 9268 9546 9867 9946 10024 10103 char_num 1(18) based fixed bin(2,0) level 3 in structure "temporary" packed packed unsigned unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 8997* 8998 char_num 1(18) based fixed bin(2,0) level 3 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "ext_code_generator" set ref 3075 6262 6263* 6334* 8186 9326 char_num 1(18) based fixed bin(2,0) level 3 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1763* 3068 8225 10371 10494 char_num 1(18) based fixed bin(2,0) level 3 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "ext_code_generator" set ref 3073 7896 7897* 7898 8244* 8245 char_num_hold 003174 automatic fixed bin(2,0) dcl 6233 set ref 6262* 6295 6301 6310 6320 6334 char_overlay based char(1) array packed unaligned dcl 10355 set ref 10372 char_size 10 based fixed bin(20,0) level 4 packed packed unsigned unaligned dcl 1-844 set ref 3548 9546 9877 10029* 10378 10382 10500 10504 char_star_ndims 000114 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 9932* 9970* 10015 10015 10029 10030 char_star_ndims 004351 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10080* 10127* 10172 10172 char_target based char array dcl 10351 in procedure "initialize_symbol" set ref 10428* char_target based char array dcl 10474 in procedure "list_initialize_symbol" set ref 10583* char_temp 001332 automatic char(8) packed unaligned dcl 2469 set ref 4028* 4029 4029 4041* 4042 4042 char_units constant fixed bin(3,0) initial dcl 3-136 ref 1760 3063 4651 5633 6253 6279 6287 7767 8265 8369 8540 9270 9948 10105 10369 10375 10494 10497 character 10(25) based bit(1) level 5 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 10026* 10375 10497 character 0(32) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 10872 character_operand 1 based fixed bin(18,0) level 2 unsigned dcl 1-605 ref 653 chars_per_dw constant fixed bin(9,0) initial dcl 3-68 ref 799 4035 4038 4038 4041 4042 4042 chars_per_word 000730 constant fixed bin(9,0) initial dcl 3-68 ref 804 804 1762 1763 2666 2677 4022 4025 4025 4028 4029 4029 4627 4627 7881 7897 7898 7900 8186 8204 8225 8244 8245 8247 8994 8995 8997 8998 9000 9082 9925 10073 10845 10845 10872 10872 check_multiply 11(31) based bit(1) level 3 packed packed unaligned dcl 1-753 ref 4129 check_stringrange constant fixed bin(18,0) initial dcl 2449 set ref 8095* check_subscript constant fixed bin(18,0) initial dcl 2449 set ref 7743* class 1(33) based bit(3) level 2 in structure "definition" packed packed unaligned dcl 26-12 in procedure "generate_definition" set ref 10967* class parameter fixed bin(3,0) dcl 10934 in procedure "generate_definition" ref 10931 10967 10969 10973 10978 cleanup builtin function dcl 569 ref 973 cleanup_body_address 000146 automatic fixed bin(18,0) unsigned dcl 423 set ref 1537* 1538 1548* 1553* 4155 clength 002654 automatic fixed bin(18,0) dcl 4611 set ref 4626* 4627 4650 clp 000114 automatic pointer dcl 939 set ref 1538* 1539 1540 1541 1541 1541 1541 1541 1543 1544 1547* cm 000107 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 9973* 9975* 9979 9986* 9986 cm 000216 automatic fixed bin(18,0) dcl 2222 in procedure "get_array_size" set ref 2237* 2239 2240* 2240 cm 004345 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10130* 10132* 10136 10143* 10143 cmpx_image based complex float bin(27) dcl 2474 set ref 2643* cmpx_mode 000730 constant fixed bin(4,0) initial dcl 3-106 set ref 1356 2644* 3114 3120 7234 code parameter fixed bin(18,0) dcl 5858 in procedure "c_a_18" ref 5851 5871 code 000103 automatic fixed bin(18,0) dcl 6405 in procedure "base_man_load_large_base" set ref 6410* 6412* 6419 6437 code parameter fixed bin(18,0) dcl 5985 in procedure "base_man_load_any_pr" ref 5982 5996 code parameter fixed bin(18,0) dcl 5805 in procedure "c_a" ref 5800 5811 code_emitted 003606 automatic bit(1) dcl 7759 set ref 7766* 7915 7977 7999 8139* 8147* 8159* 8168* 8176 8184* 8341* 8355* 8385 8393* 8450 8656 8731 8757* 8768 common 0(20) based bit(1) level 3 packed packed unaligned dcl 18-23 set ref 2051 2112* common_chain 2 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1155 common_length 000122 automatic fixed bin(35,0) dcl 1957 set ref 1967* 1993 common_link 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 18-23 set ref 1986* 2051* 2051 compare_inst 000501 constant fixed bin(18,0) initial array dcl 22-16 ref 3458 3497 con 000276 automatic fixed bin(18,0) dcl 470 set ref 770* 770* 771* 794* 794* 795* const 000112 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 10013* 10015* 10031 10039 const 004131 automatic fixed bin(18,0) dcl 9238 in procedure "make_descriptor" set ref 9281* 9291* 9301 const 004347 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10170* 10172* 10176 10180 10184 constant based structure level 1 dcl 1-256 set ref 9-74 9-74 constant_count 77 based fixed bin(17,0) array level 3 dcl 53 set ref 9-87* 9-87 constant_info 77 based structure array level 2 dcl 53 constant_node 000733 constant fixed bin(4,0) initial dcl 3-87 set ref 9-74* 3425 4047 5300 9602 9614 9718 9727 9747 constant_type constant fixed bin(4,0) initial dcl 3-120 ref 9-82 2661 7697 7728 7808 8035 8042 conv_round 2500 based entry variable array level 2 dcl 53 ref 2826 copy builtin function dcl 569 in procedure "code_generator" ref 1988 2105 2107 2137 copy builtin function dcl 9689 in procedure "lhs_fld" ref 9749 count 002732 automatic fixed bin(18,0) dcl 4813 in procedure "free_temp" set ref 4825* 4826 count based bit(9) level 2 in structure "acc" packed packed unaligned dcl 10800 in procedure "name_assign" set ref 10821 10841* count_type constant fixed bin(4,0) initial dcl 3-120 ref 3045 create_char_constant 1524 based entry variable level 2 dcl 53 ref 4029 4042 4050 4050 10015 10172 create_constant_block 34 based entry variable level 2 dcl 58 ref 3948 create_entry based structure level 1 unaligned dcl 18-23 set ref 1823 2030 create_init_entry based structure level 1 unaligned dcl 18-61 set ref 10593 cs 000570 automatic pointer dcl 2334 in procedure "interpreter" set ref 2622* 2623* 3073 3183 3194 3685 3826 3828 4109 4124 4129 4295 4651 6499 6501 6538 6540 7728 8089 9822* 9823* 9825 9828 9831 9837 cs parameter pointer dcl 2281 in procedure "create_automatic_integer" ref 2276 2293 2294 cs parameter pointer dcl 746 in procedure "get_subr_options" ref 740 748 749 750 751 752 cs 000106 automatic pointer dcl 939 in procedure "assign_storage" set ref 994* 995* 999 1003 1011 1015 1065 1065 1067 1068 1083 1140 1140 1142 1143 1155 1170 1170 1172 1173 1185 1203 1203 1203 1207 1208 1208 1209 1209 1233 1233 1235 1236 1244 1255 1442 1443 1443 1468 1468 1470 1471 1478 1592* 1593* 1597 1603 1623 1636 2160* 2161* 2164 2164 2166 2186 2190 2205 2207 2264* cs 000104 automatic pointer dcl 9908 in procedure "make_symbol_descriptor" set ref 10035* 10036 10037 csize 004460 automatic fixed bin(18,0) dcl 10335 in procedure "initialize_symbol" set ref 10378* 10382* 10428 10428 10428 10432 10432 10432 csize 003763 automatic fixed bin(18,0) dcl 8820 in procedure "create_array_ref" set ref 8844* 8845 8848 8850 csize 004014 automatic fixed bin(18,0) array dcl 8925 in procedure "start_cat" set ref 8935* 8944* 8959* csize 000115 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 9950* 9951 9951 csize parameter fixed bin(18,0) dcl 6736 in procedure "xr_man_load_const" ref 6731 6741 csize 004352 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10107* 10108 10108 csize 004060 automatic fixed bin(18,0) dcl 9043 in procedure "get_cat_lengths" set ref 9048* 9049 9054 9055 9068 9081 9088 csize 004036 automatic fixed bin(18,0) dcl 8973 in procedure "continue_cat" set ref 8986* 8987 8994 9004 9007* 9007 9007 9009 9009 csize 003624 automatic fixed bin(18,0) dcl 8025 in procedure "finish_subscript" set ref 8087* 8092* 8101 8101 8108 8108 csize 000125 automatic fixed bin(18,0) dcl 10457 in procedure "list_initialize_symbol" set ref 10500* 10504* 10551 10556 10583 10583 10583 10588 10588 10588 csize 004133 automatic fixed bin(18,0) dcl 9238 in procedure "make_descriptor" set ref 9272* 9273 9273 csize 003121 automatic fixed bin(18,0) dcl 5543 in procedure "get_eis_length" set ref 5552* 5553 5553 5556 5556 5556 5558 5558 csize parameter fixed bin(18,0) dcl 6801 in procedure "xr_man_add_const" ref 6795 6809 csp 004414 automatic pointer dcl 10194 set ref 10202* 10206 10214 10225 10233 10239* 10241 10259* 10261 10263 10279 csub 003555 automatic fixed bin(18,0) dcl 7688 set ref 7699* 7701 7706 csum 003576 automatic fixed bin(24,0) dcl 7757 set ref 7768* 7779* 7779 7785 7791 7794* 7811* 7811 7827 7833 7835* 7846* 7846 7853* 7853 7873 7873 7881* 7881 7884* 7884 7896* 7896 7897 7898 7898* 7898 7900* 7900 7910* 7910 7935* 7950* 7950 7956 7980 7983 7983 7983 7983 7985 8186* 8190* 8190 8199* 8199 8204* 8204 8226 8244 8245 8245* 8245 8247* 8247 8260 8264 8751 8752* cur_frame 000564 automatic pointer dcl 2331 set ref 2712* 2714* 2869 2879 2913 2975 2978 2981 2986 2991 2991 2993 2993 2993 2995 2995 2999 3003 3003 3004 3004 3639 3640* 3640 3643 3645 4445* 4445 4446 4506 4507 4534 4534* 4534 4536* 4540 4542 4545 4546 4547 4548 4567 4576 4576 4580 cur_pos 000100 automatic fixed bin(18,0) unsigned dcl 1785 set ref 1812* 1816 2024* 2025 cur_statement 67 based fixed bin(18,0) level 2 dcl 53 set ref 584* 3703* 3705 3708 cur_subprogram 71 based fixed bin(18,0) level 2 dcl 53 set ref 993* 993* 994* 1591* 1591* 1592* 2159* 2159* 2160* 2621* 2622 3685* 3686 9822 10035 cur_subr 004412 automatic fixed bin(18,0) dcl 10193 set ref 10201* 10201* 10202* 10238* 10238* 10239* 10258* 10258* 10259* current_def_offset 7 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 699* current_link_offset 10 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 700* current_offset 000123 automatic fixed bin(35,0) dcl 1958 set ref 1999* 2001* 2005 2014 2016* current_text_offset 6 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 698* currentsize builtin function dcl 569 in procedure "code_generator" ref 10593 currentsize builtin function dcl 1790 in procedure "create_storage_entry" ref 1823 2030 cvalue 003603 automatic fixed bin(18,0) dcl 7758 set ref 7810* 7811 8222* 8223* 8223 8225* 8225 8226* 8226 8228 8228 d 000102 automatic pointer dcl 9908 in procedure "make_symbol_descriptor" set ref 9966* 9967 9982 9984 9985 9986 9996 9996 10001 10001 10003 10023* 10024 10025 10026 10027 10028 10029 10030 10031 d 003660 automatic pointer dcl 7995 in procedure "add_pointer" set ref 8003* 8004 d 004342 automatic pointer dcl 10056 in procedure "make_entry_descriptor" set ref 10085* 10088 10088* 10088 10092 10093 10123* 10124 10139 10141 10142 10143 10153 10153 10158 10158 10160 d 000214 automatic pointer dcl 2221 in procedure "get_array_size" set ref 2226* 2230 2230 2231 2232 2238 2239 2240 2243 2244 2256 2258 2258 2259 2259 2259 2259 2262 2262 2262 2262 2264 2266 d 003570 automatic pointer dcl 7756 in procedure "finish_subscript" set ref 7763* 7771 7777 7779 7780 7797 7853 7853 7860 7873 8307* 8309 8313 8315 8317 8318 8320 8335 8337 8337 8338 8339 8344 8346 8387 8389 8390 8394 8399 8399 8401 8402 8408 8410 8412 8413 8415 8472 8472 8479 8479 8481 8481 8498 8506 8506 8508 8514 8514 8514 8516 8527 8534 8575 8577 8579 8587 8589 8600 8608 8611 8612 8616 8620 8623 8623 8624 8625 8628 8632 8635 8638 8640 d 003546 automatic pointer dcl 7687 in procedure "next_subscript" set ref 7691* 7701 7701 7706 7706 7728 7728 7728 7733 7733 7735 7738 7738 7740 d 003744 automatic pointer dcl 8790 in procedure "start_subscript" set ref 8793* 8795 data_size 000104 automatic fixed bin(17,0) dcl 9-22 set ref 9-47* 9-49 9-87 9-87 9-89 9-89 9-91 9-93 data_type 0(05) based fixed bin(4,0) level 2 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "ext_code_generator" set ref 2662* data_type 0(05) based fixed bin(4,0) level 2 in structure "temporary" packed packed unsigned unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4644* 4977* data_type parameter fixed bin(4,0) dcl 9-15 in procedure "create_constant" ref 9-13 9-40 data_type 0(05) based fixed bin(4,0) level 2 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "ext_code_generator" ref 9-65 3478 4047 5633 7466 7466 7469 9266 9393 9430 9544 9544 9544 9546 9582 9588 9692 9698 9867 data_type 0(05) based fixed bin(4,0) level 2 in structure "constant" packed packed unsigned unaligned dcl 1-256 in procedure "ext_code_generator" set ref 9-81* 2824 data_type 0(05) based fixed bin(4,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1356 1358 1432 2288* 2692* 3016 3101 3103 3128 4955* 8316* 8411* 8840 8842 9505 9944 10024* 10101 10385 10507 data_type 0(05) based fixed bin(4,0) level 2 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2673* 7234 8840* data_type 1 based fixed bin(4,0) array level 3 in structure "arg_desc" packed packed unsigned unaligned dcl 1-130 in procedure "ext_code_generator" set ref 9393* 9430 9502 9505* 9527* data_type 0(18) based fixed bin(9,0) array level 2 in structure "macro_dt_inst" packed packed unaligned dcl 2547 in procedure "interpreter" ref 2767 2790 2802 2825 4595 7630 7650 data_type parameter fixed bin(4,0) dcl 4609 in procedure "assign_temp" ref 4604 4613 data_type_size 000626 constant fixed bin(17,0) initial array dcl 3-115 ref 9-43 9-47 1432 2808 4614 4941 10385 10507 datum 2 based bit level 2 packed packed unaligned dcl 18-61 set ref 10575 10579 10583 10588 debugging 113(16) based structure level 4 in structure "shared_globals" packed packed unaligned dcl 53 in procedure "ext_code_generator" debugging 11(16) based structure level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "ext_code_generator" decimal builtin function dcl 9-23 ref 9-45 9-45 decl_vers based fixed bin(17,0) level 2 dcl 13-10 set ref 715* def_base 000206 automatic pointer dcl 438 set ref 672* 10632 10646 10760 10833 10875 10887 10952 10959 11014 def_header based structure level 1 dcl 10611 def_offset 1 based bit(18) level 2 packed packed unaligned dcl 12-52 set ref 10621* def_pool 000251 automatic fixed bin(18,0) array dcl 468 set ref 586* 10909 10910 10910 10917* def_pos 000161 automatic fixed bin(18,0) dcl 428 set ref 587* 693 699 719 10636* 10760 10761 10778 10785 10788* 10788 10833 10844 10845* 10845 10875 10875 10883* 10883 10883 10886 10917 10920* 10920 10921* 10921 10923* 10923 10951 10981* 10981 def_ptr 004632 automatic pointer dcl 10938 in procedure "generate_definition" set ref 10952* 10955 10957 10961 10963 10964 10965 10967 10972 10973 def_ptr 004530 automatic pointer dcl 10701 in procedure "compile_link" set ref 10760* 10766 10768 10772 10773 10778 def_ptr 004652 automatic pointer dcl 10991 in procedure "gen_entry_defs" set ref 11014* 11019 def_reloc_base 000220 automatic pointer dcl 439 set ref 673* 697 10633 10761 10953 def_reloc_base_ptr 4 000122 automatic pointer level 2 dcl 61 set ref 697* def_reloc_ptr 004634 automatic pointer dcl 10938 in procedure "generate_definition" set ref 10953* 10976 10977 10978 def_reloc_ptr 004534 automatic pointer dcl 10701 in procedure "compile_link" set ref 10761* 10769 10774 10776 10779 defblock 2(18) based bit(18) level 2 packed packed unaligned dcl 24-3 set ref 10646* definition based structure level 1 dcl 27-12 in procedure "gen_entry_defs" definition based structure level 1 dcl 26-12 in procedure "generate_definition" definition_length 4(18) based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 719* definition_offset 4 based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 718* defrel 000165 automatic fixed bin(18,0) dcl 428 set ref 671* 672 673 693 718 10621 10825 desc 000615 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 3963* 3968* desc 000110 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 10022* 10023 10036 10037 10039* 10043 10047 desc 004104 automatic fixed bin(18,0) dcl 9153 in procedure "get_param_char_size" set ref 9157* 9163 9163 9163* 9169 9181 9187* 9188* 9195 9196* desc 004130 automatic fixed bin(18,0) dcl 9238 in procedure "make_descriptor" set ref 9288* 9292* 9298 9299 9301* 9303 desc 003636 automatic fixed bin(18,0) dcl 8289 in procedure "finish_subscript" set ref 8297* 8303 8303 8303* 8325 8335 8369 8460 8460* 8463* 8540 8547* 8549* 8551* 8577 8580* 8598 8601* 8609 8609* 8618 8621* 8630 8633* 8636 8636* desc 004116 automatic fixed bin(18,0) dcl 9213 in procedure "copy_array_desc_template" set ref 9216* 9218 9219* desc 004646 automatic fixed bin(18,0) dcl 10990 in procedure "gen_entry_defs" set ref 11025* 11026 desc_image based char packed unaligned dcl 9925 in procedure "make_symbol_descriptor" set ref 10015* 10029 desc_image based char packed unaligned dcl 10073 in procedure "make_entry_descriptor" set ref 10172* desc_no parameter fixed bin(18,0) dcl 5279 ref 5271 5316 5328 5331 5331 desc_temp_chain 000600 automatic fixed bin(18,0) unsigned dcl 2344 set ref 2701* 3976 3978 3979* 9298 9299* descriptor 004354 automatic structure level 1 dcl 10060 in procedure "make_entry_descriptor" set ref 10078* 10172 descriptor based structure array level 1 dcl 5431 in procedure "emit_eis" set ref 5494 descriptor 11(10) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 2695* 5707 descriptor 004135 automatic structure level 1 dcl 9241 in procedure "make_descriptor" set ref 9251* descriptor 000117 automatic structure level 1 dcl 9912 in procedure "make_symbol_descriptor" set ref 9930* 10015 10029 descriptor_mask_addr 000345 constant bit(36) initial dcl 2458 set ref 9176* 9290* descriptor_ptr constant fixed bin(18,0) initial dcl 2385 ref 6538 descriptor_relp 0(18) based fixed bin(18,0) array level 2 packed packed unsigned unaligned dcl 515 set ref 3736* 3738 11025 11026* descriptor_type_word 000321 automatic structure array level 1 dcl 552 set ref 9263 9267 9941 9945 10098 10102 diff 000112 automatic fixed bin(18,0) dcl 5994 set ref 5998* 6020* 6085 6085* 6085* dim 5 based structure array level 2 dcl 1-383 dim_no parameter fixed bin(18,0) dcl 8566 ref 8559 8569 dimension 12(25) based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1306 2226 3611 3761 7691 7763 8003 8228 8307 8793 9371 9966 10123 dimension based structure level 1 dcl 1-383 in procedure "ext_code_generator" dimensioned 10(35) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1351 1426 1769 3054 3813 6142 6181 9169 9184 9371 9394 9438 9506 9964 10121 10387 10509 directable 0(18) 000024 external static bit(1) array level 2 packed packed unaligned dcl 2375 ref 5235 5308 5398 div constant fixed bin(18,0) initial dcl 22-16 ref 7942 divide builtin function dcl 569 ref 663 693 712 804 893 1285 1514 1545 1561 1762 2844 4284 4627 7898 7900 8245 8247 8998 9000 10543 10548 10551 10553 10845 10872 10997 do_rounding 000230 automatic bit(1) dcl 441 in procedure "code_generator" set ref 748* 3485 3997 7263 7343 7541 do_rounding 11(28) based bit(1) level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "ext_code_generator" ref 748 dollar_name 004541 automatic char(32) dcl 10706 set ref 10733* 10734* 10745* 10746* dont_update 0(22) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 5610 5622* 7070 7209* 7518* 8705* dont_update 0(22) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 7252 7257* 7335 7338* 8076* dont_update 0(22) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 7270* 7350* double_target based bit(72) array dcl 10349 in procedure "initialize_symbol" set ref 10424* double_target based bit(72) array dcl 10472 in procedure "list_initialize_symbol" set ref 10579* dp_image based float bin(63) dcl 2473 set ref 2640* dp_mode 000734 constant fixed bin(4,0) initial dcl 3-106 set ref 2629* 2641* dt 000111 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 9944* 9945 9946 dt parameter fixed bin(18,0) dcl 4937 in procedure "push_variable" ref 4932 4941 4955 dt 004346 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10101* 10102 10103 dt 004132 automatic fixed bin(18,0) dcl 9238 in procedure "make_descriptor" set ref 9266* 9267 9268 dt 002655 automatic fixed bin(18,0) dcl 4611 in procedure "assign_temp" set ref 4613* 4614 4625* 4640* 4644 4648 dt 000622 automatic fixed bin(4,0) dcl 2349 in procedure "interpreter" set ref 2767* 2770 2770* 2770* 2802* 2805 2807* 2807* 2808 2825* 2826 2828* 2905* 2906* 3128* 3131 3131 3137 dt1 000623 automatic fixed bin(4,0) dcl 2349 set ref 3101* 3105 3111 3114 3123 dt2 000624 automatic fixed bin(4,0) dcl 2349 set ref 3103* 3108 3117 3120 3123 dt_from_reg 000374 constant fixed bin(4,0) initial array dcl 2399 ref 2905 3458 dummy constant fixed bin(4,0) initial dcl 3-120 ref 1489 1508 1539 2684 e 004206 automatic fixed bin(17,0) dcl 9474 set ref 9478* 9479 9479 9480* 9480 9482 eaq 001334 automatic structure array level 2 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 6982 7128 7245 7393 eaq 0(15) based bit(1) level 4 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 3091 3406 3406 3416 3416 3425 3425 5556 5610 6158 6681 6980 7075 7125 7173* 7194* 7209* 7234 7273* 7307* 7353* 7387 7518* eaq 0(15) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 6960 eaq_name 003467 automatic fixed bin(18,0) dcl 7534 in procedure "store" set ref 7537* 7541 7543 7547 7554 7555 7555* 7557* eaq_name 0(22) based fixed bin(5,0) array level 2 in structure "macro_instruction" packed packed unaligned dcl 2531 in procedure "interpreter" set ref 2882 3094 3096 3158 3393 3400 3449 3466 3471 3479 3516 4000 eaq_name 003443 automatic fixed bin(18,0) dcl 7366 in procedure "load" set ref 7368* 7370 7370 7384 7400 7400 7400 7404 7407 7421 7439 7441 7441* 7444* eaq_name 000616 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 3093* 3094 3096 3158* 3159 3400* 3406 3416 3416 3443* 3479* 3480 3485 3485 3485 3485 3492 3497 3516* 3518 4000* 4001 4003 eaq_name_to_reg 000352 constant fixed bin(17,0) initial array dcl 2402 ref 3159 3450 3480 3518 4003 7105 7157 7191 7554 eax0 constant fixed bin(18,0) initial dcl 22-16 ref 6681 6755 6819 element_count 2 based fixed bin(24,0) level 2 dcl 1-383 ref 2230 element_size 15(07) based fixed bin(17,0) level 2 packed packed unaligned dcl 1-844 set ref 1057 1428 1611 2175 2182 2230 2237 2290* 7844 7846 7847 7956 8260 8337 8347 8361 9973 9975 10030* 10130 10132 end_external_list 000174 automatic fixed bin(18,0) dcl 431 set ref 611* 10661 end_offset parameter fixed bin(35,0) dcl 10448 in procedure "list_initialize_symbol" set ref 10440 10564 10568 10595* end_offset 000106 automatic fixed bin(35,0) dcl 10306 in procedure "list_initialize" set ref 10311* 10317* ent_name 004525 automatic bit(18) dcl 10699 set ref 10717* 10741* 10746* 10752* 10754 10773 entry 1(20) based bit(1) level 3 in structure "definition" packed packed unaligned dcl 26-12 in procedure "generate_definition" set ref 10973* entry 000020 external static fixed bin(17,0) array level 2 in structure "fort_cg_macros_$interpreter_macros" packed packed unaligned dcl 2367 in procedure "interpreter" ref 4502 entry 000022 external static fixed bin(17,0) array level 2 in structure "fort_cg_macros_$operator_table" packed packed unaligned dcl 2371 in procedure "interpreter" ref 2948 entry based structure level 1 unaligned dcl 1846 in procedure "create_storage_entry" set ref 2075 2086 entry_info 7 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 set ref 6501 6540 9828* entry_info_size 000731 constant fixed bin(18,0) initial dcl 2456 set ref 9829* 9830 entry_type constant fixed bin(4,0) initial dcl 3-120 ref 980 ep 004214 automatic pointer dcl 9475 set ref 9482* 9484 9486 9489 9496 epaq constant fixed bin(18,0) initial dcl 22-16 ref 3771 equiv_chain 2(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1185 era 000424 constant fixed bin(18,0) initial dcl 22-16 set ref 9773* 9789* 9805* erq 000423 constant fixed bin(18,0) initial dcl 22-16 set ref 9759* err_flag 000634 automatic bit(1) dcl 2353 set ref 2923* 3660* error_exit parameter fixed bin(18,0) dcl 4519 ref 4514 4546 error_label 5 based fixed bin(18,0) level 2 dcl 2510 set ref 3639 3655 4546* ersq 000422 constant fixed bin(18,0) initial dcl 22-16 set ref 9761* 9778* 9793* 9809* escape_index constant fixed bin(18,0) initial dcl 2385 ref 6883 even 0(30) based bit(1) level 4 packed packed unaligned dcl 1-436 ref 1193 exp_ptr 1 based bit(18) level 2 packed packed unaligned dcl 12-11 set ref 10785* exp_word based structure level 1 dcl 12-21 ext_attributes 4 based structure level 2 packed packed unaligned dcl 1-844 ext_base 1(29) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4871* ext_base 1(29) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" ref 3922 5246 5519 5896 5907 6279 9321 ext_base 0(29) 000101 automatic bit(1) level 2 in structure "inst_address" packed packed unaligned dcl 5807 in procedure "c_a" set ref 5836* ext_base 1(29) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2674* ext_base 0(29) 001330 automatic bit(1) level 2 in structure "inst_address" packed packed unaligned dcl 2465 in procedure "interpreter" set ref 3770* 7941* ext_base 0(29) 000123 automatic bit(1) level 2 in structure "inst_address" packed packed unaligned dcl 6564 in procedure "base_man_store_temp" set ref 6572* ext_base 0(29) based bit(1) array level 3 in structure "instruction" packed packed unaligned dcl 2581 in procedure "interpreter" ref 5124 5262 ext_base 1(29) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1349* 1402* 1454* 1491* 1510* 1541* 2686* 2696* ext_base_and_tag 0(29) based structure array level 2 in structure "machine_instruction" packed packed unaligned dcl 2538 in procedure "interpreter" set ref 5034 ext_base_and_tag 0(29) based structure array level 2 in structure "instruction" packed packed unaligned dcl 2581 in procedure "interpreter" ext_base_on constant bit(36) initial dcl 563 ref 1021 1090 1161 1213 1310 4783 4985 5202 6292 6431 6459 ext_ptr 1(18) based bit(18) level 2 packed packed unaligned dcl 12-25 set ref 10773* ext_ref based pointer array level 2 packed packed unaligned dcl 478 set ref 1669 1669 1669 1675 1675 1678 1715 1718* 1729* 10662 external 10(31) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1298 1382 1491* 3178 3932 5721 5764 9430 external constant fixed bin(4,0) initial dcl 3-120 in procedure "ext_code_generator" ref 1298 1387 5384 external_list based structure level 1 dcl 478 factor 000575 constant fixed bin(18,0) initial array dcl 886 in procedure "get_size_in_words" ref 893 893 factor 000571 constant fixed bin(18,0) initial array dcl 905 in procedure "get_size_in_bits" ref 908 final_text_offset 11 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 701* first 13 based fixed bin(18,0) array level 3 in structure "subprogram" packed packed unsigned unaligned dcl 1-753 in procedure "ext_code_generator" set ref 1065* 1140* 1170* 1233* 1468* 1597 1603 2166 10206 10214 10225 10279 first parameter fixed bin(18,0) dcl 5926 in procedure "get_free_reg" ref 5921 5940 first_auto_loc 000640 constant fixed bin(9,0) initial dcl 3-68 ref 956 first_auto_var_loc 000304 automatic fixed bin(18,0) dcl 483 set ref 1562* 2666 2676 2677 10260 10260 10263 first_base 000736 constant fixed bin(18,0) initial dcl 2385 set ref 6002 6023* 6038* 6061* 6073* 6416 6427* 6486 6496* 6525 6535* 6588 6611* 6892 6921 7025 first_block_constant defined fixed bin(18,0) dcl 4-153 set ref 623* 792 first_char_constant defined fixed bin(18,0) dcl 4-149 set ref 601* 626* first_constant 100 based fixed bin(18,0) array level 3 dcl 53 set ref 9-89 9-89* 599 599 600 600 601 601 623 623 624 624 625 625 626 626 792 792 first_dw_constant defined fixed bin(18,0) dcl 4-145 set ref 599* 624* first_element 3(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-436 ref 1055 1609 1755 1794 1915 2172 6958 10281 10314 10902 first_entry_name 75 based fixed bin(18,0) level 2 dcl 53 ref 977 1392 9478 10999 first_header 000200 automatic pointer initial dcl 436 set ref 436* 1853 1858 1870 1870* 1963 2066 2069* 2069 2069* 2070 2071* 2071* 2077 first_index 000736 constant fixed bin(18,0) initial dcl 2385 set ref 6663 6675* 6743* 6749* 6815* 6929 6999 8071 first_label 4 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1003 first_lib_name 1 based fixed bin(18,0) level 2 unsigned dcl 58 ref 641 651 first_namelist 000176 automatic fixed bin(18,0) dcl 435 set ref 588* 704 1288* first_namelist_symbol 14 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 704* first_polish 5 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 9837 first_subprogram 72 based fixed bin(18,0) level 2 dcl 53 ref 993 1591 2159 2621 10201 10238 10258 first_symbol 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1244 3828 first_time 003604 automatic bit(1) dcl 7759 set ref 7765* 7772 7802* first_word_constant defined fixed bin(18,0) dcl 4-141 set ref 600* 625* first_xr parameter fixed bin(18,0) dcl 6772 ref 6765 6780 fixed builtin function dcl 569 ref 722 723 1361 1361 1705 1705 1708 1708 1711 1711 1715 1715 1812 1816 1886 1886 1889 1889 2024 2025 2136 2136 2251 2251 2708 2744 2959 3212 3693 3738 3763 3766 3779 3781 3791 4166 4176 4542 4850 5166 5166 5234 5260 5260 5389 5498 5516 5516 5563 5594 5594 5603 5603 5640 5640 5676 5690 5690 5710 5710 5909 6659 6812 6831 7045 7066 8235 8235 8276 8689 8689 8697 8808 8871 9325 9326 9867 9867 9894 9894 10093 10312 10325 10624 10785 10821 10825 10875 10897 10897 flag 000321 automatic bit(1) initial array level 2 packed packed unaligned dcl 552 set ref 552* flags 1(18) based structure level 2 in structure "definition" packed packed unaligned dcl 26-12 in procedure "generate_definition" flags 1(18) based bit(18) level 2 in structure "def_header" packed packed unaligned dcl 10611 in procedure "init_linkage" set ref 10632* flags 0(18) based structure level 2 in structure "create_entry" packed packed unaligned dcl 18-23 in procedure "code_generator" flags 0(05) based structure level 2 in structure "proc_frame" packed packed unaligned dcl 2510 in procedure "interpreter" set ref 4540* flags 1(18) based structure level 2 in structure "definition" packed packed unaligned dcl 27-12 in procedure "gen_entry_defs" format 0(30) based bit(1) level 4 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" ref 11045 format 12 based structure level 2 in structure "object_map" dcl 13-10 in procedure "code_generator" format_var 4 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-530 ref 11048 fort_cg_macros_$abort_list 000014 external static bit(36) dcl 2361 set ref 8808 fort_cg_macros_$error_macro 000016 external static bit(36) dcl 2361 set ref 8276 fort_cg_macros_$first_scan 000012 external static bit(36) dcl 2361 set ref 2707 2708 fort_cg_macros_$interpreter_macros 000020 external static structure array level 1 dcl 2367 fort_cg_macros_$operator_table 000022 external static structure array level 1 dcl 2371 fort_cg_macros_$single_inst 000026 external static structure array level 1 dcl 2395 ref 5062 5078 5095 5109 5122 fort_instruction_info_$fort_instruction_info_ 000024 external static structure array level 1 dcl 2375 fort_make_symbol_section 000010 constant entry external dcl 65 ref 706 fortran_declared based structure level 1 dcl 5-91 fortran_options based structure level 1 dcl 5-40 forward based bit(18) level 2 packed packed unaligned dcl 26-12 set ref 10959* 10961* forward_refs based structure array level 1 dcl 497 set ref 630 found_error 004272 automatic bit(1) initial packed unaligned dcl 9579 in procedure "rhs_fld" set ref 9579* 9585* 9591* 9597* 9599 found_error 004314 automatic bit(1) initial packed unaligned dcl 9688 in procedure "lhs_fld" set ref 9688* 9695* 9701* 9707* 9713* 9715 fptype 000337 automatic fixed bin(1,0) initial dcl 561 set ref 561* 9263 9267 9941 9945 10098 10102 free_reg 000124 automatic fixed bin(3,0) dcl 6565 set ref 6587* 6589* 6611* free_temps 000305 automatic fixed bin(18,0) array dcl 484 set ref 589* 589* 589* 3576* 3576* 3576* 4669 4673* 4681 4687* 4705 4706* 4888 4921 4922* 9839 9840 9842 9846 9847* from_base_man 000637 automatic bit(1) dcl 2356 set ref 2703* 5635 6236* 6344* ft2 0(30) based bit(6) level 2 packed packed unaligned dcl 12-11 set ref 10782* ft_char_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 552 ft_complex_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 ft_double_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 ft_external_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 552 ft_hex_complex_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 ft_hex_double_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 ft_hex_real_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 ft_integer_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 552 ft_logical_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 552 ft_real_dtype constant fixed bin(17,0) initial dcl 19-96 ref 552 full_pointer based pointer dcl 10197 set ref 10209* func 0(05) based bit(1) level 3 packed packed unaligned dcl 2510 set ref 2869 2879 2978 3649 4542* function constant fixed bin(18,0) initial dcl 2447 ref 2959 4542 gap_value constant fixed bin(17,0) initial dcl 3-57 ref 10390 10408 10536 general 6(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-844 set ref 9195 9218 9379 9381 9387* 9411 9486 9489* 9489 9496 10031* 10088 generate_long_profile 000224 automatic bit(1) dcl 441 set ref 750* 1574 4191 7596 10245 generate_profile 000225 automatic bit(1) dcl 441 set ref 749* 1571 3708 4191 10245 generate_symtab 000226 automatic bit(1) dcl 441 set ref 751* 1482 1631 getlp 000452 constant fixed bin(18,0) initial dcl 22-16 set ref 3283* 6631* 6906* grow parameter bit(18) dcl 10694 ref 10691 10724 10768 10769 grow_info 004622 automatic bit(18) dcl 10860 set ref 10886* 10887 10925 grow_pt 004612 automatic pointer dcl 10854 set ref 10887* 10888 10898 10914 10915 h 000100 automatic pointer dcl 10303 in procedure "list_initialize" set ref 10308* 10309 10314 h 004416 automatic pointer dcl 10194 in procedure "initialize_static" set ref 10207* 10208 10210 10215* 10216 10221 10226* 10227 10232 h 004434 automatic pointer dcl 10273 in procedure "initialize" set ref 10280* 10281 10281 10287* 10288 h parameter pointer dcl 1783 in procedure "create_storage_entry" set ref 1775 1792* 1794 1794 1797 1801 1805 1826 1859 1881 1886 1886 1886 1886 1886 1886 1889 1889 1891 1891 1915 2087 h 000110 automatic pointer dcl 939 in procedure "assign_storage" set ref 1017* 1018 1020 1021 1022 1026 1030 1035 1036 1045 1046 1051* 1055 1060 1074 1075 1085* 1086 1088 1089 1090 1091 1093 1093 1095 1101 1101 1102 1105 1106 1108 1111* 1117 1120 1120 1128 1128 1132 1133* 1134 1149 1150 1157* 1158 1160 1161 1162 1166 1166* 1179 1180 1187* 1188 1193 1196 1198 1203 1208 1209 1213 1214 1215 1217 1218 1220 1221 1222 1238 1239 1598* 1599 1599 1600 1604* 1606 1608 1608 1609 1616 1616* 1618 1620 1755 1757 1758 1759 1762 1765 1767 2167* 2169 2171* 2172 2181* 2182* 2182 2182 2184 h parameter pointer dcl 2096 in procedure "make_create_entry" ref 2093 2104 2105 2105 2107 2110 2111 2112 2113 2114 2116 2117 2119 2120 2125 h 004606 automatic pointer dcl 10854 in procedure "initialize_common" set ref 10869* 10872 10875 10878 10879 10883 10892 10897 10897 10902 h_bound 2 000117 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 9912 in procedure "make_symbol_descriptor" set ref 9985* 10001* 10003* 10005* h_bound 2 004354 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 10060 in procedure "make_entry_descriptor" set ref 10142* 10158* 10160* 10162* half based structure level 1 dcl 2598 half_array 1 based fixed bin(17,0) array level 2 packed packed unaligned dcl 2527 ref 2842 3125 3137 3143 3253 has_address 0(35) based bit(1) level 3 packed packed unaligned dcl 1-155 set ref 5601 7964* 8269* has_array_size 0(24) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 2231* 8313 8317* has_dim_sizes 0(25) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 2256 2266* has_virtual_origin 0(23) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 2244* 8338* 8401* 8408 8412* hash_chain 3(18) based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 981* 1249* 1265* 1768* 3841 3841 3843 3844 3985* 8297 9157 9216 9256 9256 9936 9936 10043* 10083 10085 10176* hash_chain 3(18) based fixed bin(18,0) level 2 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "ext_code_generator" set ref 9-69 9-78* hash_index 000105 automatic fixed bin(17,0) dcl 9-24 set ref 9-57* 9-61 9-76 9-76 hash_table based fixed bin(35,0) array dcl 9-25 set ref 9-61 9-76 9-76* hash_table_size 056072 constant fixed bin(17,0) initial dcl 9-26 ref 9-57 hast based structure level 1 unaligned dcl 2527 have_vsum 003605 automatic bit(1) dcl 7759 set ref 7766* 7780 7787 7790* 7797 7814 7817* 7829 7832* 7837 7841* 7847 7873 7923 7948* 7952 8053* 8079* 8193 8196* 8213 8249 8748 8750* hbound builtin function dcl 9-27 in procedure "create_constant" ref 9-43 hbound builtin function dcl 569 in procedure "code_generator" ref 630 2993 2993 3899 4376 4378 6982 7128 7196 7202 7245 7393 9839 10819 10909 hdr parameter fixed bin(18,0) dcl 10298 in procedure "list_initialize" ref 10295 10308 hdr 000126 automatic fixed bin(18,0) dcl 940 in procedure "assign_storage" set ref 1015* 1016 1017 1060* 1065 1067 1068 1074* 1083* 1084 1085 1134* 1140 1142 1143 1149* 1155* 1156 1157 1170 1172 1173 1179* 1185* 1186 1187 1233 1235 1236 1238* 1597* 1597* 1598* 1603* 1603* 1604* 2166* 2166* 2167* hdr 004441 automatic fixed bin(18,0) dcl 10274 in procedure "initialize" set ref 10279* 10279* 10280* hdr 004413 automatic fixed bin(18,0) dcl 10193 in procedure "initialize_static" set ref 10206* 10206* 10207* 10214* 10214* 10215* 10225* 10225* 10226* hdr 000110 automatic pointer dcl 1837 in procedure "create_storage_entry" set ref 1858* 1858* 1859* 1861 1865 1870 1872 1873 1879 1881 1886 1891 1891 1898* 1898* 1899 1903 1905 1906 1913 1936 1937 1938 1939 1940 1992* 1992* 1993 1994 1994 1995 1995* 1997 2003* 2003 2003* 2004* 2028 2073* 2074 2075 2086* 2087 2088 2088 2089 2090 head_address based fixed bin(35,0) dcl 10702 set ref 10781* header 001516 automatic structure level 2 in structure "arg_list" dcl 2602 in procedure "interpreter" set ref 3937* header based structure level 1 dcl 1-436 in procedure "ext_code_generator" header 6 based bit(1) level 2 in structure "entry" packed packed unaligned dcl 1846 in procedure "create_storage_entry" set ref 1898 1939* 1992 2090* header_length 000104 automatic fixed bin(24,0) dcl 1663 set ref 1682* 1684* 1686* 1688 1688 1694* 1696* 1698* 1700 1703 1705 1705 1708 1708 1711 header_node constant fixed bin(4,0) initial dcl 3-87 ref 1606 1675 1731 2169 10281 hfp 12(04) based bit(1) level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "ext_code_generator" ref 4295 hfp 114(04) based bit(1) level 4 in structure "shared_globals" packed packed unaligned dcl 53 in procedure "ext_code_generator" ref 561 i 004510 automatic fixed bin(18,0) dcl 10657 in procedure "gen_linkage" set ref 10661* 10662 10678 10678* i 000217 automatic fixed bin(18,0) dcl 2222 in procedure "get_array_size" set ref 2238* 2239 2240* 2251* 2258* 2259 2259 2259 2259 2262 2262 2262 2262 2264* i 000100 automatic fixed bin(3,0) dcl 6481 in procedure "base_man_load_arg_ptr" set ref 6486* 6487 6487 6489 6491 6492* 6496* 6497* 6503 6505 6506 6507 6508 6510 i 003204 automatic fixed bin(3,0) dcl 6356 in procedure "base_man_load_pr_value" set ref 6362* 6366 6366 6366 6375* 6382 6386 6387 6388 6391 i 000106 automatic fixed bin(3,0) dcl 5992 in procedure "base_man_load_any_pr" set ref 6002* 6003 6003 6005 6005 6005 6009 6010 6012* 6023* 6024* 6025 6038* 6039* 6049* 6051 6061* 6062* 6063 6073* 6074* 6081 6085 6088 6089 6090 6091 6093 i 003231 automatic fixed bin(3,0) dcl 6775 in procedure "const_in_xr" set ref 6780* 6781 6781 6783 6783 6786* i 003344 automatic fixed bin(18,0) dcl 7018 in procedure "flush_addr" set ref 7025* 7025* 7026 7026 7026* 7029 i parameter fixed bin(3,0) dcl 6191 in procedure "flush_base" ref 6186 6194 6196 6206 i 000122 automatic fixed bin(3,0) dcl 6520 in procedure "base_man_load_desc_ptr" set ref 6525* 6526 6526 6528 6530 6531* 6535* 6536* 6542 6544 6545 6546 6547 6549 i 004572 automatic fixed bin(18,0) dcl 10805 in procedure "name_assign" set ref 10819* 10820* i 003107 automatic fixed bin(18,0) dcl 5439 in procedure "emit_eis" set ref 5447* 5448 5448 5449 5449 5450 5450 5451* 5483* 5487 5487 5489 5489 5494 5496 5496 5498 5500 5502 5502 5505 5509 5510 5514 5516 5516 5516* 5519 5519 5519 5519 5519 5523 5524* i 000104 automatic fixed bin(17,0) dcl 1787 in procedure "create_storage_entry" set ref 2002* 2005* 2005 2007 2017 2018 2024 i 000121 automatic fixed bin(18,0) dcl 5753 in procedure "m_a_check_large_address" set ref 5768* 5770 5770* i 000100 automatic fixed bin(3,0) dcl 5930 in procedure "get_free_reg" set ref 5940* 5942 5944 5944 5946 5948 5949* i 003445 automatic fixed bin(18,0) dcl 7366 in procedure "load" set ref 7396* 7396* 7397* i 004146 automatic fixed bin(18,0) dcl 9314 in procedure "set_itp_addr" set ref 9317* 9319 9323 9324 9325 9326 9331 9334 i parameter fixed bin(3,0) dcl 6102 in procedure "base_man_load_VLA" ref 6097 6164 6166 6170 6172 6176 i 000130 automatic fixed bin(18,0) dcl 940 in procedure "assign_storage" set ref 1032* 1040* 1065 1065 1067 1068 1110* 1119* 1126* 1140 1140 1142 1143 1193* 1195* 1196* 1196 1198* 1198 1203 1203 1203 1207 1208 1208 1209 1209 1209 1229* 1233 1233 1235 1236 1270* 1275* 1277* 1293* 1297* 1418* 1432* 1434* 1435* 1435 1437* 1437 1442 1443 1443 1464* 1468 1468 1470 1471 i 003166 automatic fixed bin(3,0) dcl 6228 in procedure "base_man_load_pr" set ref 6238* 6266* 6279 6279 6283* 6285 6293 6338 6339 6340 6341 6342 i 003300 automatic fixed bin(3,0) dcl 6919 in procedure "reset_regs" set ref 6921* 6923* 6929* 6931 6931 6931* i 004442 automatic fixed bin(18,0) dcl 10274 in procedure "initialize" set ref 10278* 10279* i 000104 automatic fixed bin(18,0) dcl 5658 in procedure "m_a_except_xreg" set ref 5673* 5681* 5695* 5697* 5702* 5705* 5707* 5714* 5716* i 004157 automatic fixed bin(18,0) dcl 9358 in procedure "check_arg_list" set ref 9369* 9370 9371* 9391* 9392 9393 9397 9398 9401 9402* 9420* 9421 9430 9430 9440 9442 9446 9449* 9461 i 003674 automatic fixed bin(3,0) dcl 8567 in procedure "compute_dimension_size" set ref 8569* 8575 8577 8579 8580 8587 8589 8600 8601 8608 8609 8611 8612 8616 8620 8621 8623 8623 8624 8625 8628 8632 8633 8635 8636 8638 8640 i 003120 automatic fixed bin(17,0) dcl 5542 in procedure "get_eis_length" set ref 5545* 5547 5552 5553 5556 5558 5559 5563 5563 5567 5567 5567 5572 i 000277 automatic fixed bin(18,0) dcl 470 in procedure "code_generator" set ref 630* 631 632* 650* 654 655 656 657* 657 11024* 11025 11026* i 003243 automatic fixed bin(3,0) dcl 6804 in procedure "xr_man_add_const" set ref 6808* 6812 i 003266 automatic fixed bin(18,0) dcl 6879 in procedure "free_regs" set ref 6883* 6884 6886 6887 6887* 6892* 6893 6895 6896 6896* 6903* 6904 6904 6907 6910 i 004207 automatic fixed bin(17,0) dcl 9474 in procedure "find_arg_desc" set ref 9498* 9499 9501* 9520 i 000103 automatic fixed bin(3,0) dcl 6656 in procedure "xr_man_load_any_xr" set ref 6663* 6664 6664 6667 6668* 6675* 6677* 6681 6691 6694 6695 6697 6700 i 000101 automatic fixed bin(3,0) dcl 6404 in procedure "base_man_load_large_base" set ref 6416* 6417 6417 6419 6419 6421 6422* 6427* 6429* 6434 6435 6437 6438 6439 6440 6442 i 000100 automatic fixed bin(18,0) dcl 7511 in procedure "reset" set ref 7516* 7516* 7517* i 000142 automatic fixed bin(18,0) dcl 2097 in procedure "make_create_entry" set ref 2136* 2137 i 004326 automatic fixed bin(17,0) dcl 9819 in procedure "start_subprogram" set ref 9839* 9840 9842 9846 9847* i 002604 automatic fixed bin(18,0) dcl 4458 in procedure "get_operand" set ref 4468* 4470 i 004344 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10134* 10136 10139 10141 10141 10142 10142 10143 10153 10153 10153 10155 10158 10158 10158 10160 10160 10162* i 003154 automatic fixed bin(3,0) dcl 5886 in procedure "make_both_addressable" set ref 5889* 5891 5896 5896* i 003312 automatic fixed bin(18,0) dcl 6949 in procedure "flush_ref" set ref 6958* 6958* 6959 6960* i 000164 automatic fixed bin(18,0) dcl 2154 in procedure "relocate" set ref 2163* 2164 2164 2166 2186* 2205 i 003526 automatic fixed bin(18,0) dcl 7627 in procedure "setup_message_structure" set ref 7632* 7641 7642 7649 7650 7651* i parameter fixed bin(18,0) dcl 4372 in procedure "push" ref 4367 4382 i 002667 automatic fixed bin(18,0) dcl 4662 in procedure "get_temp" set ref 4668* 4669 4673 4679* 4698 i 003255 automatic fixed bin(18,0) dcl 6843 in procedure "reserve_regs" set ref 6849* 6850 6850 6853 6860* i 000106 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 9977* 9979 9982 9984 9984 9985 9985 9986 9996 9996 9996 9998 10001 10001 10001 10003 10003 10005* i 004023 automatic fixed bin(17,0) dcl 8929 in procedure "start_cat" set ref 8933* 8934 8934 8935 8935 8935* i 003431 automatic fixed bin(18,0) dcl 7230 in procedure "use_eaq" set ref 7247* 7249 7266* i 000100 automatic fixed bin(18,0) dcl 6711 in procedure "flush_xr" set ref 6717* 6719 6726 6726 i 003216 automatic fixed bin(3,0) dcl 6738 in procedure "xr_man_load_const" set ref 6749* 6751* 6755 6757 6758 6759 6761 i 000111 automatic fixed bin(18,0) dcl 7319 in procedure "save_logical_temps" set ref 7323* 7323* 7325 7325* 7331* 7332 7346* i 000126 automatic fixed bin(3,0) dcl 6565 in procedure "base_man_store_temp" set ref 6588* 6589 6589 6591 6591 6591* 6611* 6614 6616* 6623* 6625 6628* i 003407 automatic fixed bin(18,0) dcl 7186 in procedure "also_in_reg" set ref 7202* 7204 7208* i 003600 automatic fixed bin(18,0) dcl 7758 in procedure "finish_subscript" set ref 7771* 7777 7779 7780 7797 7806 7814 7818* 8373* 8387 8387 8389 8390 8394 8394 8399 8460 8463 8472 8472 8479 8479 8481 8481 8490* 8498 8506 8506 8508 8514 8514 8514 8516 8527* 8542* 8544* 8546* 8546* 8547 8549 8551* i 003706 automatic fixed bin(18,0) dcl 8654 in procedure "finalize_vsum" set ref 8680* 8681 8681 8684* 8686* 8690* 8697* 8699 i 000103 automatic fixed bin(18,0) dcl 1661 in procedure "alloc_external" set ref 1667* 1669 1669 1669* 1674* 1675 1675 1678 1682 1684 1688 1688 1694 1696 1700 1703 1705 1711 1715 1718* i 003330 automatic fixed bin(18,0) dcl 6974 in procedure "flush_simple_ref" set ref 6983* 6983* 6984 6986* 6986 6986* 6987 6987* 6999* 6999* 7001 7001 7001* 7004 i 000602 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 2837* 2839 2839 2842 2882* 2883 2905 2909* 2952* 2952 2952* 2953 2955 2962* 2963 2966* 2967 3016* 3019 3019 3021 3035* 3038 3038 3045* 3047 3111* 3114* 3117* 3120* 3123* 3125 3249* 3251 3251 3253 3314* 3315 3315 3490* 3492* 3493* 3548* 3549* 3593* 3735* 3736 3736 3738 3739* 3747* 3748 3750 3760 3788 3789* 3798* 3799 3803 3805* 3811* 3812 3818* 3884* 3885 3887 3887 3890* 3913* 3914 3916* 3943* 3944 3945* 3962* 3963 3965 3965 3969* identifier 1 based char(8) level 2 dcl 13-10 set ref 716* if_test 0(27) based bit(1) array level 2 packed packed unaligned dcl 2573 ref 3051 3059 3163 3169 3175 3181 3186 3192 3698 3895 4107 4116 4122 4127 4132 4139 4150 4293 ii 004210 automatic fixed bin(17,0) dcl 9474 set ref 9497* 9501 9502 9504 9505 9509 9510 9513 9514 9517* 9517 9520 9525 9526 9527 imac 000572 automatic fixed bin(18,0) dcl 2336 set ref 2708* 2726* 2726 2730 2742 2743 2744 2767 2790 2802 2807 2807 2808* 2808 2825 2842 2844* 2844 2851* 2856* 2856 2857* 2857 2860* 2882 2919* 2929* 2966 2967* 2971 2972* 2986* 2995 2996* 3003* 3019 3021 3038 3047 3051 3059 3094 3096 3125* 3125 3137* 3137 3143* 3143 3158 3163 3169 3175 3181 3186 3192 3208 3212 3241* 3253* 3253 3257* 3257 3257* 3259* 3326 3377 3393 3400 3439* 3449 3466 3471 3479 3516 3597* 3655* 3661* 3693 3698 3895 4000 4071* 4107 4116 4122 4127 4132 4139 4150 4293 4504* 4504* 4509* 5034 5034 5041 5042 5044 5443* 5443 5448 5450 5462 5479 5484* 5484 5516 5516 5547 5563 7630 7633* 7633 7635 7642 7650 7651 8276* 8808* image based fixed bin(18,0) array dcl 465 set ref 776* 776 in_a constant fixed bin(18,0) initial dcl 2412 ref 3406 7305 7412 7421 8579 8580 8600 8601 8620 8621 8632 8633 in_common 0(35) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1108 2105 2112 in_common 11(02) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 5700 6151 in_deaq constant fixed bin(18,0) initial dcl 2412 ref 3485 3485 in_eaq constant fixed bin(18,0) initial dcl 2412 ref 3485 in_equiv_stmnt 11(08) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 6954 in_ia constant fixed bin(18,0) initial dcl 2412 set ref 7080 7092 7094 8681 8686 9660* 9665* 9771 9787 9802 in_ind constant fixed bin(18,0) initial dcl 2412 ref 3094 3094 3154 7167 7298 7370 7384 7407 7441 in_iq constant fixed bin(18,0) initial dcl 2412 ref 9774 9790 9806 in_q constant fixed bin(18,0) initial dcl 2412 set ref 3832 3843 3844 5006* 6161 7078 7090 7096 7109 7400 7400 7547 8148* 8160* 8169* 8179* 8346* 8348* 8424* 8427* 8428* 8436* 8439* 8443* 8460 8463 8472* 8500 8505* 8514* 8516* 8522* 8534* 8547 8549 8551 8608* 8609 8612* 8623* 8625* 8635* 8636 8640* 8660* 8681 8684 8705 8755* 9125* 9130* 9175 9177 9196 9289* 9292 in_tq constant fixed bin(18,0) initial dcl 2412 set ref 7400 7400 9610* 9628* 9648* 9742* 9743* 9751* 9754* inc parameter fixed bin(18,0) dcl 5217 in procedure "put_word" ref 5211 5238 5246 5246 5260 5262 5262 5266 5267 inc parameter fixed bin(18,0) dcl 5277 in procedure "text_ref" ref 5271 5308 5377 5393 5393 inc 003102 automatic fixed bin(18,0) array dcl 5427 in procedure "emit_eis" set ref 5450* 5456* 5509 5519 5519 5523 5524 inc parameter fixed bin(18,0) array dcl 5885 in procedure "make_both_addressable" set ref 5878 5896 5896* inc 003020 automatic fixed bin(18,0) dcl 5032 in procedure "emit_inst" set ref 5041* 5044* inc parameter fixed bin(18,0) dcl 5783 in procedure "increment_address" ref 5778 5788 5792 inc parameter fixed bin(18,0) dcl 844 in procedure "assign_address_offset" ref 837 848 inc 003030 automatic fixed bin(18,0) dcl 5058 in procedure "emit_single" set ref 5060* 5062* 5075* 5078* incr parameter fixed bin(18,0) dcl 5073 ref 5068 5075 increment 0(04) 000026 external static fixed bin(13,0) array level 2 in structure "fort_cg_macros_$single_inst" packed packed unaligned dcl 2395 in procedure "interpreter" ref 5060 5124 5124 5128 5166 increment 0(04) based fixed bin(13,0) array level 2 in structure "machine_instruction" packed packed unaligned dcl 2538 in procedure "interpreter" set ref 5041 5450 ind_to_a 000524 constant fixed bin(18,0) initial array dcl 22-16 ref 7298 ind_word based bit(36) dcl 2477 set ref 9334* index 000122 automatic fixed bin(18,0) dcl 10457 in procedure "list_initialize_symbol" set ref 10480* 10526* 10526 10543 10548 10553 10558 index parameter fixed bin(18,0) dcl 6949 in procedure "flush_ref" set ref 6942 6952* 6953 index builtin function dcl 569 in procedure "code_generator" ref 10678 10728 index 004456 automatic fixed bin(18,0) dcl 10335 in procedure "initialize_symbol" set ref 10359* 10407 10410* 10410 10420 10424 10428 10432 index_regs 37 001334 automatic structure array level 2 dcl 2479 set ref 6675* 6749* 6815* indicators_valid 35 001334 automatic fixed bin(18,0) level 2 dcl 2479 set ref 3160 3456 3459* 3482 3499* 3501* 3518* 4003* 7105* 7175* 7177* 7310* 7412 7425* indx1_constant 003621 automatic bit(1) dcl 8024 set ref 8037* 8040* 8089 8101 8117 8190 8213 indx1_value 003626 automatic fixed bin(35,0) dcl 8027 set ref 8038* 8101 8101 8124 8137 8149 8149 8190 indx2_constant 003622 automatic bit(1) dcl 8024 set ref 8044* 8047* 8089 8108 8117 8154 indx2_value 003627 automatic fixed bin(35,0) dcl 8027 set ref 8045* 8108 8108 8124 8160 inhibit 0(28) based bit(1) array level 2 packed packed unaligned dcl 2531 set ref 2730 init 0(24) based bit(1) level 3 packed packed unaligned dcl 18-23 set ref 2116* init_auto_to_zero 000231 automatic bit(1) dcl 441 set ref 752* 2677 init_info based structure level 1 dcl 25-30 init_pt 004614 automatic pointer dcl 10854 in procedure "initialize_common" set ref 10888* 10897 10897 10904* init_pt parameter pointer dcl 10332 in procedure "initialize_symbol" ref 10329 10358 init_pt parameter pointer dcl 10443 in procedure "list_initialize_symbol" set ref 10440 10567 10568 10569* 10569 10571 10572 10575 10579 10583 10588 10593* 10593 10593 init_val 004616 automatic fixed bin(18,0) dcl 10855 set ref 10890* 10896* 10901* 10909 10915 10921 10923 initial 13(07) based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 987* 1258 1285 1414* 1616 3178 3582* 3587 3932 3934 5384 5721 5727 10389 10395 10511 10516 10663 10904 11051 initial 004463 automatic structure level 1 dcl 10337 in procedure "initialize_symbol" initial 000127 automatic structure level 1 dcl 10460 in procedure "list_initialize_symbol" initial_in_polish based structure level 1 dcl 10342 in procedure "initialize_symbol" initial_in_polish based structure level 1 dcl 10465 in procedure "list_initialize_symbol" initialed 0(29) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1060 1134 1196 1715 1715 2116 10309 10681 10875 10879* 10883 10892 initialed 0(29) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1435 10284 10317 inst 003046 automatic structure level 1 dcl 5200 in procedure "emit_operator_call" set ref 5202* 5206 inst parameter structure level 1 dcl 5217 in procedure "put_word" ref 5211 5230 5251 inst_address 000123 automatic structure level 1 packed packed unaligned dcl 6564 in procedure "base_man_store_temp" set ref 6571* 6580 6580 6601 6601 6617 6617 6629 6629 inst_address 000100 automatic structure level 1 dcl 5860 in procedure "c_a_18" set ref 5867* 5874 inst_address 000104 automatic structure level 1 dcl 6406 in procedure "base_man_load_large_base" set ref 6431* 6434 6434 inst_address 003172 automatic structure level 1 dcl 6231 in procedure "base_man_load_pr" set ref 6292* 6302 6302 6311 6311 6313 6313 6321 6321 6330 6330 inst_address 001330 automatic structure level 1 dcl 2465 in procedure "interpreter" set ref 3768* 3771 3771 3777 3777 7939* 7942 7942 inst_address 000101 automatic structure level 1 dcl 5807 in procedure "c_a" set ref 5810* 5847 inst_address 000110 automatic structure level 1 packed packed unaligned dcl 6457 in procedure "base_man_load_large_base_no_flush" set ref 6459* 6462 6462 inst_address based structure level 1 packed packed unaligned dcl 6104 in procedure "base_man_load_VLA" inst_number 003470 automatic fixed bin(18,0) dcl 7534 set ref 7541* 7543* 7545* inst_pos 003110 automatic fixed bin(18,0) dcl 5439 set ref 5478* 5487 5489 instruction based fixed bin(17,0) array level 2 in structure "forward_refs" packed packed unaligned dcl 497 in procedure "code_generator" set ref 631 5390* instruction based structure array level 1 dcl 2581 in procedure "interpreter" int_image based fixed bin(35,0) dcl 2471 ref 4049 5336 5341 8038 8045 int_mode 000737 constant fixed bin(4,0) initial dcl 3-106 set ref 2288 2692 3695* 4047 7664* 8178* 8316 8411 8658* 8687* 8698* 9129* 9183* 9281* 9288* 9544 9582 9588 9692 9698 10013* 10170* integer 10(20) based bit(1) level 5 packed packed unaligned dcl 1-844 set ref 2289* interpreter_called 0(06) based bit(1) level 4 packed packed unaligned dcl 2510 set ref 2921 3653 4506* interpreter_return 6 based label variable local level 2 dcl 2510 set ref 2924 3662 4507* ipol 000573 automatic fixed bin(18,0) dcl 2337 set ref 2933 2933 2939 2939 2940* 2940 2945 2946* 2946 3541* 3541 3541 3703 3706* 3706 3708 9837* is_addressable 0(14) based bit(1) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1221* is_addressable 0(14) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 982* 1103* 1282* 1308* 1378* 1408* 1412* 1456* 1491* 1510* 1541* 2686* 5732* is_addressable 0(14) based bit(1) level 3 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" set ref 2663* is_addressable 0(14) based bit(1) level 3 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" set ref 1005* 2317* is_addressable 0(14) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2674* 7954* 8251* is_addressable 0(14) based bit(1) level 3 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" set ref 9-83* is_addressable 0(14) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4781* 4873* 4980* 5185 is_addressable 0(14) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 869* 3922 5244 5262 5519 5589 5893 6250 6372 6688 7100 is_string 6 based bit(1) array level 4 dcl 58 set ref 7641* 7649* isub 003554 automatic fixed bin(18,0) dcl 7688 set ref 7693* 7701 7701 7706 7706 7728 7728 7733 7733 7735 7738 7738 7740 itp based structure level 1 dcl 16-18 itp_list 2 001516 automatic structure array level 2 dcl 2602 set ref 3899 9319* 9334 itp_mod 2(30) 001516 automatic bit(6) array level 3 in structure "arg_list" packed packed unaligned dcl 2602 in procedure "interpreter" set ref 9324* itp_mod 0(30) based bit(6) level 2 in structure "itp" packed packed unaligned dcl 16-18 in procedure "code_generator" ref 827 831 j 000101 automatic fixed bin(3,0) dcl 5930 in procedure "get_free_reg" set ref 5937* 5949* 5955 5957 j 000300 automatic fixed bin(18,0) dcl 470 in procedure "code_generator" set ref 631* 632 632 j 003256 automatic fixed bin(3,0) dcl 6844 in procedure "reserve_regs" set ref 6853* 6854* 6855 6856 6860* 6861* 6862 6863 6865 6867 j 000107 automatic fixed bin(3,0) dcl 5992 in procedure "base_man_load_any_pr" set ref 6000* 6012* 6015 6020 6022 j 003244 automatic fixed bin(3,0) dcl 6804 in procedure "xr_man_add_const" set ref 6815* 6817* 6819 6827 6828 6829 6831 k parameter fixed bin(3,0) dcl 5926 in procedure "get_free_reg" ref 5921 5933 5933 5933 k 000102 automatic fixed bin(3,0) dcl 6404 in procedure "base_man_load_large_base" set ref 6414* 6417* 6427* k 000110 automatic fixed bin(3,0) dcl 5992 in procedure "base_man_load_any_pr" set ref 6000* 6003* 6023* 6038* 6070* 6073* k 004540 automatic fixed bin(18,0) dcl 10704 in procedure "compile_link" set ref 10728* 10730 10733 10739 10745 k 003217 automatic fixed bin(3,0) dcl 6738 in procedure "xr_man_load_const" set ref 6743* 6745 6746 6749* k 000101 automatic fixed bin(3,0) dcl 6481 in procedure "base_man_load_arg_ptr" set ref 6484* 6487* 6496* k 000603 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 2756* 2758 2890* 2892 2892 2894 3433* 3435 3534* 3535 3538 3738* 3739 3741 3931* 3932 3932* 3932 3934 4280* 4285 k 000123 automatic fixed bin(3,0) dcl 6520 in procedure "base_man_load_desc_ptr" set ref 6523* 6526* 6535* l_bound 1 004354 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 10060 in procedure "make_entry_descriptor" set ref 10141* 10153* 10155* l_bound 1 000117 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 9912 in procedure "make_symbol_descriptor" set ref 9984* 9996* 9998* label based structure level 1 dcl 1-530 set ref 2312 2312 label_node 000725 constant fixed bin(4,0) initial dcl 3-87 set ref 2312* 11045 label_op constant fixed bin(18,0) initial dcl 3-197 ref 3708 large_address 0(20) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 7962* 7962 8261* 8261 large_address 0(20) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4873 5679 6578 large_address 0(20) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 5714 6145 7881 7962 8223 8261 10217 10228 10364 10488 10668 large_address 0(20) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 868* 5758 5788 8204 large_base_reg 000125 automatic fixed bin(3,0) dcl 6565 set ref 6587* 6588 6591* 6597 6599 6600 large_offset 0(34) based bit(1) level 3 packed packed unaligned dcl 1-155 set ref 5610 7890* 7909* 8055 8240* last parameter fixed bin(18,0) dcl 5926 in procedure "get_free_reg" ref 5921 5940 last 13(18) based fixed bin(18,0) array level 3 in structure "subprogram" packed packed unsigned unaligned dcl 1-753 in procedure "ext_code_generator" set ref 1065 1067 1068* 1140 1142 1143* 1170 1172 1173* 1233 1235 1236* 1468 1470 1471* last 004327 automatic fixed bin(18,0) dcl 9820 in procedure "start_subprogram" set ref 9843* 9845 last_assigned_mode constant fixed bin(4,0) initial dcl 3-106 ref 3131 last_assigned_op constant fixed bin(18,0) initial dcl 3-197 ref 2933 last_auto_loc 000302 automatic fixed bin(18,0) dcl 481 set ref 956* 1041 1041* 1041 1045 1047* 1047 1128 1129* 1129 1312 1313* 1313 1317 1322 1323* 1323 1333 1333* 1333 1336 1337* 1337 1338 1514* 1514 1516* 1517* 1517 1518 1545* 1545 1547* 1548 1549* 1549 1550 1562 1566* 1807* 1807 2677 4698 4766 4770* 4943 9827* 9827 9827 9828 9829* 9830* 9830 9831 10997 last_base 000725 constant fixed bin(18,0) initial dcl 2385 set ref 6002 6023* 6038* 6061* 6073* 6416 6427* 6486 6496* 6525 6535* 6588 6611* 6892 6921 7025 last_constant 101 based fixed bin(18,0) array level 3 dcl 53 set ref 9-91 9-93* last_def 000247 automatic bit(18) dcl 467 set ref 10635* 10646 10955 10955 10959 10980* 11013 11014 last_dynamic_temp 161 001334 automatic fixed bin(18,0) level 2 dcl 2479 set ref 4100* 5016* 8952 last_entry_name 76 based fixed bin(18,0) level 2 dcl 53 ref 9479 last_header 000202 automatic pointer initial dcl 436 set ref 436* 1872 1873* last_index 000731 constant fixed bin(18,0) initial dcl 2385 set ref 6663 6675* 6749* 6780 6815* 6883 6929 6999 8071 last_listp 000144 automatic pointer dcl 2098 set ref 2134* 2135 2136 last_namelist 000177 automatic fixed bin(18,0) dcl 435 set ref 588* 1288 1290 1291* last_pos 000170 automatic fixed bin(18,0) dcl 428 set ref 617* 701 last_subprogram 73 based fixed bin(18,0) level 2 dcl 53 ref 2666 last_symbol 3(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 set ref 2293 2294* 10036 10037* lca 000416 constant fixed bin(18,0) initial dcl 22-16 set ref 9654* 9667* lcq constant bit(10) initial dcl 5286 ref 5348 5357 ldq constant bit(10) initial dcl 5286 ref 5348 5357 left based bit(18) array level 2 in structure "reloc_halfs" packed packed unaligned dcl 491 in procedure "code_generator" set ref 827* 831* 1988* 2105* 2107* 2137* 11011* left based fixed bin(17,0) level 2 in structure "half" packed packed unaligned dcl 2598 in procedure "interpreter" ref 5316 5330 5344 left based fixed bin(17,0) array level 2 in structure "text_halfs" packed packed unaligned dcl 487 in procedure "code_generator" set ref 632* 632 4155* 4166* 4170* 4219* 4237* 4285* 5097* 5128* 5128 5238* 5267* 5267 5318* 5330* 5364* 5377* 5393* 5393 5524* 5524 7602* 11005* 11013* 11023 left 000574 automatic fixed bin(18,0) dcl 2339 in procedure "interpreter" set ref 2743* 2777 2782* 2785* 2785* 2794 2812 2814* 2831 2839 2844 2847 2851* 2857* 2860 2863 2929 2966* 2971* 2986 2996 3241 3251 3257 3300 3336* 3345* 3439 3439 3466* 3523 3528 3534 3535 3597 3632 3851 3857* 3861* 3861* 4071 4092 4301 5462 7629 7635* 7636 left based fixed bin(17,0) array level 2 in structure "macro_instruction" packed packed unaligned dcl 2531 in procedure "interpreter" set ref 2743 2857 2962 7635 7651 left_rel 0(12) based bit(6) array level 2 packed packed unaligned dcl 2592 set ref 3739* 4167* 4171* 4220* 4238* 4288* 5146* 5253* 5321* 5332* 5366* 5500* 6076* 6078* 6126* 7603* 7615* len 003076 automatic fixed bin(18,0) array dcl 5425 in procedure "emit_eis" set ref 5468* 5468 5498 5553* 5559* 5563* 5567 5567* len parameter fixed bin(18,0) dcl 10855 in procedure "initialize_common" ref 10851 10870 len 004271 automatic fixed bin(18,0) dcl 9578 in procedure "rhs_fld" set ref 9605* 9606 9606 9608 9625* 9625 9626 9632 9637* 9637* 9642 9662 len parameter fixed bin(18,0) dcl 9560 in procedure "generate_mask" ref 9555 9565 len 004313 automatic fixed bin(18,0) dcl 9687 in procedure "lhs_fld" set ref 9721* 9722 9722 9724 9738* 9738 9740 9749 9749 9755 9760* 9760* 9788* 9791 length builtin function dcl 1790 in procedure "create_storage_entry" ref 1988 2105 2107 2137 length 12 based fixed bin(24,0) level 2 in structure "temporary" dcl 1-1005 in procedure "ext_code_generator" set ref 4650* 4822 4828* 5006 9113* 9129* 9889 9891 length 0(24) based bit(12) array level 2 in structure "descriptor" packed packed unaligned dcl 5431 in procedure "emit_eis" set ref 5462 5496* 5498* 5547 5563 length based fixed bin(35,0) level 2 in structure "create_init_entry" dcl 18-61 in procedure "code_generator" set ref 10320* 10568* 10571* 10575 10579 10583 10588 10593 length builtin function dcl 2615 in procedure "interpreter" ref 3019 3038 length 4 based fixed bin(18,0) level 2 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "ext_code_generator" set ref 655 799 804 806 2666* 2679 4022 4025 4028 4035 4038 4041 4060 5304 9549 9870 10428 10432 10583 10588 length builtin function dcl 6845 in procedure "reserve_regs" ref 6849 length builtin function dcl 10811 in procedure "name_assign" ref 10815 10822 10832 length 7 based fixed bin(24,0) level 2 in structure "array_ref" dcl 1-155 in procedure "ext_code_generator" set ref 2677* 2679* 8239* 8848* 8850* 8892 9882 9884 length 6 based fixed bin(24,0) level 2 in structure "header" dcl 1-436 in procedure "ext_code_generator" set ref 1208 1209 1682 1684 1686 1694 1696 1698 1733 1881 1881 1886 1886 1886 1886 1891 1891 1891* 1891 1967 1993* 2117 length parameter fixed bin(17,0) dcl 10-12 in procedure "create_node" ref 10-10 10-20 10-23 10-24 length 1 based fixed bin(24,0) level 2 in structure "create_entry" dcl 18-23 in procedure "code_generator" set ref 2117* length builtin function dcl 10708 in procedure "compile_link" ref 10710 10739 length builtin function dcl 9927 in procedure "make_symbol_descriptor" ref 10029 lib 000301 automatic fixed bin(18,0) dcl 470 set ref 651* 651* 652* lib_list_ptr 000210 automatic pointer dcl 438 set ref 644* 647 648 654 655 lib_pos 000167 automatic fixed bin(18,0) dcl 428 set ref 587* 643* 644 645 684 684 684 lib_pt 000152 automatic pointer dcl 426 set ref 652* 653 658 lib_reloc_ptr 000222 automatic pointer dcl 439 set ref 645* 656 library based structure level 1 dcl 1-605 limit 004461 automatic fixed bin(18,0) dcl 10335 in procedure "initialize_symbol" set ref 10396* 10405* 10405 10407 limit 1 based fixed bin(17,0) level 2 in structure "initial_in_polish" dcl 10342 in procedure "initialize_symbol" ref 10403 limit 1 004463 automatic fixed bin(18,0) level 2 in structure "initial" dcl 10337 in procedure "initialize_symbol" set ref 10403* 10405 limit 1 000127 automatic fixed bin(35,0) level 2 in structure "initial" dcl 10460 in procedure "list_initialize_symbol" set ref 10523* 10525* 10526 limit parameter fixed bin(18,0) dcl 2149 in procedure "relocate" ref 2144 2207 2207 2207 limit 1 based fixed bin(35,0) level 2 in structure "initial_in_polish" dcl 10465 in procedure "list_initialize_symbol" ref 10523 link based structure level 1 dcl 12-11 link_base 000204 automatic pointer dcl 438 set ref 664* 695 10208 10217 10219 10228 10230 10240* 10247 10621 10622 10623 10624 10763 link_base_ptr 000122 automatic pointer level 2 dcl 61 set ref 695* link_begin 6 based bit(18) level 2 packed packed unaligned dcl 12-52 set ref 10622* link_pos 000160 automatic fixed bin(18,0) dcl 428 in procedure "code_generator" set ref 587* 671 700 721 1561* 1567* 1573 1577* 1577 1579* 1579 1581* 1581 1581 1582 1589 1599 1608 1616* 1631* 1634* 1634 1636 1738 1739* 1739 1740 2051 10623 link_pos parameter fixed bin(15,0) dcl 10694 in procedure "compile_link" ref 10691 10763 10764 10781 link_ptr 004532 automatic pointer dcl 10701 set ref 10763* 10781 10782 10785 link_reloc_base 000216 automatic pointer dcl 439 set ref 665* 696 10627 10764 link_reloc_base_ptr 2 000122 automatic pointer level 2 dcl 61 set ref 696* link_reloc_ptr 004536 automatic pointer dcl 10701 set ref 10764* 10783 10786 linkage_length 5(18) based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 721* linkage_offset 5 based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 720* linkage_pad 000303 automatic fixed bin(18,0) dcl 482 set ref 965* 1033 1033* 1033 1035 1037* 1037 1120 1122* 1122 1561 1805* 1805 1983 1984* 1984 2019* 2019 linkage_section_lng 6(18) based bit(18) level 2 packed packed unaligned dcl 12-52 set ref 10623* linkrel 000164 automatic fixed bin(18,0) dcl 428 set ref 663* 664 665 671 720 722 list 113(10) based bit(1) level 5 packed packed unaligned dcl 53 ref 592 list_init_info based structure level 1 dcl 25-41 list_size 2(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 25-41 set ref 10898* listing 113(07) based structure level 4 packed packed unaligned dcl 53 listp 000102 automatic pointer dcl 1786 set ref 1800 1800 1801 1803 1803 1812 1812 1823 1986 2017 2018 2024 2030 2050* 2051 2051 2051 2053 2100* 2104 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2120 2123 llr 000426 constant fixed bin(18,0) initial dcl 22-16 set ref 7945* lng 1(18) based fixed bin(17,0) array level 3 packed packed unaligned dcl 503 set ref 655* load_base 000563 constant fixed bin(18,0) initial array dcl 22-16 ref 6025 6051 6063 6081 6164 6170 6279 6285 6382 6434 6462 6503 6542 load_inst 000551 constant fixed bin(18,0) initial array dcl 22-16 set ref 3832 3843 7103* 7439 8547* 8549* 8579* 8600* 8620* 8632* 9175 9771* 9774* 9787* 9790* 9802* 9806* load_packed_base 000435 constant fixed bin(18,0) initial array dcl 22-16 ref 6176 load_segment_num 000427 constant fixed bin(18,0) initial array dcl 22-16 ref 6166 6172 loc 000102 automatic fixed bin(18,0) dcl 1660 in procedure "alloc_external" set ref 1678* 1721 1738* 1743 loc 000133 automatic fixed bin(18,0) dcl 941 in procedure "assign_storage" set ref 1207* 1214 1442* 1453 loc 000100 automatic fixed bin(18,0) dcl 859 in procedure "set_address_offset" set ref 867* 871 loc 000165 automatic fixed bin(18,0) dcl 2154 in procedure "relocate" set ref 2156* 2164 2171* 2175* 2182* 2186* 2189* 2189 2189 2193 2205 2207 loc 002714 automatic fixed bin(18,0) dcl 4745 in procedure "create_temp" set ref 4766* 4768 4770 4796* loc 003144 automatic fixed bin(18,0) dcl 5786 in procedure "increment_address" set ref 5792* 5794 loc_p 000100 automatic pointer dcl 6101 set ref 6136* 6138* 6145 6145 6145 6147 6151 6151 location based fixed bin(18,0) level 2 in structure "create_entry" packed packed unsigned unaligned dcl 18-23 in procedure "code_generator" set ref 2104* location 5 based fixed bin(24,0) level 2 in structure "temporary" dcl 1-1005 in procedure "ext_code_generator" set ref 5679 6591 6616 6628 location 5 based fixed bin(24,0) level 2 in structure "header" dcl 1-436 in procedure "ext_code_generator" set ref 1035* 1045* 1120* 1128* 1132 1166* 1214* 1678 1762 1765 1797 1801 1983* 1986* 1994* 2104 10208 10678 10681 location 1 based fixed bin(18,0) level 3 in structure "label" packed packed unsigned unaligned dcl 1-530 in procedure "ext_code_generator" set ref 632 1281* 3314 7584* 11001 11026 location 5 based fixed bin(24,0) level 2 in structure "node" dcl 1-63 in procedure "ext_code_generator" set ref 848 871* 1599* 1599 1608* 1608 2203 5714 5716 5768 5792 5794* 6145 8204 location 5 based fixed bin(24,0) level 2 in structure "symbol" dcl 1-844 in procedure "ext_code_generator" set ref 1324* 1324 1336* 1344* 1344 1369 1404* 1453* 1496* 1669 1762* 1765* 3791 3791 3837 3837 5716 7881 7884 8223 9174* 10219 10230 10364 10484 10488 10668 location 1(18) based bit(18) level 2 in structure "statement" packed packed unaligned dcl 1-721 in procedure "ext_code_generator" set ref 3705* location 000124 automatic fixed bin(18,0) dcl 1959 in procedure "create_storage_entry" set ref 1983* 1989 1995 2007 2047* 2050 2053* 2054 location 1 based fixed bin(18,0) level 3 in structure "constant" packed packed unsigned unaligned dcl 1-256 in procedure "ext_code_generator" set ref 775* location 1 based fixed bin(18,0) level 3 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "ext_code_generator" set ref 654 805* 2664* location 000111 automatic fixed bin(18,0) dcl 6105 in procedure "base_man_load_VLA" set ref 6145* 6147* 6149* 6151* 6153* locn parameter fixed bin(18,0) dcl 2149 set ref 2144 2156 2193* logical_mode 000733 constant fixed bin(4,0) initial dcl 3-106 set ref 2647* long_profile 12(02) based bit(1) level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "ext_code_generator" ref 750 long_profile 000350 constant fixed bin(14,0) initial dcl 2433 in procedure "interpreter" set ref 4218* 4236* 7598* long_profile_entry based structure level 1 dcl 8-12 ref 1577 7610 long_profile_header based structure level 1 dcl 8-4 set ref 1576 1577 10248* looping 000112 automatic bit(1) packed unaligned dcl 1838 set ref 1923* 1924 1926* 1928* 2045* 2048 2054* lower 0(09) based bit(1) array level 3 packed packed unaligned dcl 1-383 ref 2262 7701 7733 8335 8394 8472 8479 8577 9996 10153 lower_bound 5 based fixed bin(24,0) array level 3 dcl 1-383 ref 2239 2259 2262 7701 7733 7735 8337 8389 8399 8472 8479 8481 8481 8579 8589 8611 8620 8624 8632 8638 9984 9996 10141 10153 lp defined bit(3) dcl 525 ref 827 1036 1095 1217 1403 1449 1493 3922 5764 5817 5825 6410 lreg 004040 automatic bit(6) dcl 8975 in procedure "continue_cat" set ref 9004* 9007* 9009* 9011* 9013 lreg 003100 automatic bit(6) array dcl 5426 in procedure "emit_eis" set ref 5451* 5469* 5469 5489 5496 5496 5556* 5558* 5567* 5572 lrl constant fixed bin(18,0) initial dcl 22-16 ref 3774 lrs 000420 constant fixed bin(18,0) initial dcl 22-16 set ref 9775* 9791* 9807* ltp 002730 automatic pointer dcl 4812 set ref 4822* 4823 4825 4825 4826* ltrim builtin function dcl 10-17 in procedure "create_node" ref 10-29 10-29 ltrim builtin function dcl 569 in procedure "code_generator" ref 1705 1705 1708 1708 1886 1886 2207 2207 ltrim builtin function dcl 9-28 in procedure "create_constant" ref 9-45 9-45 lused 000102 automatic fixed bin(18,0) dcl 5931 set ref 5938* 5946 5948* lxl0 constant fixed bin(18,0) initial dcl 22-16 set ref 6691 9770* 9786* 9800* lxl1 constant fixed bin(18,0) initial dcl 22-16 set ref 9801* m 004620 automatic fixed bin(18,0) dcl 10856 set ref 10895* 10897* 10898 10923 mac 003716 automatic fixed bin(18,0) dcl 8718 in procedure "add" set ref 8720* 8729* 8735* 8737* mac 003427 automatic fixed bin(18,0) dcl 7229 in procedure "use_eaq" set ref 7263* 7265* 7266* mac 000110 automatic fixed bin(18,0) dcl 7319 in procedure "save_logical_temps" set ref 7343* 7345* 7346* mac 000100 automatic fixed bin(18,0) dcl 5178 in procedure "emit_temp_store" set ref 5182* 5188* mac_base 000566 automatic pointer dcl 2332 set ref 2707* 2730 2742 2743 2744 2767 2790 2802 2807 2807 2825 2842 2857 2882 2959 2962 3019 3021 3038 3047 3051 3059 3094 3096 3125 3137 3143 3158 3163 3169 3175 3181 3186 3192 3208 3212 3253 3259 3326 3377 3393 3400 3449 3466 3471 3479 3516 3693 3698 3895 4000 4107 4116 4122 4127 4132 4139 4150 4293 4542 4595 5034 5034 5041 5042 5044 5448 5450 5462 5479 5516 5516 5547 5563 7630 7635 7642 7650 7651 7651 mac_no parameter fixed bin(18,0) dcl 5178 ref 5172 5182 mac_num parameter fixed bin(18,0) dcl 5141 in procedure "emit_c_a_var" ref 5135 5153 5166 5166 5166 mac_num parameter fixed bin(18,0) dcl 5056 in procedure "emit_single" ref 5051 5060 5062 5068 5078 mac_num parameter fixed bin(18,0) dcl 4497 in procedure "interpreter_proc" ref 4475 4502 mac_num parameter fixed bin(18,0) dcl 5089 in procedure "emit_with_tag" ref 5084 5095 mac_num parameter fixed bin(18,0) dcl 5119 in procedure "emit_c_a" ref 5114 5122 5124 5124 5128 mac_num parameter fixed bin(18,0) dcl 5107 in procedure "emit_zero" ref 5102 5109 mac_proc 002624 automatic fixed bin(18,0) dcl 4524 set ref 4526* 4528* 4542 machine_instruction based structure array level 1 dcl 2538 set ref 2807 2807 3259 5034 5044 5479 machine_state 001334 automatic structure level 1 dcl 2479 set ref 2702* 6936* macro_bits_inst based structure array level 1 dcl 2553 macro_cond_inst based structure array level 1 dcl 2573 macro_dt_inst based structure array level 1 dcl 2547 macro_if_inst based structure array level 1 dcl 2559 macro_instruction based structure array level 1 dcl 2531 set ref 2842 3125 3137 3143 3253 macro_proc parameter fixed bin(18,0) dcl 4591 in procedure "get_nextbase" ref 4586 4595 macro_proc parameter fixed bin(18,0) dcl 4519 in procedure "setup_call" ref 4514 4526 macro_proc 002614 automatic fixed bin(18,0) dcl 4500 in procedure "interpreter_proc" set ref 4502* 4504* 4509 macro_regs_inst based structure array level 1 dcl 2567 main_entry_point_name 56 based varying char(32) level 2 dcl 53 ref 987 main_program constant fixed bin(9,0) initial dcl 3-68 ref 3183 6499 6538 9825 map_ptr based bit(18) dcl 13-38 set ref 733* mask 004105 automatic fixed bin(18,0) dcl 9154 in procedure "get_param_char_size" set ref 9183* 9186* 9194* mask 004254 automatic fixed bin(35,0) dcl 9561 in procedure "generate_mask" set ref 9564* 9565 9567* mask_left constant bit(36) initial dcl 2383 ref 5095 5122 5230 5251 max builtin function dcl 569 ref 9624 9625 9737 9738 max_address_offset constant fixed bin(14,0) initial dcl 565 ref 1317 1317 max_fixed_bin_18 constant fixed bin(18,0) initial dcl 3-58 ref 7983 max_linkage_size 000651 constant fixed bin(18,0) initial dcl 567 set ref 1567* 1582 1582 1582 1636 1636 1636 1740 1740 1740 10875 10878 max_stack_size 000602 constant fixed bin(18,0) initial dcl 566 set ref 1338 1338 1518 1518 1550 1550 1566* 4768 4768 9831 9831 max_template_init_size constant fixed bin(18,0) initial dcl 10863 ref 10875 10892 message_number 4 based fixed bin(18,0) level 3 dcl 58 set ref 7629* message_structure 4 based structure level 2 dcl 58 mf 000342 constant fixed bin(6,0) initial array dcl 5293 in procedure "text_ref" ref 5331 mf 000337 constant fixed bin(6,0) initial array dcl 5437 in procedure "emit_eis" ref 5487 5489 min builtin function dcl 569 ref 9624 9625 9737 9738 misc_attributes 10(28) based structure level 3 packed packed unaligned dcl 1-844 mod builtin function dcl 569 in procedure "code_generator" ref 621 799 870 888 907 1033 1041 1203 1209 1209 1333 1581 1763 2189 10875 10883 mod builtin function dcl 2615 in procedure "interpreter" ref 3739 4248 4559 4639 4698 4943 5793 5841 7897 8244 8997 9827 mod builtin function dcl 9-29 in procedure "create_constant" ref 9-57 mod 3(30) 001516 automatic bit(6) array level 3 in structure "arg_list" packed packed unaligned dcl 2602 in procedure "interpreter" set ref 9331* mod_2_sum 000106 automatic bit(36) dcl 9-30 set ref 9-51* 9-54* 9-57 mode 10(20) based structure level 4 packed packed unaligned dcl 1-844 mode_bits 10 based structure level 3 packed packed unaligned dcl 1-844 mop 000576 automatic fixed bin(18,0) dcl 2341 in procedure "interpreter" set ref 2744* 2746 2851 3375 4323 mop 003060 automatic fixed bin(18,0) dcl 5223 in procedure "put_word" set ref 5234* 5235 mop parameter fixed bin(18,0) dcl 5278 in procedure "text_ref" ref 5271 5308 5398 mopnd 000575 automatic fixed bin(18,0) dcl 2340 set ref 2742* 2748* 2753* 2762* 2835* 2888* 3061* 3088* 3128* 3133* 3165* 3171* 3177* 3188* 3204* 3247* 3264* 3269* 3277* 3294* 3308* 3330* 3339* 3370* 3387* 3447* 3464* 3469* 3474* 3521* 3526* 3531* 3545* 3580* 3585* 3590* 3608* 3665* 3665* 3700* 3929* 4008* 4014* 4019* 4032* 4118* 4141* move_eis constant fixed bin(18,0) initial dcl 2449 set ref 9220* mpy 000456 constant fixed bin(18,0) initial dcl 22-16 set ref 3777 8550* multiplier 3 004354 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 10060 in procedure "make_entry_descriptor" set ref 10136* multiplier 3 000117 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 9912 in procedure "make_symbol_descriptor" set ref 9979* must_be 1(04) based structure array level 3 packed packed unaligned dcl 1-130 n 000100 automatic fixed bin(18,0) dcl 5805 in procedure "c_a" set ref 5809* 5839 5841* 5841 5842 5845 n 000102 automatic fixed bin(18,0) dcl 6482 in procedure "base_man_load_arg_ptr" set ref 6499* 6501* 6503* 6503* n 000220 automatic fixed bin(18,0) dcl 2222 in procedure "get_array_size" set ref 2224* 2232* 2270 n 000156 automatic fixed bin(18,0) dcl 428 in procedure "code_generator" set ref 646* 647 648 712* 713 733 737 n 000530 automatic fixed bin(17,0) dcl 766 in procedure "alloc_constants" set ref 768* 777 n parameter fixed bin(18,0) dcl 5857 in procedure "c_a_18" ref 5851 5869 n 000124 automatic fixed bin(18,0) dcl 6521 in procedure "base_man_load_desc_ptr" set ref 6538* 6540* 6542* 6542* n 004003 automatic fixed bin(18,0) dcl 8868 in procedure "free_array_ref" set ref 8884* 8885 8895* 8896 n 004571 automatic fixed bin(9,0) dcl 10804 in procedure "name_assign" set ref 10821* 10822 10822 10832* 10841 10842 10845 n 004621 automatic fixed bin(18,0) dcl 10856 in procedure "initialize_common" set ref 10870* 10872* 10872 10875 10875 10892 10909 10910 10910 10914 10917 10921 n 000604 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 3726* 3735 3747 3798 3811 3841 3843 3881* 3882 3884 3898* 3899 3913 3940* 3941 3943 3948 3955* 3956 3958 3962 4276* 4279 4284 n 002567 automatic fixed bin(18,0) dcl 4413 in procedure "pop" set ref 4423* 4424 4429* 4430 n 000100 automatic fixed bin(18,0) dcl 5985 in procedure "base_man_load_any_pr" set ref 5996* 6005 6028 6054 6054 6057 6068* 6076 6078 6088 n_args 0(05) based fixed bin(12,0) level 2 in structure "arg_desc" packed packed unaligned dcl 1-130 in procedure "ext_code_generator" set ref 9389* 9413 9416 9416 9498 9525* n_args based fixed bin(18,0) level 2 in structure "parm_desc_ptrs" packed packed unsigned unaligned dcl 515 in procedure "code_generator" set ref 4279* 11024 name parameter fixed bin(18,0) dcl 7186 in procedure "also_in_reg" ref 7181 7191 name parameter fixed bin(18,0) dcl 7364 in procedure "load" ref 7361 7368 name parameter char dcl 10797 in procedure "name_assign" ref 10794 10815 10815 10815 name parameter char dcl 10934 in procedure "generate_definition" set ref 10931 10949* name parameter fixed bin(18,0) dcl 7152 in procedure "in_reg" ref 7147 7157 7165 name 20 based char level 2 in structure "symbol" dcl 1-844 in procedure "ext_code_generator" set ref 987 1395 1395 1636 1669 1669 2207 2207 9479 9479 9484 9484 9831 10670* 11009* name 003367 automatic fixed bin(18,0) dcl 7063 in procedure "eaq_man_load_a_or_q" set ref 7077* 7078 7080 7090* 7092* 7094* 7096* 7103 7105 7107* 7109 name 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 3140 3143 3154 3485 3485 3490 3490 6991* 7132 7165* 7167 7263 7265 7276* 7298 7305* 7343 7345 7400 7400 7400* 7404 7412 7522* 7555 name parameter fixed bin(18,0) dcl 7531 in procedure "store" ref 7527 7537 name_length 14(07) based fixed bin(17,0) level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 987 1395 1395 1526 1636 1669 1669 2207 2207 9479 9479 9484 9484 9831 10670 10670 11009 11009 name_length 4(18) based fixed bin(17,0) level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1675 1675 1680 1859 1859 1886 2119 2120 10678 10678 10678 10681 10681 10683 10683 10878 10878 name_length 2(18) based fixed bin(17,0) level 2 in structure "create_entry" packed packed unaligned dcl 18-23 in procedure "code_generator" set ref 1803 1812 1823 2018 2024 2030 2119* 2120 2120 named_constant 11(06) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1255 1277 11051 namelist 10(34) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1279 namelist_used 115(01) based bit(1) level 4 in structure "shared_globals" packed packed unaligned dcl 53 in procedure "ext_code_generator" ref 751 namelist_used 0(14) based bit(1) level 2 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "ext_code_generator" ref 3194 names 1 based structure array level 2 in structure "saved_lib_list" dcl 503 in procedure "code_generator" names 1 based structure array level 2 in structure "saved_lib_reloc_list" dcl 509 in procedure "code_generator" nargs 002644 automatic fixed bin(18,0) dcl 4593 set ref 4595* 4596 4596* 4598 nb parameter fixed bin(18,0) dcl 4519 ref 4514 4528 4530 ndims 000113 automatic fixed bin(18,0) dcl 9909 in procedure "make_symbol_descriptor" set ref 9932* 9967* 9968 9970 9977 10003 10013 10015 10015 10029 10030 ndims 004350 automatic fixed bin(18,0) dcl 10057 in procedure "make_entry_descriptor" set ref 10080* 10124* 10125 10127 10134 10160 10170 10172 10172 ndims 003634 automatic fixed bin(18,0) dcl 8289 in procedure "finish_subscript" set ref 8309* 8335 8369 8373 8387 8394 8498 8546 8575 need_PS 0(11) based bit(1) level 2 packed packed unaligned dcl 1-753 ref 999 needs_descriptors 0(33) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 1361 1415* 1415 2251 3189 3910 3951 4112* needs_pointer 0(18) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 7954 8251 8852* needs_pointer 0(18) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" ref 5666 needs_pointer 0(18) based bit(1) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1020* 1089* 1160* needs_pointer 0(18) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4872* 4979* needs_pointer 0(18) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1320* 1353* 1356* 1360* 2694* 8852 new 1(18) based bit(1) level 3 packed packed unaligned dcl 26-12 set ref 10963* next 3 based fixed bin(18,0) level 2 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "ext_code_generator" set ref 1600 1620 2184 2203 2203 2293* 10036* 10210 10221 10232 10288 next 2 based pointer level 2 in structure "proc_frame" packed packed unaligned dcl 2510 in procedure "interpreter" set ref 4534 4534 4576* 4581* next 000127 automatic fixed bin(35,0) level 2 in structure "initial" dcl 10460 in procedure "list_initialize_symbol" set ref 10516* 10518 10522 10523 10524* 10524 next based pointer level 2 in structure "entry" dcl 1846 in procedure "create_storage_entry" set ref 1861 1872* 2032 2071 2088* next 3 based fixed bin(18,0) level 2 in structure "temporary" packed packed unsigned unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 3979 4673 4687 4689* 4689 4694 4705* 4727 4792* 4898 4921* 4926* 4926 4927* 9298* 9844 9845* next based fixed bin(17,0) level 2 in structure "initial_in_polish" dcl 10342 in procedure "initialize_symbol" ref 10404 next 004463 automatic fixed bin(18,0) level 2 in structure "initial" dcl 10337 in procedure "initialize_symbol" set ref 10395* 10398 10402 10403 10404* 10404 next 2 based fixed bin(18,0) level 2 in structure "create_entry" packed packed unsigned unaligned dcl 18-23 in procedure "code_generator" set ref 2053 2118* 2135* 2136 next based fixed bin(35,0) level 2 in structure "initial_in_polish" dcl 10465 in procedure "list_initialize_symbol" ref 10524 next 3 based fixed bin(18,0) level 2 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "ext_code_generator" set ref 8831 8904* next_base 000607 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 2950* 2952 2957* 2971* next_base 002625 automatic fixed bin(18,0) dcl 4524 in procedure "setup_call" set ref 4528* 4530* 4547 next_constant 3 based fixed bin(18,0) level 2 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "ext_code_generator" ref 812 next_constant 3 based fixed bin(18,0) level 2 in structure "constant" packed packed unsigned unaligned dcl 1-256 in procedure "ext_code_generator" set ref 9-91* 780 next_free_array_ref 000577 automatic fixed bin(18,0) dcl 2343 set ref 2700* 8823 8829 8831* 8904 8905* next_free_object 43 based fixed bin(18,0) level 2 dcl 53 set ref 737* next_free_operand 42 based fixed bin(18,0) level 2 dcl 53 set ref 10-20 10-22 10-23* 10-23 4559 4561 4562* 4562 4566 4567* 4567 4569 next_free_polish 41 based fixed bin(18,0) level 2 dcl 53 set ref 605 611 630 637* 689* 1634 1634 1667 1674 1727 1729 1733 1734 1736* 1736 5381 5387* 5387 5389 5390 10819 10835 10837* 10837 10838 next_free_temp 47 based fixed bin(18,0) level 2 dcl 53 set ref 4723 4726 4727* 9845 9846* next_header 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-436 set ref 1067* 1074 1075* 1142* 1149 1150* 1172* 1179 1180* 1235* 1238 1239* next_label 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-530 ref 1007 next_library_node 0(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-605 ref 658 next_loc 000202 automatic fixed bin(18,0) dcl 2201 in procedure "relocate_error" set ref 2203* 2205* 2207 next_loc 14 based fixed bin(18,0) array level 3 in structure "subprogram" dcl 1-753 in procedure "ext_code_generator" set ref 1203 1203* 1203 1207 1208* 1208 1209* 1209 1442 1443* 1443 2164* 2164 2186 2205 2666 10263 next_member 7(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-844 set ref 1058 1290* 1612 1771 1819 1941 2177 3595 3601 6962 10286 10319 10906 next_subprogram 1(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1478 1623 2190 3685 10233 10241 10261 next_symbol 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-844 set ref 989 1397 1470* 1474 1475* 9480 11028 nlibs based fixed bin(18,0) level 2 dcl 503 set ref 647* no_value_stored 0(29) based bit(1) level 3 packed packed unaligned dcl 1-316 set ref 2668* node based structure level 1 dcl 1-63 in procedure "ext_code_generator" node 4 based pointer level 2 in structure "entry" dcl 1846 in procedure "create_storage_entry" set ref 1859 1881 1886 1891 1891 1938* 1967 1983 1985* 1986* 1986 1989 1989 1993 1994 1994* 1995 1995 2004 2087* node_offset 000107 automatic fixed bin(17,0) dcl 9-31 set ref 9-61* 9-62 9-63 9-65 9-69* 9-74* 9-76 9-78 9-80 9-89 9-91 9-93 9-95 node_ptr 000110 automatic pointer dcl 9-32 set ref 9-63* 9-65 9-65 9-69 9-78 9-80* 9-81 9-82 9-83 9-84 9-85 node_size 002710 automatic fixed bin(17,0) dcl 4742 set ref 4751* 4761* 4772* node_type 002715 automatic fixed bin(4,0) dcl 4746 in procedure "create_temp" set ref 4750* 4760* 4772 4772* 4786 node_type based fixed bin(4,0) level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 10-25* 1606 1667 1669 1675 1731 2169 3054 3065 3070 3333 3342 3425 3425 3670 3750 3753 3789 3800 3803 3813 3818 3887 3916 3919 3965 4047 4058 4145 4400 4400 4421 4427 4823 5148 5158 5255 5300 5302 5502 5511 5598 5662 5671 5674 5719 5764 6031 6033 6119 6199 6244 6246 6954 7206 7234 7250 7270 7333 7350 7421 8051 8067 8137 8141 8213 8253 8265 8664 8676 8882 8893 9063 9078 9256 9331 9371 9394 9402 9428 9430 9436 9449 9506 9514 9546 9549 9602 9614 9718 9727 9747 9870 9873 9880 9887 10088 10281 10663 11045 11051 node_type based fixed bin(4,0) level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 8833* node_type based fixed bin(4,0) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4729* nop 000453 constant fixed bin(18,0) initial dcl 22-16 set ref 4248* not_found 000134 automatic bit(1) dcl 942 set ref 1391* 1393 1395* 1400 not_in_storage 0(23) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 4016* 6685 6724 7294 7325 7553* not_in_storage 0(23) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4789* 4860* 5190* 6199 6574* 7261 7341 8067 nshort 12 based fixed bin(18,0) level 2 dcl 2510 set ref 2991* 2991 2993 2995 2999 3003 3004* 3004 4548* null builtin function dcl 569 ref 436 436 595 1853 1858 1865 1870 1921 1926 1963 2003 2066 2069 2072 2088 2629 2629 2712 4534 4573 4576 4581 5299 5308 7232 10209 10220 10231 num parameter fixed bin(18,0) dcl 5985 ref 5982 5997 num_args 000117 automatic fixed bin(17,0) dcl 1-150 set ref 9361* 9369 9387 9387 9389 9391 9413 9416 9416* 9420 num_of_lib_names based fixed bin(17,0) level 2 dcl 58 ref 646 number 1 001334 automatic fixed bin(18,0) array level 3 dcl 2479 set ref 3154 3406 6983 6986 6990* 6990 6991 7094 7094 7094 7130 7163* 7196 7198* 7198 7199 7242 7247 7277* 7294 7304* 7323 7331 7384 7396 7516 7523* number_dims 0(08) 000321 automatic fixed bin(3,0) initial array level 2 in structure "descriptor_type_word" packed packed unaligned dcl 552 in procedure "code_generator" set ref 552* number_dims 0(08) 000117 automatic fixed bin(3,0) level 3 in structure "descriptor" packed packed unaligned dcl 9912 in procedure "make_symbol_descriptor" set ref 9968* number_dims 0(08) 004354 automatic fixed bin(3,0) level 3 in structure "descriptor" packed packed unaligned dcl 10060 in procedure "make_entry_descriptor" set ref 10125* number_of_dims 0(05) based fixed bin(3,0) level 2 packed packed unaligned dcl 1-383 ref 2238 2258 7728 7771 8309 8795 9967 10124 number_of_lines 53 based fixed bin(17,0) level 2 dcl 53 ref 593 number_of_operands 5 based fixed bin(17,0) level 3 dcl 58 set ref 7630* 7632 object_base 4 based pointer level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 75 object_base 000104 automatic pointer dcl 44 in procedure "ext_code_generator" set ref 75* 632 632 644 664 672 713 776 806 825 1060 1060 1134 1134 2050 2100 2134 2136 3259 3303 3303 3315 3315 4155 4166 4170 4176 4180 4219 4224 4237 4242 4278 4285 4286 5034 5095 5096 5097 5109 5122 5124 5124 5124 5128 5128 5164 5165 5206 5230 5235 5238 5251 5262 5266 5266 5267 5267 5318 5319 5330 5331 5348 5348 5351 5351 5354 5354 5357 5357 5364 5365 5377 5393 5393 5398 5479 5487 5489 5494 5496 5498 5523 5523 5524 5524 7602 7607 10260 10260 11005 11013 11023 11023 object_map based structure level 1 dcl 13-10 set ref 733 737 object_map_version_2 constant fixed bin(17,0) initial dcl 13-40 ref 715 object_max_len 000114 automatic fixed bin(19,0) dcl 45 in procedure "ext_code_generator" set ref 70* object_max_len 36 based fixed bin(19,0) level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 70 objectname 42 based varying char(32) level 2 dcl 58 ref 590 590 odd 0(31) based bit(1) level 4 packed packed unaligned dcl 1-436 ref 1203 off 000126 automatic fixed bin(35,0) dcl 10458 in procedure "list_initialize_symbol" set ref 10484* 10487* 10488* 10488 10492 10543* 10548* 10553* 10558* 10564 10568 10595 off 000100 automatic fixed bin(18,0) dcl 6401 in procedure "base_man_load_large_base" set ref 6408* 6419 6435* 6435* 6439 off parameter fixed bin(18,0) dcl 859 in procedure "set_address_offset" ref 852 863 off 000102 automatic fixed bin(18,0) dcl 5985 in procedure "base_man_load_any_pr" set ref 5998* 6005 6020 6090 off 004037 automatic fixed bin(18,0) dcl 8974 in procedure "continue_cat" set ref 8994* 8995 8997 8998 8998 9000 off 004462 automatic fixed bin(18,0) dcl 10335 in procedure "initialize_symbol" set ref 10363* 10364* 10364 10367 10371* 10372 offset 6(01) based fixed bin(35,0) level 2 in structure "entry" packed packed unsigned unaligned dcl 1846 in procedure "create_storage_entry" set ref 1928 1936* 2089* offset 0(03) 001330 automatic fixed bin(14,0) level 2 in structure "inst_address" packed packed unaligned dcl 2465 in procedure "interpreter" set ref 3776* 7940* offset 3 001516 automatic bit(18) array level 3 in structure "arg_list" packed packed unaligned dcl 2602 in procedure "interpreter" set ref 9325* offset parameter fixed bin(18,0) dcl 6401 in procedure "base_man_load_large_base" ref 6395 6408 offset 000101 automatic fixed bin(18,0) dcl 859 in procedure "set_address_offset" set ref 863* 865 867 870* 870 871 874 offset 1(03) based fixed bin(14,0) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 8994 8998* 9000* offset 1(03) based fixed bin(14,0) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 874* 5514 5641* 5788* 5788 5792 5795* 6145 6147 6279 8186 8264* 9325 offset 17 based fixed bin(24,0) level 2 in structure "symbol" dcl 1-844 in procedure "ext_code_generator" set ref 1762 1763 1765 1797 1803 1928 1936 2005 2014 2016 2018 7910 offset parameter fixed bin(18,0) dcl 5985 in procedure "base_man_load_any_pr" ref 5982 5998 offset 003145 automatic fixed bin(18,0) dcl 5786 in procedure "increment_address" set ref 5792* 5793* 5793 5794 5795 offset parameter fixed bin(18,0) dcl 6453 in procedure "base_man_load_large_base_no_flush" ref 6446 6463 6463 6469 offset 0(03) 003046 automatic fixed bin(14,0) level 2 in structure "inst" packed packed unaligned dcl 5200 in procedure "emit_operator_call" set ref 5203* offset based fixed bin(24,0) array level 3 in structure "create_entry" packed packed unsigned unaligned dcl 18-23 in procedure "code_generator" set ref 1803* 2018* offset 1 based bit(18) array level 3 in structure "saved_lib_list" packed packed unaligned dcl 503 in procedure "code_generator" set ref 654* offset 1(03) based fixed bin(14,0) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1312* 1322* 1369* 1527* 1527 3781 3781 6181* 8222 10217 10219 10228 10230 10363 10487 10667 offset 000100 automatic fixed bin(18,0) dcl 10-13 in procedure "create_node" set ref 10-22* 10-24 10-25 10-26 offset 0(03) based fixed bin(14,0) array level 2 in structure "instruction" packed packed unaligned dcl 2581 in procedure "interpreter" set ref 3303* 3303 3315* 3315 5124* 5124 5164 5165* 5266* 5266 5523* 5523 offset 0(03) 000101 automatic fixed bin(14,0) level 2 in structure "inst_address" packed packed unaligned dcl 5807 in procedure "c_a" set ref 5845* offset 000100 automatic fixed bin(17,0) level 2 in structure "inst_address" packed packed unaligned dcl 5860 in procedure "c_a_18" set ref 5869* offset 1(03) based fixed bin(14,0) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1120* 1128* offset 114 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 3352* 3359* 5021* 6005 6020 6090* 6341* 6366 6388* 6419 6439* 6469* 6508* 6547* 6591 6867* offset 1(03) based fixed bin(14,0) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2676* 7950 offset 000105 automatic fixed bin(18,0) dcl 5658 in procedure "m_a_except_xreg" set ref 5676* 5677 5677* 5677 5679* 5679 5681* old_pos 004573 automatic fixed bin(18,0) dcl 10805 set ref 10825* 10826 10844* 10847 op 0(18) based bit(10) array level 2 in structure "instruction" packed packed unaligned dcl 2581 in procedure "interpreter" set ref 5348 5348* 5351 5351* 5354 5354* 5357 5357* op 004710 automatic fixed bin(18,0) dcl 11038 in procedure "effective_operand" set ref 11041* 11042 11044 11048* 11049 11051* 11055 op parameter fixed bin(18,0) dcl 6100 in procedure "base_man_load_VLA" ref 6097 6118 op parameter fixed bin(18,0) dcl 7993 in procedure "add_pointer" ref 7990 8002 op 002556 automatic fixed bin(18,0) dcl 4391 in procedure "copy" set ref 4393* 4395* 4397 4399 op 003167 automatic fixed bin(18,0) dcl 6229 in procedure "base_man_load_pr" set ref 6239* 6240 6283* 6285* 6340 op parameter fixed bin(18,0) dcl 8766 in procedure "mult" set ref 8761 8774 8774 8774 8774 8776* op 003074 automatic fixed bin(18,0) array dcl 5424 in procedure "emit_eis" set ref 5448* 5449 5505 op 004012 automatic fixed bin(18,0) array dcl 8924 in procedure "start_cat" set ref 8934* 8935* 8952 op 0(18) 003046 automatic bit(10) level 2 in structure "inst" packed packed unaligned dcl 5200 in procedure "emit_operator_call" set ref 5204* op parameter fixed bin(18,0) dcl 8718 in procedure "add" set ref 8713 8724 8735 8735 8735 8737* op 000100 automatic fixed bin(18,0) dcl 7120 in procedure "get_eaq_name" set ref 7123* 7125 7132 op 003205 automatic fixed bin(18,0) dcl 6357 in procedure "base_man_load_pr_value" set ref 6360* 6361 6366 6377* 6387 op1 004073 automatic fixed bin(18,0) dcl 9104 in procedure "compute_cat_result_length" set ref 9121* 9123* 9125* op1 000605 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 2748* 2750* 2753* 2757 2758 2762* 2764* 2835* 2837 2888* 2890 2891 3088* 3091 3093* 3165* 3166 3171* 3172 3177* 3178 3178 3188* 3189 3204* 3206* 3206 3215 3219 3223 3227 3231 3235 3247* 3249 3264* 3269* 3272 3277* 3280* 3283 3294* 3296* 3308* 3309 3311 3330* 3333 3333 3336* 3339* 3342 3342 3345* 3370* 3373 3373 3387* 3390 3390* 3390 3393* 3447* 3452* 3464* 3466* 3469* 3471* 3474* 3476 3476* 3476 3478 3478 3497* 3521* 3523 3523 3526* 3528 3528 3531* 3534 3535 3538 3545* 3548 3580* 3582 3585* 3587 3590* 3594 3601* 3604* 3608* 3610 3613* 3615* 3617* 3665* 3667 3669 3674* 3929* 3931 3934 4008* 4010* 4014* 4016 4019* 4022 4025 4025 4028 4029 4032* 4035 4038 4038 4041 4042 4118* 4119 4141* 4145 4145 op2 000606 automatic fixed bin(18,0) dcl 2348 set ref 3208* 3209 3209* 3215 3219 3223 3227 3231 3235 3377* 3378 3378 3449* 3450 3452* 3458 3458 op_code 0(18) based bit(10) array level 2 in structure "machine_instruction" packed packed unaligned dcl 2538 in procedure "interpreter" set ref 5516 5516 op_code 0(29) based bit(7) array level 2 in structure "macro_instruction" packed packed unaligned dcl 2531 in procedure "interpreter" set ref 2744 2959 4542 op_code 0(18) parameter bit(10) level 2 in structure "inst" packed packed unaligned dcl 5217 in procedure "put_word" ref 5234 5260 5260 op_code 0(18) 000026 external static bit(10) array level 2 in structure "fort_cg_macros_$single_inst" packed packed unaligned dcl 2395 in procedure "interpreter" ref 5166 5166 op_code 000601 automatic fixed bin(18,0) dcl 2346 in procedure "interpreter" set ref 2945* 2948 op_length parameter fixed bin(18,0) array dcl 9100 ref 9093 9108 9108 9113 9113 9121 9121 9123 9127 op_type 002711 automatic fixed bin(18,0) dcl 4743 set ref 4752* 4762* 4778 operand 0(18) based fixed bin(18,0) array level 2 in structure "forward_refs" packed packed unsigned unaligned dcl 497 in procedure "code_generator" set ref 632 5389* operand based fixed bin(3,0) array level 2 in structure "machine_instruction" packed packed unaligned dcl 2538 in procedure "interpreter" set ref 3377 5042 5448 operand 0(18) based fixed bin(3,0) array level 2 in structure "macro_instruction" packed packed unaligned dcl 2531 in procedure "interpreter" set ref 2742 7642 operand_base 000106 automatic pointer dcl 44 in procedure "ext_code_generator" set ref 76* 10-24 10-25 9-61 9-63 9-76 9-76 9-80 9-91 632 652 653 771 795 978 994 1004 1017 1056 1067 1085 1102 1142 1157 1172 1187 1235 1246 1258 1290 1306 1307 1394 1470 1488 1507 1525 1538 1592 1598 1604 1610 1636 1756 1796 1916 1989 1989 1995 1995 2160 2167 2173 2203 2207 2226 2287 2293 2313 2622 2660 2666 2671 2679 2683 2690 2822 2824 3016 3035 3053 3061 3070 3091 3101 3103 3128 3166 3178 3178 3189 3272 3283 3309 3333 3342 3373 3373 3378 3378 3406 3406 3416 3416 3425 3425 3425 3425 3478 3548 3582 3587 3594 3610 3611 3665 3665 3669 3748 3761 3762 3799 3812 3828 3841 3843 3887 3910 3914 3932 3932 3934 3944 3951 3959 3965 3978 3985 4016 4022 4025 4028 4035 4038 4041 4045 4056 4112 4119 4145 4145 4399 4420 4561 4566 4644 4645 4646 4650 4651 4673 4685 4687 4689 4689 4694 4705 4727 4728 4729 4776 4822 4891 4898 4921 4926 4926 4927 4950 4950 4955 4975 5004 5158 5183 5242 5384 5449 5513 5556 5556 5556 5558 5558 5600 5609 5662 5698 5703 5727 6030 6033 6051 6051 6118 6121 6122 6196 6240 6246 6361 6719 6953 6957 6959 6978 7021 7125 7173 7194 7204 7234 7234 7234 7234 7234 7234 7234 7234 7249 7294 7307 7325 7332 7387 7421 7465 7517 7539 7582 7690 7691 7692 7762 7763 7806 7889 8002 8003 8004 8031 8032 8033 8056 8057 8137 8141 8141 8141 8228 8236 8303 8307 8316 8411 8659 8663 8700 8792 8793 8826 8830 8838 8881 8892 8977 8978 9007 9007 9009 9009 9023 9046 9065 9065 9106 9163 9174 9195 9218 9250 9298 9362 9370 9371 9388 9392 9411 9421 9430 9479 9480 9482 9496 9504 9543 9582 9588 9602 9605 9614 9617 9692 9698 9718 9721 9727 9730 9747 9749 9822 9829 9829 9831 9844 9845 9929 9966 10023 10035 10036 10077 10085 10088 10123 10180 10202 10207 10215 10216 10226 10227 10239 10259 10280 10283 10308 10315 10420 10424 10428 10432 10575 10579 10583 10588 10903 11000 11026 11044 11049 operand_base 2 based pointer level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 76 operand_index 7 based fixed bin(18,0) array level 4 dcl 58 set ref 7642* operand_max_len 35 based fixed bin(19,0) level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 71 operand_max_len 000115 automatic fixed bin(19,0) dcl 45 in procedure "ext_code_generator" set ref 71* 10-20 10-29 10-29 4569 4571 4571 operand_type 0(09) based fixed bin(4,0) level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2672* 8839* operand_type 0(09) based fixed bin(4,0) level 2 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" set ref 2315* 3311 operand_type 0(09) based fixed bin(4,0) level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 980* 1269* 1274* 1298* 1300* 1387* 1424* 1489* 1508* 1539* 1766* 2684* 2691* 3035 9941 10098 operand_type 0(09) based fixed bin(4,0) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4778* operand_type 0(09) based fixed bin(4,0) level 2 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" set ref 9-82* operand_type 0(09) based fixed bin(4,0) level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" ref 5384 5398 7697 7728 7808 8035 8042 9263 operand_type 0(09) based fixed bin(4,0) level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" set ref 2661* operands 6 based structure array level 3 dcl 58 opnd parameter fixed bin(18,0) dcl 6225 in procedure "base_man_load_pr" ref 6219 6239 opnd parameter fixed bin(18,0) dcl 4391 in procedure "copy" set ref 4386 4393* opnd parameter fixed bin(18,0) dcl 11036 in procedure "effective_operand" ref 11031 11041 opnd parameter fixed bin(18,0) dcl 7120 in procedure "get_eaq_name" ref 7115 7123 opnd parameter fixed bin(18,0) dcl 7455 in procedure "check_negative" ref 7450 7462 7462 7465 opnd parameter fixed bin(18,0) dcl 9540 in procedure "one_word_dt" ref 9534 9543 opnd parameter fixed bin(18,0) dcl 6353 in procedure "base_man_load_pr_value" ref 6348 6360 opnd parameter fixed bin(18,0) dcl 9038 in procedure "get_cat_lengths" ref 9029 9046 opnd parameter fixed bin(18,0) dcl 4456 in procedure "get_operand" ref 4450 4460 4460 4462 4462 opno parameter fixed bin(17,0) dcl 5542 ref 5535 5545 options 11 based structure level 2 in structure "subprogram" dcl 1-753 in procedure "ext_code_generator" options 113 based structure level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" orq 000454 constant fixed bin(18,0) initial dcl 22-16 set ref 9186* 9194* 9291* os 000112 automatic pointer dcl 939 set ref 1307* 1308 1309 1310 1311 1312 1394* 1395 1397 1415 other_sym 000132 automatic fixed bin(18,0) dcl 940 set ref 1306* 1307 1392* 1393 1394 1397* 1414 own_sub 003424 automatic pointer dcl 7227 set ref 7232* 7234* 7252 7270 p 004162 automatic pointer dcl 9359 in procedure "check_arg_list" set ref 9370* 9371 9371 9371 9392* 9393 9394 9394 9398 9402 9421* 9428 9430 9430 9436 9438 9442 9449 p 004032 automatic pointer dcl 8972 in procedure "continue_cat" set ref 8977* 8984 8994 8997 8998 8998 9000 9013 9013 p 000100 automatic pointer dcl 6192 in procedure "flush_base" set ref 6196* 6197 6199 6199 6199 6206* 6212 6212 6213 6213 p 000114 automatic pointer dcl 7321 in procedure "save_logical_temps" set ref 7332* 7333 7335 7337* 7338 7341 7341 7350 7350 7353 p 003130 automatic pointer dcl 5585 in procedure "m_a" set ref 5587* 5589 5592 5594 5594 5594 5598 5600 5601 5603 5603 5607 5609 5610 5621 5626 5631* 5633 5633 5635 5638 5638 5639 5639 5640 5640 5640 5641 5642 5643 p 000102 automatic pointer dcl 6712 in procedure "flush_xr" set ref 6719* 6720 6724 p 000102 automatic pointer dcl 2308 in procedure "create_rel_constant" set ref 2313* 2315 2316 2317 2317 2317 p 003510 automatic pointer dcl 7580 in procedure "alloc_label" set ref 7582* 7584 7585 p 003550 automatic pointer dcl 7687 in procedure "next_subscript" set ref 7692* 7697 7699 7728 p 004244 automatic pointer dcl 9541 in procedure "one_word_dt" set ref 9543* 9544 9544 9544 9546 9546 9546 9546 9549 9549 p 003412 automatic pointer dcl 7186 in procedure "also_in_reg" set ref 7204* 7206 7209 7209 p 004712 automatic pointer dcl 11039 in procedure "effective_operand" set ref 11044* 11045 11045 11048 11049* 11051 11051 11051 p 003422 automatic pointer dcl 7226 in procedure "use_eaq" set ref 7249* 7250 7252 7252 7252 7256* 7257 7261 7261 7270 7270 7270 7273 p 000100 automatic pointer dcl 6654 in procedure "xr_man_load_any_xr" set ref 6658* 6659 6661 6681 6685 6688 6688* 6691* 6696 p 003010 automatic pointer dcl 5002 in procedure "allocate_dynamic_temp" set ref 5004* 5006 5013 5014 p 000102 automatic pointer dcl 5180 in procedure "emit_temp_store" set ref 5183* 5185 5185* 5188 5188 5190 p 004056 automatic pointer dcl 9042 in procedure "get_cat_lengths" set ref 9046* 9048* 9063 9065 9065 9078 9078 9082 p 003314 automatic pointer dcl 6950 in procedure "flush_ref" set ref 6953* 6954 6954 6954 6957* 6957 6958 6959* 6960 6962 p 003170 automatic pointer dcl 6230 in procedure "base_man_load_pr" set ref 6240* 6244 6244 6246 6246 6250 6250* 6253 6260 6261 6262 6263 6279 6279 6279 6279 6279 6279* 6287 6333 6334 p 004144 automatic pointer dcl 9313 in procedure "set_itp_addr" set ref 9316* 9321 9323 9325 9326 9331 9331 9331 9334 p 003326 automatic pointer dcl 6973 in procedure "flush_simple_ref" set ref 6978* 6980 6999 7006 p 003206 automatic pointer dcl 6358 in procedure "base_man_load_pr_value" set ref 6361* 6372 6372* 6377 6380 6382* 6384 p 003454 automatic pointer dcl 7456 in procedure "check_negative" set ref 7465* 7466 7466 7468 7469 p 000100 automatic pointer dcl 9908 in procedure "make_symbol_descriptor" set ref 9929* 9936 9936 9941 9944 9948 9950* 9964 9966 9973 9973 9975 9975 10043 p parameter pointer dcl 858 in procedure "set_address_offset" ref 852 868 869 871 874 p 003364 automatic pointer dcl 7061 in procedure "eaq_man_load_a_or_q" set ref 7065* 7066 7070 7075 7100 7100* 7103* p 000104 automatic pointer dcl 6101 in procedure "base_man_load_VLA" set ref 6118* 6119 6121 6122 6124 6161 p 002716 automatic pointer dcl 4747 in procedure "create_temp" set ref 4776* 4778 4779 4779 4781 4781 4781 4783 4784 4788 4789 4792 4794 4796* p 003056 automatic pointer dcl 5221 in procedure "put_word" set ref 5242* 5244 5246 5246* 5248* 5251 5253 5255 5255 5260 5260* 5262 5262* p 003572 automatic pointer dcl 7756 in procedure "finish_subscript" set ref 7806* 7808 7810 8031* 8051 8053 8054 8055 8056 8082 8087* 8186 8186 8204 8204 8213 p 003104 automatic pointer dcl 5428 in procedure "emit_eis" set ref 5510* 5511 5513* 5513 5516 5516* p 000100 automatic pointer dcl 1659 in procedure "alloc_external" set ref 1665* 1667 1669 1675 1680 1682 1682 1684 1686 1694 1694 1696 1698 1705 1705 1708 1708 1711 1711 1715 1715 1715 1718 1729 1731 1733 1734 p 000626 automatic pointer dcl 2352 in procedure "interpreter" set ref 2660* 2661 2662 2663 2663 2664 2665 2666 2668 2671* 2672 2673 2674 2674 2674 2675 2676 2677 2679 2680 2683* 2684 2685 2686 2686 2686 2687 2690* 2691 2692 2693 2694 2695 2696 2913* 2919 2921 2924 3053* 3054 3054 3061* 3063 3065 3065 3068 3070 3070 3073 3075 3309* 3311 3314 3594* 3595 3601 3610* 3611* 3611 3613 3613 3615 3645* 3649 3649 3653 3655 3661 3662 3669* 3670 3670 3670 3748* 3750 3753 3753 3761 3766 3779 3781 3781 3786 3789 3791 3791 3799* 3800 3800 3803 3805* 3812* 3813 3813 3813 3813 3813 3818 3820* 3828* 3832 3837 3837 3841 3844 3914* 3916 3919 3919 3922 3922 3922 3922 3922 3944* 3945* 3978* 3979 3980* 4045* 4047 4047 4049 4056* 4058 4060 4399* 4400 4400 4400 4400 4420* 4421 4423 4423 4424* 4427 4429 4429 4430* p 000100 automatic pointer dcl 5143 in procedure "emit_c_a_var" set ref 5157* 5158* 5161 5166* p 000100 automatic pointer dcl 9863 in procedure "get_char_size" set ref 9865* 9867 9867 9867 9870 9870 9873 9875 9875 9877 9880 9882 9882 9884 9887 9889 9889 9891 9894 9894 p 004126 automatic pointer dcl 9237 in procedure "make_descriptor" set ref 9250* 9256 9256 9256 9263 9266 9270 9272* 9289* 9289* p 004340 automatic pointer dcl 10056 in procedure "make_entry_descriptor" set ref 10077* 10083 10085 10098 10101 10105 10107* 10121 10123 10130 10130 10132 10132 10176 p 000100 automatic pointer dcl 5656 in procedure "m_a_except_xreg" set ref 5660* 5662 5662 5664 5681 5690 5690 5690 5710 5710 5714 5714 5716 5716 5731 5732 5732 5736 5739* 5742* p parameter pointer dcl 5783 in procedure "increment_address" ref 5778 5788 5788 5788 5792 5792 5794 5795 p 003776 automatic pointer dcl 8867 in procedure "free_array_ref" set ref 8870* 8871 8873 8879 8881 8890 8892 8904 p 003156 automatic pointer dcl 5887 in procedure "make_both_addressable" set ref 5891* 5893 5896 5896* 5899* 5903 5907 5909 p 000154 automatic pointer dcl 426 in procedure "code_generator" set ref 713* 715 716 717 718 719 720 721 722 723 724 725 727 729 731 731 733 733 737 p 000102 automatic pointer dcl 5282 in procedure "text_ref" set ref 5297* 5300 5300 5302 5304 5373 5375 5384 5384* 5384 5389 5398 p 004070 automatic pointer dcl 9102 in procedure "compute_cat_result_length" set ref 9106* 9113 9114 9129 9132 p parameter pointer dcl 843 in procedure "assign_address_offset" ref 837 848 848 p 002634 automatic pointer dcl 4557 in procedure "create_proc_frame" set ref 4566* 4576 4579 4580 4581 4582 p 000114 automatic pointer dcl 5751 in procedure "m_a_check_large_address" set ref 5755* 5758 5768 5770 5772 p 003342 automatic pointer dcl 7017 in procedure "flush_addr" set ref 7021* 7023 7030 p 000102 automatic pointer dcl 7512 in procedure "reset" set ref 7517* 7518 7518 p 003000 automatic pointer dcl 4972 in procedure "assign_dynamic_temp" set ref 4975* 4977 4978 4979 4980 4982 4982 4983 4983 4985 4986 p 004574 automatic pointer dcl 10806 in procedure "name_assign" set ref 10820* 10821 10822 10825 10833* 10838 10841 10842 p1 004034 automatic pointer dcl 8972 in procedure "continue_cat" set ref 8978* 8986* p1 000102 automatic pointer dcl 5657 in procedure "m_a_except_xreg" set ref 5662* 5664* 5666 5671 5671 5671 5674 5676 5679 5679 5688 5693 5695 5698* 5698 5700 5703* 5703 5705 5707 5714 5716 5719 5721 5721 5727* 5727 5729 5731 5736 5739* 5742* p1 parameter pointer dcl 43 in procedure "ext_code_generator" ref 40 68 p1 003612 automatic pointer dcl 8023 in procedure "finish_subscript" set ref 8032* 8035 8038 p1 000116 automatic pointer dcl 5751 in procedure "m_a_check_large_address" set ref 5756* 5764 5764 5764 p2 parameter pointer dcl 43 in procedure "ext_code_generator" ref 40 69 p2 003614 automatic pointer dcl 8023 in procedure "finish_subscript" set ref 8033* 8042 8045 packed 0(07) 000117 automatic bit(1) level 4 in structure "descriptor" packed packed unaligned dcl 9912 in procedure "make_symbol_descriptor" set ref 9948* 9973 packed 0(07) 000321 automatic bit(1) initial array level 2 in structure "descriptor_type_word" packed packed unaligned dcl 552 in procedure "code_generator" set ref 552* packed 0(07) 004354 automatic bit(1) level 4 in structure "descriptor" packed packed unaligned dcl 10060 in procedure "make_entry_descriptor" set ref 10105* 10130 packed 0(07) 004135 automatic bit(1) level 4 in structure "descriptor" packed packed unaligned dcl 9241 in procedure "make_descriptor" set ref 9270* packed_pointer based pointer packed unaligned dcl 10198 set ref 10220* 10231* parameter 11(04) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1249 1295 3065 3070 3166 3959 5705 5736 7706 parent 7 based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 5698 5703 6954 6957 parent 11(18) based fixed bin(18,0) level 2 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "ext_code_generator" set ref 3070 5148 5158 5255 5502 5513 5600 5662 6033 6121 6246 8056 8837* 9065 9065 parm_desc_ptrs based structure level 1 dcl 515 parm_desc_ptrsp 000214 automatic pointer dcl 438 set ref 3736 3738 4278* 4279 11023* 11024 11025 11026 passed_as_arg 0(28) based bit(1) level 4 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" ref 796 passed_as_arg 0(28) based bit(1) level 5 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1361 passed_as_arg 0(28) based bit(1) level 4 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" ref 772 pointer_count 0(27) based fixed bin(9,0) level 3 packed packed unsigned unaligned dcl 18-23 set ref 1800* 1800 1801 1803 1812 1823 2017* 2030 2123* pointer_offsets based structure array level 2 dcl 18-23 set ref 1812 2024 polish based fixed bin(18,0) array dcl 474 set ref 1285 1682 1684 1688 1688* 1694 1696 1700 1703* 1705 1711 1733* 1734* 2933 2933 2939* 2939* 2945 3541 3705 3708 3708 10389 10402 10403 10404 10511 10522 10523 10524 10678 10678 polish_base based pointer level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 77 polish_base 000110 automatic pointer dcl 44 in procedure "ext_code_generator" set ref 77* 630 631 632 1285 1669 1669 1669 1675 1675 1678 1682 1684 1688 1688 1694 1696 1700 1703 1705 1711 1715 1718 1729 1733 1734 2933 2933 2939 2939 2945 3541 3705 3708 3708 5389 5390 10389 10402 10403 10404 10511 10522 10523 10524 10662 10678 10678 10819 10820 10838 polish_max_len 34 based fixed bin(19,0) level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 72 polish_max_len 000116 automatic fixed bin(19,0) dcl 45 in procedure "ext_code_generator" set ref 72* 1727 1746 1746 5381 5381 5381 10835 pos 004637 automatic bit(18) dcl 10939 in procedure "generate_definition" set ref 10951* 10952 10953 10959 10969 10980 pos parameter fixed bin(18,0) dcl 9314 in procedure "set_itp_addr" ref 9307 9317 position 004511 automatic fixed bin(15,0) dcl 10658 set ref 10667* 10668* 10668 10670* pr_no based bit(3) level 2 in structure "itp" packed packed unaligned dcl 16-18 in procedure "code_generator" ref 827 pr_no 2 001516 automatic bit(3) array level 3 in structure "arg_list" packed packed unaligned dcl 2602 in procedure "interpreter" set ref 9323* prev 1 based pointer level 2 in structure "proc_frame" packed packed unaligned dcl 2510 in procedure "interpreter" set ref 3640 4445 4580* prev parameter fixed bin(18,0) dcl 4914 in procedure "thread_temp" ref 4908 4916 4926 4927 prev 002670 automatic fixed bin(18,0) dcl 4662 in procedure "get_temp" set ref 4680* 4687 4689 4693* prev_temp 002745 automatic fixed bin(18,0) dcl 4846 set ref 4887* 4893* 4897* 4904* print_message 1530 based entry variable level 2 dcl 53 ref 10-29 9-45 1317 1338 1518 1550 1582 1636 1705 1708 1711 1715 1740 1746 1886 1889 2207 2817 2839 2869 2879 2978 2981 2993 2999 3019 3040 3105 3108 3133 3140 3154 3251 3311 3322 3396 3535 3568 3681 3989 3993 4025 4038 4052 4063 4301 4323 4355 4378 4571 4768 4856 5381 5472 5603 5710 5955 6377 6625 6671 6685 7087 7142 7169 7215 7372 7701 7713 7719 8104 8111 8127 8797 8875 9371 9415 9461 9584 9590 9596 9606 9618 9694 9700 9706 9712 9722 9731 9831 9867 9894 10683 10878 print_message_op 30 based entry variable level 2 dcl 58 ref 3622 3636 proc_frame based structure level 1 dcl 2510 set ref 4567 4579* procedure 12(02) based bit(1) level 3 packed packed unaligned dcl 13-10 set ref 731* profile 11(20) based bit(1) level 4 packed packed unaligned dcl 1-753 ref 749 profile_entry based structure level 1 dcl 17-3 ref 1579 7617 profile_offset 12 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 702* profile_pos 000172 automatic fixed bin(18,0) dcl 428 set ref 1573* 1576* 7607 7610* 7610 7614 7614 7617* 7617 profile_size 55 based fixed bin(17,0) level 2 dcl 53 ref 1577 1579 profile_start 000171 automatic fixed bin(18,0) dcl 428 set ref 587* 702 1573* 4219 4237 7602 10247 psap 000120 automatic pointer dcl 939 set ref 1525* 1526 1527 1527 psize 004061 automatic fixed bin(18,0) dcl 9044 set ref 9065* 9066 9069 psp 000116 automatic pointer dcl 939 set ref 1507* 1508 1509 1510 1510 1510 1510 1510 1512 1513 1516* 1526 pt parameter pointer dcl 7061 in procedure "eaq_man_load_a_or_q" ref 7056 7065 pt parameter pointer dcl 9313 in procedure "set_itp_addr" ref 9307 9316 pt parameter pointer dcl 5585 in procedure "m_a" ref 5580 5587 pt parameter pointer dcl 9863 in procedure "get_char_size" ref 9856 9865 pt parameter pointer dcl 10298 in procedure "list_initialize" set ref 10295 10312 10317* 10320 10321* 10321 10325 pt parameter pointer dcl 5656 in procedure "m_a_except_xreg" ref 5650 5660 pt parameter pointer dcl 8867 in procedure "free_array_ref" ref 8861 8870 pt parameter pointer dcl 5751 in procedure "m_a_check_large_address" ref 5746 5755 pt parameter pointer dcl 10854 in procedure "initialize_common" ref 10851 10869 pt parameter pointer dcl 1659 in procedure "alloc_external" ref 1643 1665 pt parameter pointer dcl 10270 in procedure "initialize" ref 10267 10276 pt parameter pointer dcl 2221 in procedure "get_array_size" ref 2215 2225 pt parameter pointer dcl 6652 in procedure "xr_man_load_any_xr" ref 6647 6658 pt parameter pointer dcl 5276 in procedure "text_ref" ref 5271 5297 pt1 parameter pointer dcl 5751 ref 5746 5756 pthru parameter fixed bin(18,0) dcl 4411 ref 4406 4415 ptr builtin function dcl 569 ref 2707 put_in_profile 3(01) based bit(1) level 3 packed packed unaligned dcl 1-721 ref 3708 put_in_symtab 0(34) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 1361 2251 q 000550 automatic pointer dcl 821 in procedure "relocate_itp_list" set ref 825* 827 827 831 q 000104 automatic pointer dcl 5282 in procedure "text_ref" set ref 5299* 5300* 5305* 5308 5316 5318 5328 5330 5336 5341 5342* 5344 5364 qls 000417 constant fixed bin(18,0) initial dcl 22-16 set ref 9641* 9652* 9661* 9666* 9756* qrl 000443 constant fixed bin(18,0) initial dcl 22-16 set ref 3772 9634* 9642* 9655* 9662* 9668* 9776* 9792* 9808* qrs constant fixed bin(18,0) initial dcl 22-16 ref 3834 r 003331 automatic fixed bin(18,0) dcl 6974 in procedure "flush_simple_ref" set ref 6982* 6983 6984 6986 6987 6987 6990 6990 6991 6991* r 003430 automatic fixed bin(18,0) dcl 7230 in procedure "use_eaq" set ref 7245* 7247 7249 7252 7263 7265 7266 7276 7277* r 000101 automatic fixed bin(18,0) dcl 7121 in procedure "get_eaq_name" set ref 7128* 7130 7132 7132* r parameter fixed bin(18,0) dcl 7511 in procedure "reset" ref 7506 7514 rand parameter fixed bin(18,0) dcl 5056 in procedure "emit_single" ref 5051 5062 5068 5078 rand 003021 automatic fixed bin(18,0) dcl 5032 in procedure "emit_inst" set ref 5042* 5044 rand parameter fixed bin(18,0) dcl 5217 in procedure "put_word" set ref 5211 5225 5238 5242* 5258 rands based fixed bin(18,0) array dcl 472 set ref 632 652 653 771 795 978 994 1004 1017 1056 1067 1085 1102 1142 1157 1172 1187 1235 1246 1258 1290 1306 1307 1394 1470 1488 1507 1525 1538 1592 1598 1604 1610 1636 1756 1796 1916 1989 1989 1995 1995 2160 2167 2173 2203 2207 2226 2287 2293 2313 2622 2660 2666 2671 2679 2683 2690 2822 2824 3016 3035 3053 3061 3070 3091 3101 3103 3128 3166 3178 3178 3189 3272 3283 3309 3333 3342 3373 3373 3378 3378 3406 3406 3416 3416 3425 3425 3425 3425 3478 3548 3582 3587 3594 3610 3611 3665 3665 3669 3748 3761 3762 3799 3812 3828 3841 3843 3887 3910 3914 3932 3932 3934 3944 3951 3959 3965 3978 3985 4016 4022 4025 4028 4035 4038 4041 4045 4056 4112 4119 4145 4145 4399 4420 4561* 4566 4644 4645 4646 4650 4651 4673 4685 4687 4689 4689 4694 4705 4727 4728 4729 4776 4822 4891 4898 4921 4926 4926 4927 4950 4950 4955 4975 5004 5158 5183 5242 5384 5449 5513 5556 5556 5556 5558 5558 5600 5609 5662 5698 5703 5727 6030 6033 6051 6051 6118 6121 6122 6196 6240 6246 6361 6719 6953 6957 6959 6978 7021 7125 7173 7194 7204 7234 7234 7234 7234 7234 7234 7234 7234 7249 7294 7307 7325 7332 7387 7421 7465 7517 7539 7582 7690 7691 7692 7762 7763 7806 7889 8002 8003 8004 8031 8032 8033 8056 8057 8137 8141 8141 8141 8228 8236 8303 8307 8316 8411 8659 8663 8700 8792 8793 8826 8830 8838 8881 8892 8977 8978 9007 9007 9009 9009 9023 9046 9065 9065 9106 9163 9174 9195 9218 9250 9298 9362 9370 9371 9388 9392 9411 9421 9430 9479 9480 9482 9496 9504 9543 9582 9588 9602 9605 9614 9617 9692 9698 9718 9721 9727 9730 9747 9749 9822 9829 9829 9831 9844 9845 9929 9966 10023 10035 10036 10077 10085 10088 10123 10180 10202 10207 10215 10216 10226 10227 10239 10259 10280 10283 10308 10315 10420 10424 10428 10432 10575 10579 10583 10588 10903 11000 11026 11044 11049 rank builtin function dcl 569 ref 4060 rc_a 000606 constant bit(6) initial packed unaligned dcl 20-6 in procedure "assign_storage" ref 1091 1373 1513 1544 2107 2107 rc_a constant bit(6) initial packed unaligned dcl 23-6 in procedure "interpreter" ref 4167 4177 4225 4243 4289 4986 5321 5332 5366 5643 7608 rc_a_dp constant bit(36) initial packed unaligned dcl 14-23 ref 10769 10774 rc_dp constant bit(18) initial packed unaligned dcl 14-6 ref 10633 10779 10786 11011 rc_dp_dp 000601 constant bit(36) initial packed unaligned dcl 14-23 ref 10776 10976 10977 rc_is15 056066 constant bit(6) initial packed unaligned dcl 20-6 in procedure "assign_storage" ref 1101 1218 1450 2105 2105 rc_is15 constant bit(6) initial packed unaligned dcl 23-6 in procedure "interpreter" ref 6078 7615 rc_is18 constant bit(6) initial packed unaligned dcl 23-6 in procedure "interpreter" ref 4220 4238 7603 rc_is18 constant bit(18) initial packed unaligned dcl 14-6 in procedure "code_generator" ref 827 rc_lp15 constant bit(6) initial packed unaligned dcl 23-6 in procedure "interpreter" ref 6076 rc_lp15 constant bit(6) initial packed unaligned dcl 20-6 in procedure "assign_storage" ref 1407 1495 rc_lp18 056067 constant bit(6) initial packed unaligned dcl 20-6 ref 1988 1988 rc_nlb constant bit(18) initial packed unaligned dcl 14-6 ref 10783 rc_t constant bit(6) initial packed unaligned dcl 11-6 in procedure "create_constant" ref 9-84 rc_t constant bit(18) initial packed unaligned dcl 14-6 in procedure "code_generator" ref 656 831 10627 rc_t constant bit(6) initial packed unaligned dcl 23-6 in procedure "interpreter" ref 2665 3739 3741 4171 4181 4288 rc_t constant bit(6) initial packed unaligned dcl 21-6 in procedure "create_rel_constant" ref 2316 rc_t 056070 constant bit(6) initial packed unaligned dcl 20-6 in procedure "assign_storage" ref 983 1006 1283 1413 2137 2137 real_image based float bin(27) dcl 2472 set ref 2637* real_mode 000736 constant fixed bin(4,0) initial dcl 3-106 set ref 2638* 9544 reallocate_char_string constant fixed bin(14,0) initial dcl 2433 ref 8954 reallocated parameter bit(1) dcl 8922 set ref 8911 8946* 8952* 8954 ref_count 6 based fixed bin(17,0) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 3670* 3670 4400* 4400 4423 4423* 4645* 4825 4825* 4854 7252 8141* 8141 8664* 8664 8884 8884* 8895 8895* ref_count 6 based fixed bin(17,0) level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 2680* 4429 4429* 7234 8855* 8873 referenced 0(27) based bit(1) level 5 packed packed unaligned dcl 1-530 set ref 2317* referenced_executable 0(29) based bit(1) level 4 packed packed unaligned dcl 1-530 set ref 2317* 3272 reg 003155 automatic fixed bin(3,0) dcl 5886 in procedure "make_both_addressable" set ref 5909* 5910 reg parameter fixed bin(18,0) dcl 7567 in procedure "lock_eaq" ref 7562 7569 reg 003471 automatic fixed bin(18,0) dcl 7534 in procedure "store" set ref 7554* 7555 reg_number parameter fixed bin(18,0) dcl 7488 set ref 7483 7490 7493 7498* regno 003444 automatic fixed bin(18,0) dcl 7366 in procedure "load" set ref 7393* 7396 7397 7400 7400 7400 7404 7409 7412 7421* regno 000101 automatic fixed bin(18,0) dcl 7511 in procedure "reset" set ref 7514* 7516 7517 7522 7523 regno 003410 automatic fixed bin(18,0) dcl 7186 in procedure "also_in_reg" set ref 7191* 7196 7198 7198 7199 7199 7204 7208 regno 003377 automatic fixed bin(18,0) dcl 7152 in procedure "in_reg" set ref 7157* 7159* 7163 7164 7165 7167 7175 7177 regno 000617 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 3159* 3160 3450* 3456 3459 3480* 3482 3485 3485 3490 3490 3499 regs based bit(18) array level 2 in structure "macro_regs_inst" packed packed unaligned dcl 2567 in procedure "interpreter" ref 3326 3693 regs parameter structure array level 1 dcl 5926 in procedure "get_free_reg" ref 5921 rel builtin function dcl 569 ref 1361 1361 1705 1705 1708 1708 1711 1711 1715 1715 1812 1816 1886 1886 1889 1889 2024 2025 2136 2136 2251 2251 2708 3738 3766 3779 4850 5151 5389 5594 5594 5603 5603 5640 5640 5690 5690 5710 5710 6130 6659 7066 8235 8235 8276 8689 8689 8808 8871 9867 9867 9894 9894 10093 10312 10325 10825 10875 10897 10897 rel_code 000333 constant bit(18) initial array dcl 10941 ref 10978 rel_constant constant fixed bin(4,0) initial dcl 3-120 ref 2315 3311 5398 relation 0(22) based bit(3) array level 2 in structure "macro_if_inst" packed packed unaligned dcl 2559 in procedure "interpreter" ref 3212 relation 000610 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 3212* 3213 reloc based structure array level 1 dcl 2592 in procedure "interpreter" reloc 2(12) based bit(6) level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" set ref 2665* reloc 2(12) based bit(6) level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 8854* reloc 2(12) based bit(6) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4983 4986* reloc 2(12) based bit(6) level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 983* 1106* 1283* 1407* 1413* 1450* 1495* 1513* 1544* 1759* 8854 reloc 2(12) based bit(6) level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" set ref 1026* 1091* 1101* 1106 1218* 1759 reloc 2(12) based bit(6) level 2 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" set ref 9-84* reloc 2(12) based bit(6) level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 5146 5253 5500 5639 5643* 6126 6213* reloc based bit(36) array dcl 495 in procedure "code_generator" set ref 10627* 10633* 10769* 10774* 10776* 10779* 10783* 10786* 10976* 10977* 10978* reloc 2(12) based bit(6) level 2 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" set ref 1006* 2316* reloc 1 based bit(18) array level 3 in structure "saved_lib_reloc_list" packed packed unaligned dcl 509 in procedure "code_generator" set ref 656* reloc_halfs based structure array level 1 dcl 491 reloc_hold 2(06) based bit(6) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4983* reloc_hold 2(06) based bit(6) level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 5639* 6213 relocatable 113(24) based bit(1) level 4 in structure "shared_globals" packed packed unaligned dcl 53 in procedure "ext_code_generator" ref 729 relocatable 12(01) based bit(1) level 3 in structure "object_map" packed packed unaligned dcl 13-10 in procedure "code_generator" set ref 729* relocate_itp 000540 automatic bit(1) dcl 790 set ref 792* 807 relocation_base 000112 automatic pointer dcl 44 in procedure "ext_code_generator" set ref 78* 645 665 673 827 831 1988 2105 2107 2137 3739 3741 4167 4171 4177 4181 4220 4225 4238 4243 4288 4289 5146 5253 5321 5332 5366 5500 6076 6078 6126 7603 7608 7615 11011 relocation_base 12 based pointer level 2 in structure "shared_globals" dcl 53 in procedure "ext_code_generator" ref 78 repeat 1(06) based fixed bin(30,0) level 2 in structure "create_init_entry" packed packed unsigned unaligned dcl 18-61 in procedure "code_generator" set ref 10567* 10572* repeat parameter fixed bin(35,0) dcl 10534 in procedure "list_assign_value" ref 10531 10572 10595 reserve 003254 automatic bit(14) dcl 6842 set ref 6847* 6849 6850 reserved 110(01) 001334 automatic bit(1) array level 4 in structure "machine_state" packed packed unaligned dcl 2479 in procedure "interpreter" set ref 5910* 6338* 6609 6610* 6612* 6625 6862* 6893 6895* 6904 6910* reserved 37(01) 001334 automatic bit(1) array level 4 in structure "machine_state" packed packed unaligned dcl 2479 in procedure "interpreter" set ref 6855* 6884 6886* 7045* reserved 0(01) parameter bit(1) array level 3 in structure "regs" packed packed unaligned dcl 5926 in procedure "get_free_reg" ref 5933 5942 reserved 6 001334 automatic bit(1) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 6881* 7087 7087 7090 7092 7569* restore_prs 0(32) based bit(1) level 3 packed packed unaligned dcl 1-530 ref 3283 result 001324 automatic bit(72) dcl 2461 in procedure "interpreter" set ref 2637 2638* 2640 2641* 2643 2644* 2646* 2647* 2826* 2828* 3693* 3695* result parameter fixed bin(18,0) dcl 9099 in procedure "compute_cat_result_length" ref 9093 9106 result 004016 automatic fixed bin(18,0) dcl 8926 in procedure "start_cat" set ref 8943* 8944* 8945* 8958* 8959* 8960* 8961* ret_lab parameter label variable local dcl 4497 ref 4475 4507 retain 1(21) based bit(1) level 3 packed packed unaligned dcl 27-12 set ref 11019* return 3 based fixed bin(18,0) level 2 in structure "proc_frame" dcl 2510 in procedure "interpreter" set ref 2919 2986 3661 4545* return parameter fixed bin(18,0) dcl 4519 in procedure "setup_call" ref 4514 4545 reverse builtin function dcl 569 ref 10815 right 0(18) based fixed bin(17,0) level 2 in structure "half" packed packed unaligned dcl 2598 in procedure "interpreter" ref 5318 5328 5364 right 0(18) based fixed bin(17,0) array level 2 in structure "text_halfs" packed packed unaligned dcl 487 in procedure "code_generator" set ref 4176* 4180* 4224* 4242* 4286* 7607* right_rel 0(30) based bit(6) array level 2 packed packed unaligned dcl 2592 set ref 3741* 4177* 4181* 4225* 4243* 4289* 7608* round_inst 000465 constant fixed bin(18,0) initial array dcl 22-16 ref 3490 3492 4001 rounded 34 001334 automatic bit(1) level 2 dcl 2479 set ref 3485 3494* 3997 4002* 7161* 7263 7281* 7343 7446* 7500* 7541 rscan 000552 automatic fixed bin(18,0) dcl 822 set ref 824* 825 827 831* s 004650 automatic pointer dcl 10991 in procedure "gen_entry_defs" set ref 11000* 11001 11009 11028 s 000102 automatic pointer dcl 10303 in procedure "list_initialize" set ref 10315* 10317 10317* 10319 s 003662 automatic pointer dcl 7996 in procedure "add_pointer" set ref 8002* 8003 s 000102 automatic pointer dcl 6101 in procedure "base_man_load_VLA" set ref 6121* 6124* 6130 6136 6138 6142 6142 6142 6142 6149 6158 6181 6181 6181 s 000236 automatic pointer dcl 2283 in procedure "create_automatic_integer" set ref 2287* 2288 2289 2289 2289 2289 2290 2291 s 004164 automatic pointer dcl 9359 in procedure "check_arg_list" set ref 9362* 9364 9379 9379* 9381 9387 9411 s 004512 automatic pointer dcl 10659 in procedure "gen_linkage" set ref 10662* 10663 10663 10663 10667 10668 10668 10670 10678 10678 10678* 10678* 10678 10681 10681 10681 10683 s 003766 automatic pointer dcl 8821 in procedure "create_array_ref" set ref 8838* 8840 8841 8842 8844* 8852 8853 8854 s 003132 automatic pointer dcl 5585 in procedure "m_a" set ref 5600* 5619 s 000114 automatic pointer dcl 1839 in procedure "create_storage_entry" set ref 1796* 1797 1797* 1801* 1803 1816 1819 1916* 1928 1936 1938 1941 2004* 2005 2007* 2010 2010 2014 2016 2018 2025 s 004114 automatic pointer dcl 9212 in procedure "copy_array_desc_template" set ref 9215* 9216 s 000104 automatic pointer dcl 5990 in procedure "base_man_load_any_pr" set ref 6030* 6031 6031 6033 6033 6036 s 004102 automatic pointer dcl 9150 in procedure "get_param_char_size" set ref 9156* 9157 9169 9169* 9177 9184 s 000212 automatic pointer dcl 2221 in procedure "get_array_size" set ref 2225* 2226 2228 2228 2230 2232 2237 2251 2251 2251 2251 s 000630 automatic pointer dcl 2352 in procedure "interpreter" set ref 3762* 3763* 3773* 3778* s 004610 automatic pointer dcl 10854 in procedure "initialize_common" set ref 10903* 10904 10904* 10906 s 000122 automatic pointer dcl 939 in procedure "assign_storage" set ref 978* 980 981 982 983 987 987 989 1004* 1005 1006 1007 1056* 1057* 1057 1057 1058 1102* 1103 1104 1105 1106 1132* 1246* 1247 1249 1249 1255 1257 1258 1261 1263 1265 1267 1269 1272 1274 1277 1279 1281 1282 1283 1285 1295 1295 1298 1298 1300 1302 1306 1320 1321 1322 1324 1324 1327 1336 1344 1344 1349 1351 1353 1354* 1356 1356 1358 1360 1361 1361 1361 1361 1361 1361 1361 1367 1369 1369 1370 1373 1375 1377 1378 1382 1387 1395 1402 1403 1404 1404* 1405 1407 1408 1412 1413 1414 1415 1424 1426 1426* 1428 1428 1432 1435 1437 1447 1449 1450 1452 1453 1454 1456 1461 1474 1475 1610* 1611* 1611 1611 1612 1756* 1757 1758 1759 1760 1762 1762 1763 1763 1765 1765 1766 1767 1768 1769 1769* 1771 2173* 2174* 2175* 2175 2175 2177 s 003742 automatic pointer dcl 8790 in procedure "start_subscript" set ref 8792* 8793 s 000120 automatic pointer dcl 10456 in procedure "list_initialize_symbol" set ref 10479* 10484 10484 10487 10488 10488 10494 10494 10497 10497 10500 10504 10507 10509 10511 10516 s 003574 automatic pointer dcl 7756 in procedure "finish_subscript" set ref 7762* 7763 7767 7825 7837 7840 7844 7846 7847 7873 7873 7881 7881 7881 7884 7903 7910 7956 7956 7962 8056* 8082* 8213 8213 8222 8223 8223 8225 8228 8235 8235 8253 8260 8260 8261 8265 8292* 8294 8294 8297 8307 8325 8325* 8335 8337 8347 8359 8361 8369 8424 8436 8540 8542 s 004420 automatic pointer dcl 10194 in procedure "initialize_static" set ref 10216* 10217 10217 10219 10219 10227* 10228 10228 10230 10230 s 003552 automatic pointer dcl 7687 in procedure "next_subscript" set ref 7690* 7691 7706 s 004452 automatic pointer dcl 10334 in procedure "initialize_symbol" set ref 10357* 10363 10364 10364 10369 10371 10375 10375 10378 10382 10385 10387 10389 10395 s parameter pointer dcl 2200 in procedure "relocate_error" ref 2197 2203 2203 2207 s 004436 automatic pointer dcl 10273 in procedure "initialize" set ref 10283* 10284 10284* 10286 saved_cat_address 001331 automatic structure level 1 dcl 2467 set ref 8984* 9023 saved_lib_list based structure level 1 dcl 503 set ref 648 saved_lib_reloc_list based structure level 1 dcl 509 sbfx1 constant fixed bin(18,0) initial dcl 22-16 ref 8729 sbq constant bit(10) initial dcl 5286 ref 5351 5354 scalar 1(05) based bit(1) array level 4 packed packed unaligned dcl 1-130 set ref 9401* 9402* 9440 9513* 9514* scan_called 0(07) based bit(1) level 4 packed packed unaligned dcl 2510 set ref 2975* 2981 3649 scan_interpreter_frame 0(06) based structure level 3 packed packed unaligned dcl 2510 scan_proc 000611 automatic fixed bin(18,0) dcl 2348 set ref 2948* 2950* 2959 2962 2971* 2972 section_name parameter char packed unaligned dcl 2149 ref 2144 2207 seg_def 000250 automatic bit(18) dcl 467 set ref 10646 10969* 10972 seg_name 004524 automatic bit(18) dcl 10699 set ref 10716* 10734* 10754* 10756* 10772 seg_ptr 1 based bit(18) level 2 packed packed unaligned dcl 12-25 set ref 10772* segname 000311 automatic char(32) dcl 520 in procedure "code_generator" set ref 590* 10640* segname 2(18) based bit(18) level 2 in structure "definition" packed packed unaligned dcl 26-12 in procedure "generate_definition" set ref 10972* segname_def based structure level 1 dcl 24-3 separate_static 12(04) based bit(1) level 3 packed packed unaligned dcl 13-10 set ref 727* shared_globals based structure level 1 dcl 53 shared_struc_ptr 000100 automatic pointer dcl 43 set ref 68* 70 71 72 75 76 77 78 10-20 10-22 10-23 10-23 10-29 9-45 9-87 9-87 9-89 9-89 9-91 9-93 561 584 592 593 593 599 600 601 605 611 623 624 625 626 630 637 689 706* 729 737 751 792 967 967 977 987 993 993 993 994 1313 1317 1338 1361 1392 1518 1550 1577 1579 1582 1591 1591 1591 1592 1634 1634 1636 1667 1674 1705 1708 1711 1715 1727 1729 1733 1734 1736 1736 1740 1746 1797 1886 1889 1999 2047 2048 2115 2128 2128 2134 2139 2159 2159 2159 2160 2207 2251 2621 2621 2622 2666 2817 2826 2839 2869 2879 2978 2981 2993 2999 3019 3040 3105 3108 3133 3140 3154 3251 3311 3322 3396 3535 3568 3681 3685 3686 3703 3705 3708 3763 3989 3993 4025 4029 4038 4042 4050 4050 4052 4063 4134 4163 4170 4174 4180 4301 4323 4355 4378 4559 4561 4562 4562 4566 4567 4567 4569 4571 4723 4726 4727 4768 4856 5381 5381 5387 5387 5389 5390 5472 5603 5710 5955 6377 6625 6671 6685 7087 7142 7169 7215 7372 7701 7713 7719 7937 8104 8111 8127 8369 8797 8875 9371 9415 9461 9478 9479 9584 9590 9596 9606 9618 9694 9700 9706 9712 9722 9731 9822 9831 9845 9846 9867 9894 9970 10015 10035 10127 10172 10201 10238 10258 10683 10819 10835 10837 10837 10838 10878 10999 shift 004264 automatic fixed bin(17,0) dcl 9577 in procedure "rhs_fld" set ref 9626* 9634 9637 shift 004304 automatic fixed bin(17,0) dcl 9685 in procedure "lhs_fld" set ref 9755* 9756 9756 short 13 based fixed bin(18,0) array level 2 dcl 2510 set ref 2993 2993 2995* 3003 shorten_stack 000351 constant fixed bin(14,0) initial dcl 2433 set ref 4096* shorten_stack_mask 000346 constant bit(14) initial dcl 2443 set ref 4090* shorten_stack_protect_ind 000347 constant fixed bin(14,0) initial dcl 2433 set ref 4092* single_target based bit(36) array dcl 10470 in procedure "list_initialize_symbol" set ref 10575* single_target based bit(36) array dcl 10347 in procedure "initialize_symbol" set ref 10420* size 0(12) 000321 automatic fixed bin(23,0) initial array level 2 in structure "descriptor_type_word" packed packed unaligned dcl 552 in procedure "code_generator" set ref 552* size builtin function dcl 4748 in procedure "create_temp" ref 4751 4761 size 0(12) 004354 automatic fixed bin(23,0) level 3 in structure "descriptor" packed packed unaligned dcl 10060 in procedure "make_entry_descriptor" set ref 10108* 10112* size 002656 automatic fixed bin(18,0) dcl 4611 in procedure "assign_temp" set ref 4614* 4627* 4638* 4639* 4639 4639 4642* size 7 based fixed bin(24,0) array level 3 in structure "dimension" dcl 1-383 in procedure "ext_code_generator" set ref 2240 2259* 2262* 2264* 7779 7780 7797 8346 8390 8506 8508 8514 8514 8516 8612 8625 8640 9986 10143 size builtin function dcl 9927 in procedure "make_symbol_descriptor" ref 10022 10022 size builtin function dcl 9-33 in procedure "create_constant" ref 9-74 9-74 size parameter fixed bin(18,0) dcl 845 in procedure "assign_address_offset" ref 837 848 size 0(12) 000117 automatic fixed bin(23,0) level 3 in structure "descriptor" packed packed unaligned dcl 9912 in procedure "make_symbol_descriptor" set ref 9951* 9955* size builtin function dcl 4720 in procedure "get_temp_node" ref 4723 4723 size builtin function dcl 569 in procedure "code_generator" ref 648 722 723 733 737 1033 1035 1120 1487 1487 1506 1506 1524 1524 1537 1537 1561 1576 1577 1577 1579 1983 2286 2286 2312 2312 2659 2659 2670 2670 2682 2682 2689 2689 3706 4567 7610 7617 8825 8825 9387 9387 10624 size based fixed bin(35,0) level 2 in structure "init_info" dcl 25-30 in procedure "initialize_common" set ref 10914* size parameter fixed bin(18,0) dcl 902 in procedure "get_size_in_bits" ref 897 908 size 7 based fixed bin(24,0) level 2 in structure "temporary" dcl 1-1005 in procedure "ext_code_generator" set ref 4685 4788* 4861 4891 9082 size parameter fixed bin(18,0) dcl 860 in procedure "set_address_offset" ref 852 865 size 0(12) 004135 automatic fixed bin(23,0) level 3 in structure "descriptor" packed packed unaligned dcl 9241 in procedure "make_descriptor" set ref 9273* size parameter fixed bin(18,0) dcl 883 in procedure "get_size_in_words" ref 878 890 893 skip 000612 automatic fixed bin(18,0) dcl 2348 set ref 3958* 3959* 3959 3969 source 001326 automatic bit(72) dcl 2461 set ref 2822* 2826 source_line_base 16 based pointer level 2 dcl 53 ref 593 source_list based structure array level 1 dcl 2-31 set ref 593 sp defined bit(3) dcl 525 in procedure "code_generator" set ref 1046 1093 1220 1311 1321 1377 1452 1512 1543 2675 2687 3922 4784 5763 5821 5830 6465 6616* 6628* sp parameter pointer dcl 9475 in procedure "find_arg_desc" ref 9472 9479 9484 9489 ssp 000124 automatic pointer dcl 939 set ref 1488* 1489 1490 1491 1491 1491 1491 1491 1493 1494 1495 1496 1496* 1631* st based structure level 1 dcl 10808 sta 000536 constant fixed bin(18,0) initial dcl 22-16 set ref 7325* stack 000640 automatic fixed bin(18,0) array dcl 2359 set ref 2748 2756 2757* 2757 2758* 2782 2814 2822 2824 2828* 2837 2890 2891* 2891 2892* 2894* 2952 3016 3019* 3032 3035 3040* 3053 3061 3088 3101 3103 3105* 3108* 3128 3133* 3166 3172* 3177 3188 3206 3209 3249 3272 3283 3296 3303 3309 3311* 3314 3315 3330 3339 3373 3373 3378 3378 3387 3406 3406 3416 3416 3416* 3416* 3425 3425 3425 3425 3433 3434* 3434 3435* 3443 3447 3464 3469 3474 3523* 3523 3528* 3528 3534 3535* 3538* 3548 3582 3582 3587 3590 3593 3610 3665 3665 3693 3695* 3700* 3726 3736 3748 3750 3789 3799 3803 3812 3818 3841 3843 3857 3881 3882 3885 3887 3887 3898 3910 3914 3916 3931 3934* 3940 3944 3948* 3951 3955 3956 3959 3963 3965 3965 3985 4008 4014 4022 4025 4025 4028 4029* 4035 4038 4038 4041 4042* 4045 4056 4112 4118 4141 4276 4376 4378 4382* 4418 4420 4468 4596 5044 5448 7582 7642 7690 7692 7701* 7701* 7713* 7713* 7719* 7719* 7762 7806 7814 7818 7888 7918* 7926* 7933* 8031 8032 8033 8093 8094 8104* 8104* 8111* 8111* 8127* 8137 8140 8148 8161 8169 8170 8193 8197 8792 8795 8797* 8934 8977 8978 9023 9361 9362 9370 9371* 9371* 9392 9415* 9421 9461* 9461* 9581 9587 9593 9691 9697 9703 9709 stack_extended 160 001334 automatic bit(1) level 2 dcl 2479 set ref 4084 4099* 5011* stack_indirect 0(19) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4868 4874* 4978* 9078 stack_indirect 0(19) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1295 1327 1375 3786 stack_indirect 0(19) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" ref 5671 6199 9331 stack_size 004655 automatic fixed bin(18,0) dcl 10992 set ref 10997* 11005 stack_sub parameter fixed bin(18,0) dcl 7577 ref 7574 7582 standard 12(03) based bit(1) level 3 packed packed unaligned dcl 13-10 set ref 731* standard_bits 0(25) based structure level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" standard_bits 0(25) based structure level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" standard_bits 0(25) based structure level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" standard_bits 0(25) based structure level 3 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" standard_bits 0(25) based structure level 4 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" standard_bits 0(25) based structure level 3 in structure "constant" packed packed unaligned dcl 1-256 in procedure "ext_code_generator" standard_bits 0(25) based structure level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" star_extent_function 0(16) based bit(1) level 2 packed packed unaligned dcl 1-753 ref 3826 4124 star_extents 11(09) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 1361 2228 3813 7873 8213 8294 star_symbol_link 13 000122 automatic fixed bin(18,0) level 2 dcl 61 set ref 703* start parameter fixed bin(18,0) dcl 9560 in procedure "generate_mask" ref 9555 9565 start 004270 automatic fixed bin(18,0) dcl 9578 in procedure "rhs_fld" set ref 9617* 9618 9618 9624* 9624 9625 9626 9630 9637* 9637* 9641 9652 9652 start 000166 automatic fixed bin(18,0) dcl 2154 in procedure "relocate" set ref 2158* 2163 2163* start parameter fixed bin(18,0) dcl 765 in procedure "alloc_constants" ref 760 770 start parameter fixed bin(18,0) dcl 10270 in procedure "initialize" ref 10267 10278 10278 start 004312 automatic fixed bin(18,0) dcl 9687 in procedure "lhs_fld" set ref 9730* 9731 9731 9737* 9737 9738 9740 9749 9755 9760* 9760* 9772* 9776 9776 start parameter fixed bin(18,0) dcl 789 in procedure "alloc_char_constants" ref 784 792 794 start_offset 000105 automatic fixed bin(18,0) dcl 10305 set ref 10312* 10325 statement based structure level 1 dcl 1-721 set ref 3706 statement_function constant fixed bin(4,0) initial dcl 3-120 ref 1269 static 0(34) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1030 1117 1198 1215 1805 2105 2111 static 11(01) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1437 1447 5695 5764 6151 static 0(19) based bit(1) level 3 in structure "create_entry" packed packed unaligned dcl 18-23 in procedure "code_generator" set ref 2111* static_length 7(18) based bit(18) level 2 in structure "virgin_linkage_header" packed packed unaligned dcl 12-52 in procedure "code_generator" set ref 10624* static_length 6(18) based bit(18) level 2 in structure "object_map" packed packed unaligned dcl 13-10 in procedure "code_generator" set ref 723* static_offset 6 based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 722* stmnt_func 10(33) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1267 storage based fixed bin(17,0) array dcl 10-15 set ref 10-24* storage_class 0(33) based structure level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" ref 1757 storage_class 11 based structure level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1757 storage_info 0(25) based structure level 3 in structure "label" packed packed unaligned dcl 1-530 in procedure "ext_code_generator" storage_info 13 based structure array level 2 in structure "subprogram" dcl 1-753 in procedure "ext_code_generator" set ref 1011* storage_info 0(25) based structure level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" storage_info 0(25) based structure level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "ext_code_generator" store_base 000513 constant fixed bin(18,0) initial array dcl 22-16 set ref 3791 3837 3890* 3969* 6580 6601 6617 6629 store_inst 000537 constant fixed bin(18,0) initial array dcl 22-16 set ref 3844 7265 7345 7541 8460* 8463* 8551* 8580* 8601* 8609* 8621* 8633* 8636* 9177 9196 9292* store_no_round_inst 000470 constant fixed bin(18,0) initial array dcl 22-16 ref 7263 7343 7543 store_packed_base 000444 constant fixed bin(18,0) initial array dcl 22-16 ref 3763 3781 stq 000550 constant fixed bin(18,0) initial dcl 22-16 set ref 3773 9188* string builtin function dcl 569 in procedure "code_generator" set ref 1757 1757 1767* 1767 2259 4540* 4779* 4779* 5034 7006* 7547 7728 7777 8387 8506 8514 8527 8587 8616 8628 9319* 9982 10139 string 0(09) based char level 2 in structure "acc" packed packed unaligned dcl 10800 in procedure "name_assign" set ref 10822 10842* string parameter char dcl 10694 in procedure "compile_link" set ref 10691 10710 10728 10733 10739 10745 10752* string_length 10 based fixed bin(17,0) array level 4 dcl 58 set ref 7650* string_ptr 12 based pointer array level 4 dcl 58 set ref 7651* stringrange 11(17) based bit(1) level 4 packed packed unaligned dcl 1-753 ref 8089 stz 000522 constant fixed bin(18,0) initial dcl 22-16 set ref 8073* 8419* subprogram based structure level 1 dcl 1-753 subprogram_type 0(05) based fixed bin(3,0) level 2 packed packed unaligned dcl 1-753 ref 3183 6499 6538 9825 subscript_mpy constant fixed bin(18,0) initial dcl 2449 set ref 8777* subscriptrange 11(16) based bit(1) level 4 packed packed unaligned dcl 1-753 ref 7728 substr builtin function dcl 569 set ref 1757* 2010 3021 3047 4028* 4029 4029 4041* 4042 4042 4060 4982 5161 5260 5331* 5487* 5487 5489* 5494* 5494 5516 5638 5676 6022* 6057* 6059* 6142* 6212* 6301 6301 6377 6380* 6384* 6811* 6812* 6850 7045 9565* 9749 10733 10745 10815 substr_size 003623 automatic fixed bin(18,0) dcl 8025 set ref 8124* 8125 8140* 8141 8141 8141 8178* 8179* 8239 sxl0 constant fixed bin(18,0) initial dcl 22-16 ref 6726 8074 sym 000127 automatic fixed bin(18,0) dcl 940 in procedure "assign_storage" set ref 977* 977* 978* 1003* 1003* 1004* 1055* 1055* 1056* 1244* 1245 1246 1288 1290 1291 1468 1470 1471 1474* 1609* 1609* 1610* 1755* 1755* 1756* 2172* 2172* 2173* sym 000240 automatic fixed bin(18,0) dcl 2284 in procedure "create_automatic_integer" set ref 2286* 2287 2293 2294 2296 sym parameter pointer dcl 8287 in procedure "finish_subscript" ref 8280 8292 sym parameter fixed bin(18,0) dcl 8820 in procedure "create_array_ref" ref 8815 8837 8838 sym parameter pointer dcl 9150 in procedure "get_param_char_size" ref 9138 9156 sym 004617 automatic fixed bin(18,0) dcl 10855 in procedure "initialize_common" set ref 10902* 10902* 10903* sym 000620 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 3761* 3762 sym 004440 automatic fixed bin(18,0) dcl 10274 in procedure "initialize" set ref 10281* 10281* 10283* sym parameter pointer dcl 9212 in procedure "copy_array_desc_template" ref 9206 9215 sym 004654 automatic fixed bin(18,0) dcl 10992 in procedure "gen_entry_defs" set ref 10999* 10999* 11000* sym 000116 automatic fixed bin(18,0) dcl 1840 in procedure "create_storage_entry" set ref 1794* 1794* 1796* 1915* 1915* 1916* sym 000104 automatic fixed bin(18,0) dcl 10304 in procedure "list_initialize" set ref 10314* 10314* 10315* sym_pos 000162 automatic fixed bin(18,0) dcl 428 set ref 587* 706* 712 725 sym_pt parameter pointer dcl 10443 in procedure "list_initialize_symbol" ref 10440 10479 sym_pt parameter pointer dcl 10332 in procedure "initialize_symbol" ref 10329 10357 symbol based structure level 1 dcl 1-844 in procedure "ext_code_generator" set ref 1487 1487 1506 1506 1524 1524 1526* 1526 1537 1537 2286 2286 2682 2682 2689 2689 4761 10022 10022 symbol 2 based bit(18) level 2 in structure "definition" packed packed unaligned dcl 26-12 in procedure "generate_definition" set ref 10964* symbol 1(17) based fixed bin(18,0) array level 3 in structure "arg_desc" packed packed unaligned dcl 1-130 in procedure "ext_code_generator" set ref 9430 9499 9504 symbol 0(18) based fixed bin(18,0) level 2 in structure "subprogram" packed packed unsigned unaligned dcl 1-753 in procedure "ext_code_generator" ref 1636 2207 9831 symbol_length 7(18) based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 725* symbol_node 000736 constant fixed bin(4,0) initial dcl 3-87 set ref 1487* 1506* 1524* 1537* 1667 1669 2286* 2682* 2689* 3054 3065 3333 3342 3750 3753 3789 3800 3803 3813 3818 3887 3916 3919 3965 4145 4760 4772 5671 5719 5764 6031 6244 6954 7270 7350 8253 9256 9331 9371 9394 9436 9506 9546 9873 10022* 10088 10663 11051 symbol_offset 7 based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 724* symp 004216 automatic pointer dcl 9475 set ref 9504* 9505 9506 9506 9510 9514 symrel 000166 automatic fixed bin(18,0) dcl 428 set ref 693* 706* 712 724 symtab_parameters 000122 automatic structure level 1 dcl 61 set ref 706 706 system_options 115 based structure level 3 dcl 53 t 003354 automatic bit(6) dcl 7040 in procedure "lock_tag_register" set ref 7042* 7045 7045 7047 7049 t 004000 automatic pointer dcl 8867 in procedure "free_array_ref" set ref 8881* 8882 8884 8884 8885* 8892* 8893 8895 8895 8896* t 002776 automatic fixed bin(18,0) dcl 4971 in procedure "assign_dynamic_temp" set ref 4974* 4975 4988 table 11(19) based bit(1) level 4 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "ext_code_generator" ref 751 1255 table 113(19) based bit(1) level 5 in structure "shared_globals" packed packed unaligned dcl 53 in procedure "ext_code_generator" ref 1361 2251 8369 9970 10127 tag 0(30) 000100 automatic bit(6) level 2 in structure "inst_address" packed packed unaligned dcl 5860 in procedure "c_a_18" set ref 5871* tag 0(30) 000101 automatic bit(6) level 2 in structure "inst_address" packed packed unaligned dcl 5807 in procedure "c_a" set ref 5813* 5833* 5833 tag 0(30) based bit(6) level 2 in structure "inst_address" packed packed unaligned dcl 6104 in procedure "base_man_load_VLA" set ref 6163* 6165* 6169* 6171* tag 1(30) based bit(6) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 5621* 5626* 8683* 8684 8696* 8697 tag 1(30) based bit(6) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 5635 5642* 5903 6260 6261* 6279 6333* 6377 6380* 6384* tag 0(30) based bit(6) array level 3 in structure "instruction" packed packed unaligned dcl 2581 in procedure "interpreter" set ref 5096* 5235* 5319* 5365* 5398* tag 1(30) based bit(6) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1370* 1373* 1405* 1494* tag parameter bit(6) dcl 7040 in procedure "lock_tag_register" ref 7035 7042 tag 1(30) based bit(6) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 9013* 9013 tag parameter bit(6) dcl 5089 in procedure "emit_with_tag" ref 5084 5096 tag 0(30) 003172 automatic bit(6) level 2 in structure "inst_address" packed packed unaligned dcl 6231 in procedure "base_man_load_pr" set ref 6301* 6310* 6312* 6320* 6329* tag_hold 003173 automatic bit(6) dcl 6232 set ref 6260* 6295 6301 6301 6305 6312 6324 6329 6333 temp parameter fixed bin(18,0) dcl 5179 in procedure "emit_temp_store" ref 5172 5183 temp 000613 automatic fixed bin(18,0) dcl 2348 in procedure "interpreter" set ref 2906* 2907* 2909* 3402* 3416* 3425* 3431 3882* 3890* 3956* 3969* 4060* 4061 4061 temp 003324 automatic fixed bin(18,0) dcl 6972 in procedure "flush_simple_ref" set ref 6976* 6978 6984 7001 temp 002671 automatic fixed bin(18,0) dcl 4662 in procedure "get_temp" set ref 4669* 4671 4673 4674 4681* 4683 4685 4687 4689 4690 4693 4694* 4694 4704* 4705 4706 temp 002712 automatic fixed bin(18,0) dcl 4743 in procedure "create_temp" set ref 4772* 4774* 4776 4798 temp 002766 automatic fixed bin(18,0) dcl 4939 in procedure "push_variable" set ref 4949* 4950 4950 temp parameter fixed bin(18,0) dcl 4914 in procedure "thread_temp" ref 4908 4921 4922 4926 4927 temp 002744 automatic fixed bin(18,0) dcl 4846 in procedure "free_one_temp" set ref 4850* 4856* 4863* 4864* 4881* 4893* 4904* temp 004072 automatic fixed bin(18,0) dcl 9103 in procedure "compute_cat_result_length" set ref 9129* 9130* temp 004330 automatic fixed bin(18,0) dcl 9820 in procedure "start_subprogram" set ref 9842* 9842* 9843* 9844 temp parameter fixed bin(18,0) dcl 4999 in procedure "allocate_dynamic_temp" ref 4992 5004 5016 5018 temp 002700 automatic fixed bin(18,0) dcl 4721 in procedure "get_temp_node" set ref 4723* 4726* 4727 4728 4729 4732 temp 003340 automatic fixed bin(18,0) dcl 7016 in procedure "flush_addr" set ref 7020* 7021 7026 temp 002657 automatic fixed bin(18,0) dcl 4611 in procedure "assign_temp" set ref 4642* 4644 4645 4646 4650 4651 4655 temp 000100 automatic fixed bin(18,0) dcl 5281 in procedure "text_ref" set ref 5341* 5342 temp_index parameter fixed bin(18,0) dcl 6972 in procedure "flush_simple_ref" ref 6967 6976 temp_index parameter fixed bin(18,0) dcl 7016 in procedure "flush_addr" ref 7011 7020 temp_ptr parameter pointer dcl 4810 in procedure "free_temp" ref 4802 4815 temp_ptr parameter pointer dcl 4843 in procedure "free_one_temp" ref 4837 4849 temp_ptr parameter pointer dcl 6561 in procedure "base_man_store_temp" ref 6553 6568 temp_reg 000122 automatic fixed bin(3,0) dcl 6562 set ref 6569* 6580 6601 6609 6610 6612 6617 6629 temp_size 002747 automatic fixed bin(18,0) dcl 4847 set ref 4861* 4879 4881* 4891 temp_type constant fixed bin(4,0) initial dcl 3-120 ref 4752 temporary based structure level 1 dcl 1-1005 set ref 4723 4723 4728* 4751 temporary_node 000730 constant fixed bin(4,0) initial dcl 3-87 set ref 3670 4400 4421 4723* 4729 4750 4786 4823 5674 6199 7206 7250 7333 7421 8067 8141 8664 8882 8893 9078 9430 9887 text_halfs based structure array level 1 dcl 487 set ref 11023 text_length 3(18) based bit(18) level 2 packed packed unaligned dcl 13-10 set ref 717* text_offset 000102 automatic fixed bin(17,0) dcl 5144 in procedure "emit_c_a_var" set ref 5164* 5166 text_offset 003106 automatic fixed bin(18,0) dcl 5429 in procedure "emit_eis" set ref 5509* 5514* 5514 5516* text_pos 000157 automatic fixed bin(18,0) dcl 428 in procedure "code_generator" set ref 587* 617 621* 621 621 643 648* 648 663 698 717 775 776 777* 777 799* 799 799 805 806 809* 809 824 824 1060 1060 1060* 1134 1134 1134* 1281 1286* 1286 1823* 1823 1988 2030* 2030 2100 2105 2107 2128 2135 2139 3259 3260* 3260 3280* 3303 3303 3333 3342 3350 3357 3705 3750 3766 3779 3789 3803 3818 3887 3916 3965 3985 4155 4157 4159* 4159 4166 4167 4170 4171 4176 4177 4180 4181 4184 4187* 4187 4219 4220 4224 4225 4226* 4226 4237 4238 4242 4243 4244* 4244 4248 4278 4280 4284* 4284 4285 4286 4288 4289 4290* 4290 5020 5034 5047* 5047 5064* 5064 5080* 5080 5095 5096 5097 5098* 5098 5109 5110* 5110 5122 5124 5124 5124 5128 5128 5131* 5131 5146 5148 5151 5163* 5163 5164 5165 5168* 5168 5206 5207* 5207 5230 5235 5238 5251 5253 5255 5258 5262 5266 5266 5267 5267 5318 5319 5321 5330 5331 5332 5348 5348 5351 5351 5354 5354 5357 5357 5364 5365 5366 5377 5390 5393 5393 5398 5478 5479 5485* 5485 5494 5496 5498 5500 5502 5505 5523 5523 5524 5524 5527* 5527 6009 6076 6078 6091 6126 6130 6342 6391 6421 6440 6470 6491 6507 6530 6546 6599 6667 6697 6745 6759 6829 7602 7603 7607 7608 7609* 7609 7615 10256 10260 10260 10263* 10263 text_pos 004656 automatic fixed bin(18,0) dcl 10993 in procedure "gen_entry_defs" set ref 11001* 11005 11009 11009 11011 11013 11016 11023 text_word based bit(36) array dcl 2590 set ref 3259* 4278 5034* 5095* 5109* 5122* 5206* 5230* 5251* 5331* 5479* 5487* 5489* this_chain 000120 automatic pointer dcl 1841 set ref 1903* 1905 1906 1920* 1921 1925* 1925 1926 1928 1937 1940 2072* 2072* 2073 2074* 2076 this_temp 002746 automatic fixed bin(18,0) dcl 4846 set ref 4888* 4889 4891 4897 4898* 4898 thru 002566 automatic fixed bin(18,0) dcl 4411 set ref 4415* 4417 tnz constant fixed bin(18,0) initial dcl 2412 set ref 7416* 7441 top 000563 automatic fixed bin(18,0) dcl 2329 set ref 2716* 2756 2757 2782 2783* 2783 2814 2815* 2815 2822 2824 2828 2952 2955 3016 3019 3032 3035 3040 3053 3101 3103 3105 3108 3209 3296 3297* 3297 3303 3304* 3304 3314 3315 3317* 3317 3406 3406 3416 3416 3416 3416 3425 3425 3425 3425 3433 3434 3434 3435 3443 3582 3593 3681 3693 3695 3857 3858* 3858 3948 4045 4056 4374* 4374 4376 4382 4417 4418 4420 4435* 4435 4460 4468 4469* 4469 4470 4596 4598 7692 7693 7701 7713 7719 8977 9023 tp 002742 automatic pointer dcl 4845 in procedure "free_one_temp" set ref 4849* 4850 4854 4860 4861 4868 4870 4870 4871 4872 4873 4873 4874 tp 002726 automatic pointer dcl 4812 in procedure "free_temp" set ref 4815* 4817 4822 4828 4829 4833* tp 000120 automatic pointer dcl 6561 in procedure "base_man_store_temp" set ref 6568* 6571 6574 6578 6591 6616 6628 trap_ptr 0(18) based bit(18) level 2 packed packed unaligned dcl 12-25 set ref 10768* tv_offset parameter fixed bin(14,0) dcl 5000 in procedure "allocate_dynamic_temp" ref 4992 5009 tv_offset parameter fixed bin(14,0) dcl 5199 in procedure "emit_operator_call" ref 5194 5203 tv_offset 004022 automatic fixed bin(14,0) dcl 8928 in procedure "start_cat" set ref 8954* 8956* 8960* type parameter fixed bin(18,0) dcl 10694 in procedure "compile_link" ref 10691 10754 10774 type 1 parameter fixed bin(18,0) array level 2 in structure "regs" dcl 5926 in procedure "get_free_reg" ref 5944 type parameter fixed bin(4,0) dcl 10-14 in procedure "create_node" ref 10-10 10-25 type 1 based fixed bin(17,0) level 2 in structure "init_info" dcl 25-30 in procedure "initialize_common" set ref 10915* type based bit(18) level 2 in structure "type_pair" packed packed unaligned dcl 12-25 in procedure "code_generator" set ref 10766* type 111 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 3348* 3355* 5019* 6003 6005 6088* 6194 6339* 6366 6386* 6417 6419 6437* 6465* 6467* 6487 6489 6505* 6526 6528 6544* 6589 6591 6614 6863* 6896 6896* 6904 6907* 6938* 7026 7026* type 0(01) 000321 automatic fixed bin(6,0) initial array level 2 in structure "descriptor_type_word" packed packed unsigned unaligned dcl 552 in procedure "code_generator" set ref 552* type 40 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 6664 6694* 6714 6757* 6781 6783 6827* 6856* 6887 6887* 6931 7001 7001* type_pair based structure level 1 dcl 12-25 type_ptr based bit(18) level 2 packed packed unaligned dcl 12-21 set ref 10778* type_word 000117 automatic structure level 2 in structure "descriptor" dcl 9912 in procedure "make_symbol_descriptor" set ref 9941* 9945* 10013 10013 type_word 004354 automatic structure level 2 in structure "descriptor" dcl 10060 in procedure "make_entry_descriptor" set ref 10098* 10102* 10170 10170 type_word 004135 automatic structure level 2 in structure "descriptor" dcl 9241 in procedure "make_descriptor" set ref 9263* 9267* 9281 9281 typeless_mode constant fixed bin(4,0) initial dcl 3-106 ref 3111 3117 9544 tze constant fixed bin(18,0) initial dcl 2412 ref 3140 3143 u 000100 automatic fixed bin(3,0) dcl 884 in procedure "get_size_in_words" set ref 888* 890 893 893 u 000100 automatic fixed bin(3,0) dcl 903 in procedure "get_size_in_bits" set ref 907* 908 units parameter fixed bin(3,0) dcl 861 in procedure "set_address_offset" ref 852 865 units parameter fixed bin(3,0) dcl 846 in procedure "assign_address_offset" ref 837 848 units 2 based fixed bin(3,0) level 2 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "ext_code_generator" set ref 8841* units parameter fixed bin(3,0) dcl 884 in procedure "get_size_in_words" ref 878 888 units 2 based fixed bin(3,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 1057 1428 1611 1760 2175 2182 2232 2291* 7767 7956 8260 8369 8540 8841 9948 9973 9975 10105 10130 10132 10369 10375 10494 10497 units 2 based fixed bin(3,0) level 2 in structure "header" packed packed unsigned unaligned dcl 1-436 in procedure "ext_code_generator" ref 1682 1694 1734 units 2 based fixed bin(3,0) level 2 in structure "temporary" packed packed unsigned unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4646* 4651* 4794* units parameter fixed bin(3,0) dcl 903 in procedure "get_size_in_bits" ref 897 907 units 2 based fixed bin(3,0) level 2 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "ext_code_generator" set ref 3063 5633 6253 6279 6287 8265* 9270 unspec builtin function dcl 10-17 in procedure "create_node" set ref 10-24* unspec builtin function dcl 569 in procedure "code_generator" set ref 586* 654 1011* 1021* 1090* 1161* 1213* 1263* 1310* 1758* 1758 2010 2629 2629 2702* 3259 3768* 3771 3771 3777 3777 3937* 4579* 4728* 4783* 4870* 4982 4985* 5034 5095 5109 5122 5153 5153 5161 5188 5188 5202* 5206 5230 5251 5251 5260 5304 5479 5487 5494 5494 5516 5638 5731* 5731 5810* 5847 5867* 5874 6142 6212 6292* 6302 6302 6311 6311 6313 6313 6321 6321 6330 6330 6431* 6434 6434 6459* 6462 6462 6571* 6580 6580 6601 6601 6617 6617 6629 6629 6936* 7663 7699* 7810* 7939* 7942 7942 8832* 8853* 8853 9251* 9263* 9263 9267* 9267 9281 9281 9334 9526* 9565 9749* 9930* 9941* 9941 9945* 9945 9955* 9998* 10003* 10005* 10013 10013 10078* 10098* 10098 10102* 10102 10112* 10155* 10160* 10162* 10170 10170 10248* 11013* update_flag parameter fixed bin(18,0) dcl 7532 ref 7527 7551 upper 0(10) based bit(1) array level 3 packed packed unaligned dcl 1-383 ref 7706 7738 10001 10158 upper_bound 6 based fixed bin(24,0) array level 3 dcl 1-383 ref 2259 2262 7706 7738 7740 8600 8608 8623 8623 8635 9985 10001 10142 10158 usage 0(30) based structure level 3 packed packed unaligned dcl 1-530 use_dl 000106 automatic bit(1) dcl 5283 set ref 5346* 5360* 5362 use_pool 004623 automatic bit(1) dcl 10861 set ref 10909* 10910 10917 used 113 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 3350* 3357* 5020* 6009* 6091* 6342* 6391* 6421* 6440* 6470* 6491* 6507* 6530* 6546* 6599* used 3 parameter fixed bin(18,0) array level 2 in structure "regs" dcl 5926 in procedure "get_free_reg" ref 5946 5948 used 42 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 6667* 6697* 6745* 6759* 6829* user_options 113 based structure level 3 dcl 53 usual_base 000120 automatic bit(3) dcl 5752 set ref 5763* 5764* 5770* 5772 v parameter fixed bin(18,0) dcl 7152 in procedure "in_reg" ref 7147 7156 v 003616 automatic pointer dcl 8023 in procedure "finish_subscript" set ref 8057* 8067 8067 8067 8076 v 000101 automatic fixed bin(18,0) dcl 5985 in procedure "base_man_load_any_pr" set ref 5997* 6005 6030 6049* 6051 6051 6056* 6068* 6070 6089 v 000221 automatic fixed bin(18,0) dcl 2222 in procedure "get_array_size" set ref 2236* 2239* 2239 2243 v 003664 automatic pointer dcl 7997 in procedure "add_pointer" set ref 8004* 8005* v parameter fixed bin(18,0) dcl 7186 in procedure "also_in_reg" ref 7181 7192 v 003134 automatic pointer dcl 5585 in procedure "m_a" set ref 5609* 5610 5610 5621* 5622 5626* v 000106 automatic pointer dcl 6101 in procedure "base_man_load_VLA" set ref 6122* 6124* 6126 6136 6136 6142 6149 6158 6158 6181 v 003366 automatic fixed bin(18,0) dcl 7062 in procedure "eaq_man_load_a_or_q" set ref 7066* 7077* 7098* 7107* v 003472 automatic pointer dcl 7535 in procedure "store" set ref 7539* 7547 7553 v 000102 automatic fixed bin(18,0) dcl 7121 in procedure "get_eaq_name" set ref 7130* 7132* v 003704 automatic pointer dcl 8653 in procedure "finalize_vsum" set ref 8659* 8663* 8664 8664 8664 8676 8681* 8683* 8689 8689 8694 8694* 8696* 8701 8705 v 000102 automatic fixed bin(18,0) dcl 6655 in procedure "xr_man_load_any_xr" set ref 6659* 6664 6671* 6685* 6695 v_array based bit(36) array dcl 9-34 set ref 9-51 9-52* 9-54 9-54 v_bound 0(09) based structure array level 2 packed packed unaligned dcl 1-383 ref 2259 7728 7777 8387 8506 8514 8527 8587 8616 8628 9982 10139 v_length 004134 automatic bit(1) dcl 9239 in procedure "make_descriptor" set ref 9252* 9275* 9286 v_length 000116 automatic bit(1) dcl 9910 in procedure "make_symbol_descriptor" set ref 9931* 9954* 9970 9979 9986 9990* 10020 v_length 003620 automatic bit(1) dcl 8024 in procedure "finish_subscript" set ref 8123* 8136* 8159* 8168* 8176 8238 v_length 004353 automatic bit(1) dcl 10058 in procedure "make_entry_descriptor" set ref 10079* 10111* 10127 10136 10143 10147* v_length 6 based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "ext_code_generator" set ref 3800 3832 7825 7837 7840 8325 8335 8359 8424 8436 8542 9177 9875 9875 v_multiplier 003637 automatic bit(1) dcl 8290 set ref 8362* 8366* 8369 8387 8394 8422 8434 8460 8527* 8527 v_offset 4(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-155 set ref 5609 6122 6161 7234 7234 8054 8669* 8688* 8699* 8879 8881 val_ptr 003456 automatic pointer dcl 7456 set ref 7468* 7471 7474 7478 value 4 based bit(72) level 2 in structure "constant" dcl 1-256 in procedure "ext_code_generator" set ref 9-65 9-85* 776 2822 4049 5300 7468 7699 7810 8038 8045 9605 9617 9721 9730 9749 10420 10424 10575 10579 value 4(18) based char level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "ext_code_generator" ref 806 4028 4041 4060 5304 10428 10432 10583 10588 value 2 based fixed bin(35,0) level 2 in structure "initial_in_polish" dcl 10465 in procedure "list_initialize_symbol" ref 10511 10522 value parameter fixed bin(18,0) dcl 7577 in procedure "alloc_label" ref 7574 7584 value parameter fixed bin(35,0) dcl 7660 in procedure "create_integer_constant" ref 7657 7663 value parameter bit(72) dcl 9-16 in procedure "create_constant" ref 9-13 9-41 value 2 based fixed bin(17,0) level 2 in structure "initial_in_polish" dcl 10342 in procedure "initialize_symbol" ref 10389 10402 value 2 004463 automatic fixed bin(18,0) level 2 in structure "initial" dcl 10337 in procedure "initialize_symbol" set ref 10389* 10390 10402* 10408 10420 10424 10428 10432 value parameter fixed bin(18,0) dcl 6771 in procedure "const_in_xr" ref 6765 6778 value 000107 automatic bit(36) dcl 5284 in procedure "text_ref" set ref 5304* 5305 value parameter bit(18) dcl 10934 in procedure "generate_definition" ref 10931 10965 value 2 000127 automatic fixed bin(35,0) level 2 in structure "initial" dcl 10460 in procedure "list_initialize_symbol" set ref 10511* 10522* 10536 10575 10579 10583 10588 value 1 based bit(18) level 2 in structure "definition" packed packed unaligned dcl 26-12 in procedure "generate_definition" set ref 10965* value_in 0(15) based structure level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "ext_code_generator" value_in 0(15) based structure level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "ext_code_generator" set ref 7006* 7547 value_in 0(15) based structure level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" value_in_xr 36 001334 automatic bit(1) level 2 dcl 2479 set ref 6698* 6929 var 003406 automatic fixed bin(18,0) dcl 7186 in procedure "also_in_reg" set ref 7192* 7194 7199 7208 var 003376 automatic fixed bin(18,0) dcl 7152 in procedure "in_reg" set ref 7156* 7164 7169* 7173 var 003442 automatic fixed bin(18,0) dcl 7366 in procedure "load" set ref 7376* 7387 7397 7415* 7416* 7421 7437* 7439* 7444* var parameter fixed bin(18,0) dcl 10054 in procedure "make_entry_descriptor" ref 10051 10077 var parameter fixed bin(18,0) dcl 9906 in procedure "make_symbol_descriptor" ref 9898 9929 var 003466 automatic fixed bin(18,0) dcl 7534 in procedure "store" set ref 7538* 7539 7545* 7547* 7555* 7557* var parameter fixed bin(18,0) dcl 9236 in procedure "make_descriptor" ref 9226 9250 9259 var 002764 automatic fixed bin(18,0) dcl 4939 in procedure "push_variable" set ref 4953* 4955 4957* var 000100 automatic fixed bin(18,0) dcl 7292 in procedure "use_ind" set ref 7302* 7306 7307 var 000100 automatic fixed bin(18,0) dcl 2307 in procedure "create_rel_constant" set ref 2312* 2313 2319 var_ptr parameter pointer dcl 5142 ref 5135 5146 5148 5148 5151 5153 5153 5157 5158 5158 variable 2 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 6984 6987* 6987 7132 7164* 7196 7199* 7202 7204 7208* 7249 7266 7294 7302 7306* 7325 7325 7332 7346 7397 7517 variable 41 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 6664 6695* 6719 6726* 6758* 6783 6828* 6931 7001 8071 8699* variable 112 001334 automatic fixed bin(18,0) array level 3 in structure "machine_state" dcl 2479 in procedure "interpreter" set ref 3351* 3358* 5018* 6005 6089* 6196 6340* 6366 6387* 6438* 6468* 6506* 6545* 6865* 7026 variable_arglist 0(30) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 4119 9364 variable_array_size 0(27) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 3613 8318* variable_extents 0(32) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 1361 2228 3813 7873 8213 8294 variable_length 0(29) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "ext_code_generator" set ref 4817 4829* 9114* 9132* 9889 variable_length 0(29) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "ext_code_generator" set ref 8238* 8847* 8890 9882 variable_offset 0(30) based bit(1) level 3 packed packed unaligned dcl 1-155 set ref 5607 7234 8053 8668* variable_type constant fixed bin(4,0) initial dcl 3-120 ref 1300 1424 1766 2691 4762 variable_virtual_origin 0(26) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 7853 8339* 8402* 8413* verify builtin function dcl 569 ref 10815 virgin_linkage_header based structure level 1 dcl 12-52 set ref 722 723 1033 1035 1120 1561 1983 10624 virtual_origin 1 based fixed bin(24,0) level 2 in structure "dimension" dcl 1-383 in procedure "ext_code_generator" set ref 2243* 7853 7860 8337* 8399* 8410* 8415 virtual_origin 003630 automatic fixed bin(18,0) dcl 8289 in procedure "finish_subscript" set ref 8356* 8410* 8411 8415* 8419* 8428* 8477 8484* vname 004560 automatic varying char(32) dcl 10798 set ref 10815* 10822 10822 10832 10842 vp parameter fixed bin(18,0) dcl 7364 in procedure "load" set ref 7361 7372* 7376 vp parameter fixed bin(18,0) dcl 7530 in procedure "store" ref 7527 7538 vsegname defined varying char(32) dcl 501 ref 590 vsize 000131 automatic fixed bin(18,0) dcl 940 set ref 1285* 1286 1354* 1361* 1426* 1428* 1443 1769* vsum 003577 automatic fixed bin(18,0) dcl 7758 set ref 7791* 7818* 7833* 7840* 8054* 8057 8071 8073* 8074* 8080* 8197* 8658* 8659 8660* 8663 8669 8680* 8687* 8688 8690* 8698* 8699 8700 8705* 8751* 8755* was_reserved 000127 automatic bit(1) dcl 6566 set ref 6609* 6612 what parameter bit(14) dcl 6842 ref 6837 6847