COMPILATION LISTING OF SEGMENT cobol_addr Compiled by: Multics PL/I Compiler, Release 31b, of April 24, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 05/24/89 0940.2 mst Wed Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1981 * 6* * * 7* *********************************************************** */ 8 9 10 11 12 /****^ HISTORY COMMENTS: 13* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), 14* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 15* MCR8060 cobol_addr.pl1 Added Trace statements. 16* 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8073), 17* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 18* MCR8073 cobol_addr.pl1 Correct handling of arrays longer than 379 19* elements. 20* 3) change(89-04-23,Zimmerman), approve(89-04-23,MCR8085), 21* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 22* MCR8085 cobol_addr.pl1 Stop code generator from aborting in move 23* statement. 24* END HISTORY COMMENTS */ 25 26 27 /* Modified on 11/26/84 by FCH, [5.3-3], BUG571(phx17008), release the PR */ 28 /* Modified on 11/15/84 by FCH, [5.3-2], BUG566(phx17927), large arrays for type 7 entries */ 29 /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ 30 /* Modified on 10/13/83 by FCH, [5.2-5], subscript bug, fixed by 5.3, phx13949(BUG541) */ 31 /* Modified on 10/13/83 by FCH, [5.2-4], subscript bug, fixed by 5.3, phx13954(BUG540) */ 32 /* Modified on 09/09/83 by FCH, [5.2-3], negative temp values correctly detected phx13533(BUG538) */ 33 /* Modified on 09/04/83 by FCH, [5.2-2], aregs not allocated correctly, phx13951(BUG540) */ 34 /* Modified on 08/14/83 by FCH, [5.2 ...], trace added */ 35 /* Modified on 08/14/83 by FCH, [5.2-1], indexing of large arrays still fails, phx14746(BUG548) phx13949(BUG541) */ 36 /* Modified on 11/04/81 by FCH, [5.1-1], indexing of large arrays fails, phx10955(BUG496) */ 37 /* Modified on 04/06/81 by FCH, [4.4-2], large array bit not set correctly, phx09543(BUG474) */ 38 /* Modified on 09/26/80 by FCH, [4.4-1], type 7 possibly generates incorrect code if subscripts used, BUG445 */ 39 /* Modified on 04/03/80 by FCH, [4.2-1], fix out-of-range subscript detection BUG430(TR4533) */ 40 /* Modified on 06/02/78 by FCH, [3.0-1], condition description put in automatic storage */ 41 /* Modified since Version 3.0 */ 42 43 44 45 46 47 48 49 50 /* format: style3 */ 51 cobol_addr: 52 proc (input_ptr, inst_ptr, reloc_ptr); 53 54 /***..... 55*dcl MY_NAME char (10) int static init ("COBOL_ADDR"); 56*/**/ 57 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 58 59 error_message.name = "cobol_addr"; 60 error_message.length = 80; /* [3.0-1] */ 61 62 /* unlock index, A, Q and temporary pointer registers */ 63 64 reg_struc_ptr = addr (reg_struc); /*[5.2-1]*/ 65 large_array = "0"b; 66 67 if input_struc.lock = 2 68 then do; 69 reg_struc.reg_num = "0011"b; 70 71 call cobol_register$release (reg_struc_ptr); 72 73 /*[5.2-2]*/ 74 do rxi = 8 to 15; 75 76 /*[5.2-2]*/ 77 reg_num = substr (unspec (rxi), 33, 4); 78 79 call cobol_register$release (reg_struc_ptr); 80 81 end; 82 83 call cobol_pointer_register$priority (2, 0, "001"b); 84 call cobol_pointer_register$priority (2, 0, "010"b); 85 call cobol_pointer_register$priority (2, 0, "111"b); 86 87 end; /* clean register and ptr used by addr array */ 88 89 /*[5.2-2]*/ 90 do rxi = 0 to 9; /*[5.2-2]*/ 91 addr_reg (rxi) = 0; /*[5.2-2]*/ 92 addr_ptr (rxi) = 0; 93 end; 94 95 struc_ptr = addr (ar_buff); 96 t = input_struc.type; 97 98 /*[5.2-3]*/ 99 if t <= 0 | t > 8 100 then do; 101 102 error_message.message = "Illegal type of addressing is specified. It must be 1<=i<=8."; 103 104 call signal_ ("command_abort_", null (), addr (error_message)); 105 106 call error_end_addr; 107 return; 108 end; 109 110 inst_b1_ptr = addr (inst_b1); 111 reloc_b1_ptr = addr (reloc_b1); 112 113 /* Process variable lenth item: results are saved in var_reg */ 114 115 do opr = 1 to 3; 116 var_reg (opr) = "000"b; 117 end; /* cobol_get_size is called to get PERFORM_GEN to perform the size paragraph */ 118 119 do opr = 1 to input_struc.operand_no; 120 121 if input_struc.operand.token_ptr (opr) ^= null () 122 then if input_struc.operand.size_sw (opr) = 0 123 then do; 124 dn_ptr = input_struc.operand.token_ptr (opr); 125 126 if data_name.variable_length 127 then do; 128 call cobol_get_size (dn_ptr, 0, 0); 129 130 /* The result in A is then loaded into an index register */ 131 132 /*[5.2-2]*/ 133 j = 5; 134 call get_reg (5); 135 136 var_reg (opr) = reg_no; 137 /* store index register no */ 138 139 /* EAXn: load A to index */ 140 141 inst_b1.wd = "000000000000000000110010000000000101"b; 142 substr (inst_b1.wd, 25, 3) = reg_no; 143 144 call cobol_emit (inst_b1_ptr, null (), 1); 145 146 end; 147 end; 148 end; 149 150 aj_const_off (1), aj_const_off (2), aj_const_off (3) = 0; 151 text_wd_off_save = cobol_$text_wd_off; 152 153 desc_an_ptr = addr (inst_struc.desc_ext); 154 desc_nn_ptr = addr (inst_struc.desc_ext); 155 156 if t = 5 | t = 6 157 then do; 158 index_array_i = 0; 159 index_array_flag = 1; 160 end; 161 else index_array_flag = 0; 162 163 /***..... if Trace_Bit then call ioa_("^a^a^d",substr(Trace_Line,Trace_Lev+1,1),MY_NAME||": ",t);/**/ 164 165 go to type (t); 166 167 168 169 170 /***** type(1) *****/ 171 172 type (1): 173 call type_1; 174 175 if reloc_ptr ^= null () 176 then call reloc; 177 178 addr_done: 179 call end_addr; 180 181 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 182 183 return; 184 185 186 /***** type(2) and type(3) *****/ 187 type (2): 188 type (3): 189 call type_2; 190 191 if reloc_ptr ^= null () 192 then call reloc; 193 194 go to addr_done; 195 196 197 /***** type(4), type(5) and type(6) *****/ 198 type (4): 199 type (5): 200 type (6): 201 call type_4; 202 203 go to addr_done; 204 205 /***** type(7) *****/ 206 type (7): 207 call type_7; 208 209 go to addr_done; 210 211 type_1: 212 proc; 213 214 215 i = 0; 216 217 inst_struc_basic.zero1 = "0"b; /* interupt inhibit */ 218 inst_struc_basic.tm = "00"b; /* r type addr mod */ 219 mseg_no = input_struc_basic.segno; 220 221 /* test for constants */ 222 223 if mseg_no = 3000 224 then do; 225 inst_struc_basic.td = "0100"b; /* (R)=IC, y=y+c(ic) */ 226 inst_struc_basic.pr_spec = "0"b; 227 temp = -(cobol_$text_wd_off + binary (substr (unspec (input_struc_basic.char_offset), 1, 34))); 228 string (inst_struc_basic.y) = substr (unspec (temp), 19, 18); 229 return; 230 end; 231 232 if mseg_no < 0 & input_struc_basic.char_offset = 0 233 then do; 234 inst_struc_basic.tm = "01"b; 235 inst_struc_basic.td = "0000"b; /* RI */ 236 temp = -(mseg_no); 237 end; 238 else do; 239 inst_struc_basic.td = "0000"b; /* no mod y=y */ 240 temp = binary (substr (unspec (input_struc_basic.char_offset), 17, 18)); 241 end; 242 243 inst_struc_basic.pr_spec = "1"b; 244 245 call get_ar; 246 247 inst_struc_basic.y.pr = ptr_no; 248 inst_struc_basic.y.wd_offset = substr (unspec (temp), 22, 15); 249 250 if mseg_no < 0 & input_struc_basic.char_offset ^= 0 251 then do; /* emit eppr pr4|n,* */ 252 253 inst_b1.wd = "100000000000000000011101000001010000"b; 254 255 call get_temp_ar; 256 257 substr (inst_b1.wd, 19, 10) = eppr_op; 258 temp = -mseg_no; 259 substr (inst_b1.wd, 4, 15) = substr (unspec (temp), 22, 15); 260 reloc_b1.r = "10100"b; 261 reloc_b1.l = "10100"b; 262 b1_count = 1; 263 264 call cobol_emit (inst_b1_ptr, reloc_b1_ptr, b1_count); 265 266 end; 267 268 /* lock handling */ 269 /* lock codes to be inserted */ 270 271 end; 272 273 type_2: 274 proc; 275 276 277 i = 0; 278 279 if input_struc.operand.token_ptr (1) = null () 280 then return; 281 282 dn_ptr = input_struc.operand.token_ptr (1); /* Set interupt inhibit bit to 0 */ 283 inst_struc_basic.zero1 = "0"b; /* R type address modification is used */ 284 inst_struc_basic.tm = "00"b; 285 mseg_no = data_name.seg_num; /* test for constants */ 286 287 if mseg_no = 3000 288 then do; 289 inst_struc_basic.td = "0100"b; 290 inst_struc_basic.pr_spec = "0"b; 291 temp = -(cobol_$text_wd_off + binary (substr (unspec (data_name.offset), 1, 34))); 292 string (inst_struc_basic.y) = substr (unspec (temp), 19, 18); 293 return; 294 295 end; /* No register mod is assumed. This assumption can be negated later */ 296 297 inst_struc_basic.td = "0000"b; /* none y=y */ 298 inst_struc_basic.pr_spec = "1"b; 299 temp = binary (substr (unspec (data_name.offset), 17, 18)); 300 301 /* Subscripts processing */ 302 /*[5.2-3]*/ 303 large_array = "0"b; 304 305 if data_name.subscripted 306 then do; 307 call subscripts; 308 309 if subs_error = 1 310 then do; 311 call error_end_addr; 312 go to addr_done; 313 end; 314 315 if no_reg_flag = 0 316 then do; 317 inst_struc_basic.td = "1000"b; 318 substr (inst_struc_basic.td, 2, 3) = reg_no; 319 320 end; 321 322 temp = temp - aj_off; /* Ajust offset to 0 occurence */ 323 324 if temp < 0 325 then do; 326 inst_b1.wd = "000000000000000000001110000000000011"b; 327 /* SBXN */ 328 temp = -temp + 1; 329 substr (inst_b1.wd, 1, 18) = substr (unspec (temp), 19, 18); 330 temp = 1; 331 substr (inst_b1.wd, 25, 3) = reg_no; 332 333 call cobol_emit (inst_b1_ptr, null (), 1); 334 335 end; 336 end; 337 338 call get_ar; 339 340 inst_struc_basic.y.pr = ptr_no; 341 inst_struc_basic.y.wd_offset = substr (unspec (temp), 22, 15); 342 343 if large_array 344 then if no_reg_flag = 0 345 then call ptr_adjust; 346 347 end; 348 349 350 type_4: 351 proc; 352 353 354 355 356 if input_struc.operand_no < 0 | input_struc.operand_no > 3 357 then do; 358 error_message.message = "Illegal operand number is specified. It must be 1, 2, or 3."; 359 360 call signal_ ("command_abort_", null (), addr (error_message)); 361 362 call error_end_addr; 363 return; 364 365 end; /* set zero bits in wd 1 */ 366 inst_struc.inst.zero1 = "00"b; 367 inst_struc.inst.zero3 = "0"b; 368 inst_struc.inst.zero5 = "0"b; /* Get reloc info for 1st word */ 369 i = 0; 370 mseg_no = 2; 371 372 if reloc_ptr ^= null () 373 then call reloc; 374 375 /* To handle the modification for Type 4, Type 5 and Type 6 instruction. */ 376 377 subs_error = 0; 378 379 if input_struc.operand_no < 3 380 then string (inst_struc.inst.mf3) = "0000000"b; 381 382 383 if input_struc.operand_no < 2 384 then string (inst_struc.inst.mf2) = "0000000"b; 385 386 387 do i = 1 to input_struc.operand_no; 388 389 if i = 1 390 then mf_ptr = addr (inst_struc.inst.mf1); 391 else if i = 2 392 then mf_ptr = addr (inst_struc.inst.mf2); 393 else mf_ptr = addr (inst_struc.inst.mf3); 394 395 call mf; 396 397 if subs_error = 1 398 then do; 399 call error_end_addr; 400 return; 401 end; 402 403 end; 404 405 end; 406 407 408 type_7: 409 proc; 410 411 412 413 414 i = 1; 415 416 inst_struc_basic.y.wd_offset = "0"b; 417 inst_struc_basic.zero1 = "0"b; 418 inst_struc_basic.pr_spec = "1"b; 419 inst_struc_basic.tm = "00"b; 420 inst_struc_basic.td = "1000"b; 421 422 dn_ptr = input_struc.operand.token_ptr (1); 423 mseg_no = data_name.seg_num; 424 425 if reloc_ptr ^= null () 426 then call reloc; 427 428 429 if ^data_name.subscripted 430 then do; 431 if substr (unspec (data_name.offset), 35, 2) = "00"b 432 then return; 433 434 435 /*[5.2-2]*/ 436 j = 0; 437 call get_reg (0); 438 439 /* ldxn */ 440 /*[4.4-1]*/ 441 inst_b1.wd = "000000000000000000000000000000000011"b; 442 /*[4.4-1]*/ 443 substr (inst_b1.wd, 17, 2) = substr (unspec (data_name.offset), 35, 2); 444 substr (inst_b1.wd, 19, 10) = "0100100000"b; 445 end; 446 else do; 447 call subscripts; 448 449 if subs_error = 1 450 then do; 451 call error_end_addr; 452 return; 453 end; 454 455 456 /* adxn */ 457 /*[4.4-1]*/ 458 inst_b1.wd = "000000000000000000000000000000000011"b; 459 /*[4.4-1]*/ 460 substr (inst_b1.wd, 17, 2) = substr (unspec (data_name.offset), 35, 2); 461 substr (inst_b1.wd, 19, 10) = "0001100000"b; 462 end; 463 464 substr (inst_b1.wd, 25, 3) = reg_no; 465 substr (inst_struc_basic.td, 2, 3) = reg_no; 466 467 /*[5.3-2]*/ 468 if substr (unspec (data_name.offset), 35, 2) ^= "00"b 469 then call cobol_emit (inst_b1_ptr, null (), 1); 470 471 /*[5.2-1]*/ 472 if large_array 473 then do; 474 ptr_no = inst_struc_basic.y.pr; 475 call ptr_adjust; 476 end; 477 478 end; 479 480 481 error_end_addr: 482 proc; 483 484 error_message.message = "Error exit from cobol_addr is taken. Process is not completed."; 485 call signal_ ("command_abort_", null (), addr (error_message)); 486 487 end; 488 489 end_addr: 490 proc; /* unlock all index registers and pointer registers used */ 491 492 493 494 495 /*[5.2-2]*/ 496 if input_struc.lock ^= 1 /*[5.2-2]*/ 497 then do; 498 rxi = 8; 499 if addr_reg (8) > 0 500 then call rr; /*[5.2-2]*/ 501 rxi = 9; 502 if addr_reg (9) > 0 503 then call rr; 504 505 /*[5.2-2]*/ 506 do rxi = 0 to 7; 507 508 /*[5.2-2]*/ 509 call rp; /*[5.2-2]*/ 510 end; 511 512 /*[5.2-2]*/ 513 end; 514 515 /*[5.2-2]*/ 516 temp1 = cobol_$text_wd_off - text_wd_off_save; 517 518 /*[5.2-2]*/ 519 if temp1 ^= 0 /*[5.2-2]*/ 520 then do p = 1 to 3; 521 522 /*[5.2-2]*/ 523 call md; 524 525 /*[5.2-2]*/ 526 end; 527 528 /*[5.2-2]*/ 529 return; 530 531 rr: 532 proc; 533 534 /*[5.2-2]*/ 535 do while (addr_reg (rxi) > 0); 536 537 /*[5.2-2]*/ 538 call release_reg (rxi); /*[5.2-2]*/ 539 addr_reg (rxi) = addr_reg (rxi) - 1; 540 541 /*[5.2-2]*/ 542 end; 543 544 end; 545 546 rp: 547 proc; 548 549 /*[5.2-2]*/ 550 if addr_reg (rxi) > 0 551 then call rr; /*[5.2-2]*/ 552 if addr_reg (rxi) > 0 553 then call rpr; 554 555 end; 556 557 rpr: 558 proc; 559 560 /*[5.2-2]*/ 561 do while (addr_ptr (rxi) > 0); 562 563 /*[5.2-2]*/ 564 call cobol_pointer_register$priority (2, 0, substr (unspec (rxi), 34, 3)); 565 /*[5.2-2]*/ 566 addr_ptr (rxi) = addr_ptr (rxi) - 1; 567 568 /*[5.2-2]*/ 569 end; 570 571 end; 572 573 md: 574 proc; 575 576 /*[5.2-2]*/ 577 if aj_const_off (p) ^= 0 /*[5.2-2]*/ 578 then do; 579 temp = binary (string (desc_an.desc_f.y (p))); 580 /*[5.2-2]*/ 581 temp = temp - temp1; /*[5.2-2]*/ 582 string (desc_an.desc_f.y (p)) = substr (unspec (temp), 19, 18); 583 /*[5.2-2]*/ 584 end; 585 586 end; 587 588 589 end; 590 591 592 mf: 593 proc; 594 595 /***..... dcl MY_NAME char (2) int static init ("MF"); 596* /**/ 597 598 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 599 600 /* This procedure is called to set up The i'th 601* modification field and operand */ 602 603 if input_struc.operand.token_ptr (i) = null () 604 then return; 605 606 /* Set type 9 ptr */ 607 dn_ptr = input_struc.operand.token_ptr (i); 608 mseg_no = data_name.seg_num; /*[5.2-1]*/ 609 large_array = "0"b; 610 611 /* To process the special segment mseg_no is between 612* 20000(octal) to 27777(octal) */ 613 614 if mseg_no > 8191 & mseg_no < 12288 615 then do; 616 special_bit = "1"b; 617 618 /*[5.2-1]*/ 619 reg_bit = substr (mseg_no_bit, 25, 1); /*[5.2-1]*/ 620 disp_bit = substr (mseg_no_bit, 29, 1); 621 mf_temp.pr_spec = "1"b; 622 623 mf_temp.reg_or_length = reg_bit; 624 625 if disp_bit 626 then mf_temp.reg_mod = substr (mseg_no_bit, 29, 4); 627 else mf_temp.reg_mod = "0000"b; 628 end; 629 else do; 630 special_bit, reg_bit, disp_bit = "0"b; /* Process constants */ 631 632 if mseg_no = 3000 633 then do; 634 input_struc.operand.ic_mod (i) = 1; 635 aj_const_off (i) = i; 636 mf_temp.pr_spec = "0"b; 637 mf_temp.reg_mod = "0100"b; /* y=y+c(ic) */ 638 end; 639 else do; 640 mf_temp.pr_spec = "1"b; 641 642 if ^data_name.subscripted 643 then mf_temp.reg_mod = "0000"b; 644 else do; /* Subscripts processing */ 645 646 call subscripts; 647 if subs_error = 1 648 then return; 649 650 if no_reg_flag = 0 651 then do; 652 mf_temp.reg_mod = "1000"b; 653 substr (mf_temp.reg_mod, 2, 3) = reg_no; 654 end; 655 else mf_temp.reg_mod = "0000"b; 656 657 end; 658 end; 659 660 /* Length is contained in register or instruction */ 661 662 if input_struc.operand.size_sw (i) = 0 663 then do; 664 if data_name.item_length > 4095 | data_name.variable_length 665 then mf_temp.reg_or_length = "1"b; 666 else mf_temp.reg_or_length = "0"b; 667 end; 668 669 end; 670 671 mf_temp.zero2 = "0"b; 672 673 /* To set up operand */ 674 675 if (data_name.bin_36 | data_name.bin_18 | data_name.alphanum | data_name.alphabetic 676 | data_name.alphanum_edited | data_name.alphabetic_edited | data_name.non_elementary 677 | data_name.numeric_edited | data_name.usage_index) 678 then do; 679 call desc_anp; 680 681 if large_array 682 then if no_reg_flag = 0 683 then call ptr_adjust; 684 end; 685 else if data_name.numeric 686 then do; 687 call desc_nnp; 688 689 if large_array 690 then if no_reg_flag = 0 691 then call ptr_adjust; 692 end; 693 694 else do; 695 696 error_message.message = 697 "Illegal data type is specified for eis descriptor " || substr (desc_no_char, i, 1) || "."; 698 699 call signal_ ("command_abort_", null (), addr (error_message)); 700 end; 701 702 end; 703 704 705 706 desc_anp: 707 proc; 708 709 /***..... dcl MY_NAME char (8) int static init ("DESC_ANP"); 710* /**/ 711 712 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 713 714 /* Build alphanumeric descriptor */ 715 desc_an.desc_f.zero1 (i) = "0"b; 716 desc_an.desc_f.ta (i) = "00"b; /* 9 bit */ 717 718 /* Process constants */ 719 if mseg_no = 3000 720 then do; 721 temp = -(text_wd_off_save + binary (substr (unspec (data_name.offset), 1, 34))); 722 string (desc_an.desc_f.y (i)) = substr (unspec (temp), 19, 18); 723 desc_an.desc_f.char_n (i) = "000"b; 724 substr (desc_an.desc_f.char_n (i), 1, 2) = substr (unspec (data_name.offset), 35, 2); 725 end; 726 727 else if special_bit 728 then do; 729 desc_an.desc_f.y.pr (i) = substr (mseg_no_bit, 34, 3); 730 desc_an.desc_f.y.wd_offset (i) = (15)"0"b; 731 desc_an.desc_f.char_n (i) = "000"b; 732 end; 733 else do; 734 temp = data_name.offset; 735 736 if data_name.subscripted 737 then temp = temp - aj_off; /* adjust offset to 0 occurence */ 738 739 desc_an.desc_f.char_n (i) = "000"b; 740 substr (desc_an.desc_f.char_n (i), 1, 2) = substr (unspec (temp), 35, 2); 741 742 if temp < 0 743 then if mod (temp, 4) ^= 0 744 then temp = temp - 4; 745 746 temp = divide (temp, 4, 35, 0); 747 748 if data_name.subscripted 749 then if (temp < 0 & ^data_name.linkage_section) 750 then call offset_adjust; 751 752 call get_ar; 753 754 desc_an.desc_f.y.pr (i) = ptr_no; 755 desc_an.desc_f.y.wd_offset (i) = substr (unspec (temp), 22, 15); 756 end; /* Set length */ 757 758 if special_bit & reg_bit 759 then do; 760 desc_an.desc_f.n (i) = "000000001000"b; 761 substr (desc_an.desc_f.n (i), 10, 3) = substr (mseg_no_bit, 26, 3); 762 end; 763 else do; 764 765 if input_struc.operand.size_sw (i) = 0 766 then do; 767 768 if data_name.item_length < 4095 & ^data_name.variable_length 769 then desc_an.desc_f.n (i) = substr (unspec (data_name.item_length), 25, 12); 770 else do; 771 desc_an.desc_f.n (i) = "000000001000"b; 772 773 if data_name.variable_length 774 then substr (desc_an.desc_f.n (i), 10, 3) = var_reg (i); 775 else do; 776 call get_length; 777 778 substr (desc_an.desc_f.n (i), 10, 3) = reg_no; 779 780 end; 781 end; 782 end; 783 end; 784 785 if reloc_ptr ^= null () 786 then call reloc; 787 788 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 789 790 end; 791 792 793 794 desc_nnp: 795 proc; 796 797 /***..... dcl MY_NAME char (8) int static init ("DESC_NNP"); 798* /**/ 799 800 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 801 802 /* Build numeric descriptor */ 803 /* 4 bit */ 804 805 if data_name.ascii_packed_dec 806 then desc_nn.desc_f.tn (i) = "1"b; 807 else desc_nn.desc_f.tn (i) = "0"b; /* 9 bit */ 808 809 /* Process constants */ 810 811 if mseg_no = 3000 812 then do; 813 temp = -(text_wd_off_save + binary (substr (unspec (data_name.offset), 1, 34))); 814 string (desc_nn.desc_f.y (i)) = substr (unspec (temp), 19, 18); 815 816 /* 4 bit */ 817 if data_name.ascii_packed_dec 818 then do; 819 temp_p = data_name.places_left + data_name.places_right; 820 821 if data_name.item_signed 822 then temp_p = temp_p + 1; 823 824 temp1 = 2 * binary (substr (unspec (data_name.offset), 35, 2)); 825 826 if data_name.ascii_packed_dec_h 827 then if bit_offset = "0101"b 828 then temp1 = temp1 + 1; 829 else ; 830 else temp1 = temp1 + mod (temp_p, 2); 831 832 833 834 desc_nn.desc_f.digit_n (i) = substr (unspec (temp1), 34, 3); 835 end; 836 else do; 837 desc_nn.desc_f.digit_n (i) = "000"b; 838 substr (desc_nn.desc_f.digit_n (i), 1, 2) = substr (unspec (data_name.offset), 35, 2); 839 end; 840 end; 841 842 else if special_bit 843 then do; 844 desc_nn.desc_f.y.pr (i) = substr (mseg_no_bit, 34, 3); 845 desc_nn.desc_f.y.wd_offset (i) = (15)"0"b; 846 desc_nn.desc_f.digit_n (i) = "000"b; 847 end; 848 else do; 849 temp = data_name.offset; 850 temp_p = data_name.places_left + data_name.places_right; 851 852 if data_name.item_signed 853 then temp_p = temp_p + 1; 854 855 856 if data_name.ascii_packed_dec 857 then do; 858 859 if data_name.subscripted 860 then temp = temp * 2 - aj_off; 861 else temp = temp * 2; 862 if data_name.ascii_packed_dec_h 863 then if bit_offset = "0101"b 864 then temp = temp + 1; 865 866 temp1 = binary (substr (unspec (temp), 34, 3)); 867 868 if ^data_name.ascii_packed_dec_h 869 then temp1 = temp1 + mod (temp_p, 2); 870 871 desc_nn.desc_f.digit_n (i) = substr (unspec (temp1), 34, 3); 872 if temp < 0 873 then if mod (temp, 8) ^= 0 874 then temp = temp - 8; 875 876 temp = divide (temp, 8, 35, 0); 877 878 end; 879 else do; 880 881 if data_name.subscripted 882 then temp = temp - aj_off; 883 884 885 desc_nn.desc_f.digit_n (i) = "000"b; 886 substr (desc_nn.desc_f.digit_n (i), 1, 2) = substr (unspec (temp), 35, 2); 887 888 if temp < 0 889 then if mod (temp, 4) ^= 0 890 then temp = temp - 4; 891 892 893 894 temp = divide (temp, 4, 35, 0); 895 896 end; /* Adjust the 0 occurrence 11/10/75 bc */ 897 898 if data_name.subscripted 899 then if (temp < 0 & ^(data_name.linkage_section)) 900 then call offset_adjust; 901 902 call get_ar; 903 904 desc_nn.desc_f.y.pr (i) = ptr_no; 905 desc_nn.desc_f.y.wd_offset (i) = substr (unspec (temp), 22, 15); 906 907 end; 908 909 910 /* If size_sw is on, the following is ignored */ 911 912 if input_struc.operand.size_sw (i) = 0 913 then do; 914 if data_name.variable_length 915 then do; 916 desc_nn.desc_f.n (i) = "001000"b; 917 substr (desc_nn.desc_f.n (i), 4, 3) = var_reg (i); 918 end; 919 else if data_name.ascii_packed_dec 920 then desc_nn.desc_f.n (i) = substr (unspec (temp_p), 31, 6); 921 else desc_nn.desc_f.n (i) = substr (unspec (data_name.item_length), 31, 6); 922 923 /* Set sign type */ 924 if data_name.sign_type = "000"b 925 then desc_nn.desc_f.sign_type (i) = "11"b; 926 /* no sign */ 927 928 if data_name.ascii_packed_dec & data_name.item_signed 929 then do; 930 931 if data_name.ascii_packed_dec_h 932 then desc_nn.desc_f.sign_type (i) = "01"b; 933 /* leading separate */ 934 else desc_nn.desc_f.sign_type (i) = "10"b; 935 /* trailing separate */ 936 937 end; 938 939 if data_name.sign_type = "011"b 940 then desc_nn.desc_f.sign_type (i) = "10"b; 941 /* Trailing separate. */ 942 943 if data_name.sign_type = "100"b /* leading separate */ 944 then desc_nn.desc_f.sign_type (i) = "01"b; 945 946 /* sign_type "111"b : leading separate for floating decimal */ 947 948 if data_name.sign_type = "111"b 949 then desc_nn.desc_f.sign_type (i) = "00"b; 950 951 /* trailing "001" and leading "010" sign types are not supported */ 952 953 temp1 = -(data_name.places_right); 954 desc_nn.desc_f.scal (i) = substr (unspec (temp1), 31, 6); 955 956 end; 957 958 if special_bit & reg_bit 959 then do; 960 substr (desc_nn.desc_f.n (i), 1, 2) = "00"b; 961 substr (desc_nn.desc_f.n (i), 3, 4) = substr (mseg_no_bit, 25, 4); 962 end; 963 964 if reloc_ptr ^= null () 965 then call reloc; 966 967 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 968 969 end; 970 971 972 973 offset_adjust: 974 proc; 975 976 /***..... dcl MY_NAME char(13) int static init ("OFFSET_ADJUST"); 977*/**/ 978 979 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 980 981 /*[5.2-1]*/ 982 dcl (i, j, k, m, l) fixed bin (35); 983 984 985 dcl offset_cmp (14) bit (18) static unaligned init ("000000000000000000"b, "001000000000000011"b, 986 /* cmpxn temp,du */ 987 "000000000000000100"b, "110000101000000100"b, 988 /* tpl 4,ic */ 989 "000000000000000000"b, "000110101000000011"b, 990 /* adxn 2**j-mod(temp,2**j),du */ 991 "000000000000000000"b, "000110101000000011"b, 992 /* adxm -2*(divide(temp,2**j)+1),du */ 993 "000000000000000011"b, "111001000000000100"b, 994 /* tra 3,ic */ 995 "000000000000000000"b, "001110000000000011"b, 996 /* sbxn temp,du */ 997 "000000000000000000"b, "000110101000000011"b); 998 /* adxm -2*divide(temp,2**j),du */ 999 1000 temp = -temp + 1; 1001 1002 if data_name.ascii_packed_dec 1003 then do; 1004 i = 16384; 1005 j = 15; 1006 end; 1007 else do; 1008 i = 32768; 1009 j = 16; 1010 end; 1011 1012 1013 1014 l = 37 - j; 1015 1016 if large_array 1017 then do; 1018 if temp > (i - 1) 1019 then do; 1020 k = -2 * divide (temp, i, 35, 0); 1021 temp = mod (temp, i); 1022 end; 1023 1024 else k = 0; 1025 1026 /*[5.2-1]*/ 1027 call st (1); 1028 1029 substr (offset_cmp (2), 7, 3) = reg_no; 1030 substr (offset_cmp (6), 7, 3) = reg_no; 1031 substr (offset_cmp (12), 7, 3) = reg_no; 1032 substr (offset_cmp (8), 7, 3) = table_reg; 1033 substr (offset_cmp (14), 7, 3) = table_reg; 1034 1035 /*[5.2-1]*/ 1036 call st (11); 1037 1038 offset_cmp (13) = substr (unspec (k), 19, 18); 1039 1040 m = k - 2; 1041 offset_cmp (7) = substr (unspec (m), 19, 18); 1042 1043 temp = i - temp; /*[5.2-1]*/ 1044 call st (5); 1045 1046 if m = 0 1047 then do; 1048 offset_cmp (3) = "000000000000000011"b; 1049 call cobol_emit (addr (offset_cmp (1)), null (), 3); 1050 1051 end; 1052 else do; 1053 offset_cmp (3) = "000000000000000100"b; 1054 call cobol_emit (addr (offset_cmp (1)), null (), 4); 1055 1056 end; 1057 1058 if k = 0 1059 then do; 1060 offset_cmp (9) = "000000000000000010"b; 1061 call cobol_emit (addr (offset_cmp (9)), null (), 2); 1062 1063 end; 1064 else do; 1065 offset_cmp (9) = "000000000000000011"b; 1066 call cobol_emit (addr (offset_cmp (9)), null (), 3); 1067 1068 end; 1069 end; 1070 else if temp ^= 0 /*[5.2-1]*/ 1071 then do; 1072 call st (11); 1073 1074 substr (offset_cmp (12), 7, 3) = reg_no; 1075 1076 call cobol_emit (addr (offset_cmp (11)), null (), 1); 1077 1078 end; 1079 temp = 1; 1080 1081 return; 1082 1083 st: 1084 proc (i); 1085 1086 dcl i fixed bin; 1087 1088 offset_cmp (i) = substr (unspec (temp), l); 1089 end; 1090 1091 end offset_adjust; 1092 1093 ptr_adjust: 1094 proc; 1095 1096 /***..... dcl MY_NAME char(10) int static init ("PTR_ADJUST"); 1097* /**/ 1098 1099 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 1100 1101 /* large arrays */ 1102 /* EAQ 0,xm */ 1103 inst_b1.wd = "000000000000000000110011110000001000"b; 1104 substr (inst_b1.wd, 34, 3) = table_reg; /* QLS 14 */ 1105 /*[5.2-1]*/ 1106 inst_b1.wd1 = "000000000000001110111011110000000000"b; 1107 /* QLS 13 for packed_dec */ 1108 /*[5.2-1]*/ 1109 if data_name.ascii_packed_dec 1110 then substr (inst_b1.wd1, 13, 6) = "001101"b; 1111 1112 /* STQ pr6|table_ext_off */ 1113 1114 if table_ext_off = 0 1115 then call cobol_alloc$stack (4, 1, table_ext_off); 1116 1117 1118 inst_b1.wd2 = "110000000000000000111101110001000000"b; 1119 substr (inst_b1.wd2, 4, 15) = substr (unspec (table_ext_off), 22, 15); 1120 /* ADWPN pr6|table_ext_off */ 1121 inst_b1.wd3 = "110000000000000000000101000001000000"b; 1122 substr (inst_b1.wd3, 4, 15) = substr (inst_b1.wd2, 4, 15); 1123 1124 if ptr_no = "100"b 1125 then substr (inst_b1.wd3, 25, 3) = ptr_no; 1126 else do; 1127 substr (inst_b1.wd3, 21, 1) = substr (ptr_no, 1, 1); 1128 substr (inst_b1.wd3, 26, 2) = substr (ptr_no, 2, 2); 1129 end; 1130 1131 call cobol_emit (inst_b1_ptr, null (), 4); 1132 1133 end; 1134 1135 1136 1137 get_length: 1138 proc; 1139 1140 /* Load length in to index register */ 1141 /* ldxn */ 1142 1143 inst_b1.wd = "000000000000000000010010000000000011"b; 1144 substr (inst_b1.wd, 1, 18) = substr (unspec (data_name.item_length), 19, 18); 1145 1146 /*[5.2-2]*/ 1147 j = 5; 1148 call get_reg (5); 1149 1150 substr (inst_b1.wd, 25, 3) = reg_no; 1151 1152 call cobol_emit (inst_b1_ptr, null (), 1); 1153 1154 end; 1155 1156 1157 1158 reloc: 1159 proc; 1160 1161 if mseg_no = 3002 1162 then do; 1163 reloc_struc.left_wd (i + 1) = "11001"b; 1164 reloc_struc.right_wd (i + 1) = "11001"b; 1165 end; 1166 else if mseg_no < 0 1167 then do; 1168 reloc_struc.left_wd (i + 1) = "10100"b; 1169 reloc_struc.right_wd (i + 1) = "10100"b; 1170 end; 1171 else do; 1172 reloc_struc.left_wd (i + 1) = "00000"b; 1173 reloc_struc.right_wd (i + 1) = "00000"b; 1174 end; 1175 end; 1176 1177 1178 1179 get_ar: 1180 proc; 1181 1182 dcl ar_type fixed bin; 1183 1184 /* 1185* When cobol_$ptr_assumption_ind=0 the assumptions made about the usage of the pointer registers are valid. 1186* The assumptions are: 1187* 1188* PR0 cobol operator entry (PR6^24) 1189* PR3 cobol data 16k (40000 octal) word offset (PR6^64) 1190* PR5 cobol data 48k (140000 octal) word offset (PR6^66) 1191* (If cobol data is less than 32k, PR5 is used as a temporary) 1192* PR4 multices linkage section 1193* PR6 stack frame 1194* 1195* 1196* PR1, PR2, PR7, and sometimes PR5 are temporary registers. 1197* 1198* The use of temporary registers must be requested. 1199**/ 1200 ar_type = 0; 1201 1202 if mseg_no > 4999 & mseg_no < 5008 1203 then ar_type = 1; 1204 else if mseg_no = 2 1205 then do; 1206 if temp > 262143 1207 then ar_type = 2; 1208 else if ^large_array 1209 then if temp < 32768 1210 then ar_type = 3; 1211 else if temp >= 32768 & temp < 65536 1212 then ar_type = 4; 1213 else ar_type = 5; 1214 else ar_type = 5; 1215 end; 1216 else if mseg_no = 4000 | mseg_no = 3 1217 then ar_type = 6; 1218 else if mseg_no = 3002 1219 then ar_type = 7; 1220 else if mseg_no = 1000 1221 then ar_type = 8; 1222 else if mseg_no = 0 | mseg_no > 20000 1223 then do; 1224 if input_struc.type ^= 1 & data_name.linkage_section 1225 then ar_type = 9; 1226 end; 1227 else if mseg_no < 0 1228 then ar_type = 10; 1229 1230 go to art (ar_type); 1231 1232 /* special segment no 500n n=ptr_no */ 1233 1234 art (1): 1235 ptr_no = substr (unspec (mseg_no), 34, 3); 1236 1237 go to artx; 1238 1239 art (2): 1240 error_message.message = "Illegal offset is specified. It must be <262143"; 1241 call signal_ ("command_abort_", null (), addr (error_message)); 1242 1243 go to artx; 1244 1245 art (3): 1246 temp = temp - 16384; 1247 ptr_no = "011"b; 1248 1249 /* Check pointer register 3 status */ 1250 p = 3; /* pointer register 3 */ 1251 1252 if ^(ptr_status.seg_num (p) = 2 & ptr_status.wd_offset (p) = 16384) 1253 then call reset; 1254 1255 go to artx; 1256 1257 art (4): 1258 temp = temp - 49152; 1259 ptr_no = "101"b; /* Check pointer register 5 is set */ 1260 p = 5; 1261 1262 if ^(ptr_status.seg_num (p) = 2 & ptr_status.wd_offset (p) = 49152) 1263 then call reset; 1264 1265 go to artx; 1266 1267 /* Load temporary pointer register for data >65536 */ 1268 /* eppr pr6|156,* 7/9/76 */ 1269 1270 art (5): 1271 inst_b1.wd = "110000000001101110000000000001010000"b; 1272 1273 call get_temp_ar; 1274 1275 substr (inst_b1.wd, 19, 10) = eppr_op; 1276 substr (inst_b1.wd1, 19, 10) = adwp_op; /* adwpr n,du */ 1277 substr (inst_b1.wd1, 29, 8) = "00000011"b; 1278 1279 /* i = temp/32768; if i >= 2 then adwp_du = 16384 + i * 32768 */ 1280 1281 1282 /*[5.2-3]*/ 1283 adwp_du = divide (temp, 32768, 35, 0) * 32768 + 16384; 1284 1285 temp = temp - adwp_du; 1286 adwp_du = adwp_du - 16384; 1287 substr (inst_b1.wd1, 1, 18) = substr (unspec (adwp_du), 19, 18); 1288 1289 1290 1291 if adwp_du ^= 0 1292 then call cobol_emit (inst_b1_ptr, null (), 2); 1293 else call cobol_emit (inst_b1_ptr, null (), 1); 1294 1295 go to artx; 1296 1297 art (6): 1298 ptr_no = "000"b; /* Check pointer register 0 status */ 1299 p = 0; 1300 1301 if ^((ptr_status.seg_num (p) = 3 | ptr_status.seg_num (p) = 4000) & ptr_status.wd_offset (p) = 0) 1302 then call reset; 1303 1304 go to artx; 1305 1306 art (7): 1307 ptr_no = "100"b; /* Check pointer register 4 status */ 1308 p = 4; 1309 1310 if ^(ptr_status.seg_num (p) = 3002 & ptr_status.wd_offset (p) = 0) 1311 then call reset; 1312 1313 go to artx; 1314 1315 art (8): 1316 ptr_no = "110"b; 1317 p = 6; 1318 1319 if ^(ptr_status.seg_num (p) = 1000 & ptr_status.wd_offset (p) = 0) 1320 then call reset; 1321 1322 go to artx; 1323 1324 art (9): 1325 inst_b1.wd = "110000000000011010000000000001010000"b; 1326 1327 /* epp6|26,* */ 1328 call get_temp_ar; 1329 1330 substr (inst_b1.wd, 19, 10) = eppr_op; /* eppr prr|2*n,* */ 1331 substr (inst_b1.wd1, 1, 3) = ptr_no; 1332 temp1 = 2 * data_name.linkage; 1333 substr (inst_b1.wd1, 4, 15) = substr (unspec (temp1), 22, 15); 1334 substr (inst_b1.wd1, 19, 10) = eppr_op; 1335 substr (inst_b1.wd1, 29, 8) = "01010000"b; 1336 1337 call cobol_emit (inst_b1_ptr, null (), 2); 1338 1339 go to artx; 1340 1341 art (10): /* eppr pr4|(-mseg_no),* */ 1342 inst_b1.wd = "100000000000000000000000000001010000"b; 1343 1344 call get_temp_ar; 1345 1346 substr (inst_b1.wd, 19, 10) = eppr_op; 1347 temp1 = -mseg_no; 1348 substr (inst_b1.wd, 4, 15) = substr (unspec (temp1), 22, 15); 1349 reloc_b1.r = "10100"b; 1350 reloc_b1.l = "10100"b; 1351 1352 call cobol_emit (inst_b1_ptr, reloc_b1_ptr, 1); 1353 1354 go to artx; /* Error */ 1355 1356 art (0): 1357 error_message.message = "Segment number error."; 1358 call signal_ ("command_abort_", null (), addr (error_message)); 1359 1360 artx: 1361 return; 1362 1363 reset: 1364 proc; /* Reset pointer register */ 1365 1366 call cobol_reset_r$pointer_register (ptr_no); 1367 1368 error_message.message = "the pointer register is reset!"; 1369 call signal_ ("command_abort_", null (), addr (error_message)); 1370 1371 end; 1372 1373 end get_ar; 1374 1375 get_temp_ar: 1376 proc; 1377 1378 /* Get a temporary pointer register 1, 2, 7 or 5 and lock it */ 1379 1380 ptr_no = "000"b; 1381 1382 /*[5.2-2]*/ 1383 rxi = 1; 1384 if ptr_status.p_lock (1) = 0 1385 then do; 1386 call tl; 1387 return; 1388 end; /*[5.2-2]*/ 1389 rxi = 2; 1390 if ptr_status.p_lock (2) = 0 1391 then do; 1392 call tl; 1393 return; 1394 end; /*[5.2-2]*/ 1395 rxi = 7; 1396 if ptr_status.p_lock (7) = 0 1397 then do; 1398 call tl; 1399 return; 1400 end; 1401 1402 /*[5.2-2]*/ 1403 rxi = 1; 1404 if addr_ptr (1) = 0 1405 then do; 1406 call tpr; 1407 return; 1408 end; /*[5.2-2]*/ 1409 rxi = 2; 1410 if addr_ptr (2) = 0 1411 then do; 1412 call tpr; 1413 return; 1414 end; /*[5.2-2]*/ 1415 rxi = 7; 1416 if addr_ptr (7) = 0 1417 then do; 1418 call tpr; 1419 return; 1420 end; /*[5.2-2]*/ 1421 rxi = 5; 1422 if addr_ptr (5) = 0 1423 then do; 1424 call tpr; 1425 return; 1426 end; 1427 1428 1429 error_message.message = "Unable to get a temporary pointer register."; 1430 call signal_ ("command_abort_", null (), addr (error_message)); 1431 1432 return; 1433 1434 1435 tl: 1436 proc; 1437 1438 /*[5.2-2]*/ 1439 ptr_status.p_lock (rxi) = 1; 1440 addr_ptr (rxi) = 1; /*[5.2-2]*/ 1441 ptr_no = substr (unspec (rxi), 34, 3); 1442 1443 call set_adwp; 1444 1445 end; 1446 1447 tpr: 1448 proc; 1449 1450 /*[5.2-2]*/ 1451 structure.what_pointer = rxi; 1452 structure.lock = 1; 1453 structure.switch = 0; 1454 1455 call cobol_pointer_register$get (struc_ptr); 1456 1457 ptr_no = pointer_no; /*[5.2-2]*/ 1458 ptr_status.p_lock (rxi) = 1; /*[5.2-2]*/ 1459 addr_ptr (rxi) = 1; 1460 1461 call set_adwp; 1462 1463 end; 1464 1465 set_adwp: 1466 proc; 1467 1468 /*[5.2-2]*/ 1469 if rxi = 1 1470 then do; 1471 eppr_op = "0111010011"b; 1472 adwp_op = "0001010010"b; /* 051(0) */ 1473 end; 1474 1475 /*[5.2-2]*/ 1476 else if rxi = 2 1477 then do; 1478 eppr_op = "0111010100"b; /* 352(0) */ 1479 adwp_op = "0001010100"b; /* 052(0) */ 1480 end; 1481 1482 /*[5.2-2]*/ 1483 else if rxi = 7 1484 then do; 1485 eppr_op = "0111110111"b; 1486 adwp_op = "0011010110"b; /* 153(0) */ 1487 end; 1488 1489 /*[5.2-2]*/ 1490 else if rxi = 5 1491 then do; 1492 eppr_op = "0111110011"b; 1493 adwp_op = "0011010010"b; /* 151(0) */ 1494 end; 1495 1496 end; 1497 1498 end get_temp_ar; 1499 1500 1501 1502 get_reg: 1503 proc (reg); 1504 1505 /* 1506* If the reg_assumption_ind is on, 1507* then the assumptions made about the usage of the index 1508* registers are valid. The use of A or Q register must be requested. 1509* The index register usage are: 1510* 0: return address cobol operator 1511* 1: temporary 1512* 2: address modification 1513* 3: address modification 1514* 4: address modification 1515* 1516* 5: eis operand length 1517* 6: eis operand length 1518* 7:eis operand length 1519* If the above suggested registers are not available other registers will be used. 1520* The registers are temporarily locked for cobol_addr. They will be unlocked at 1521* cobol_addr exit unless directed otherwise. 1522**/ 1523 1524 /*[5.2-2]*/ 1525 dcl reg fixed bin; 1526 1527 /*[5.2-2]*/ 1528 rx = reg; 1529 r_max = 7; 1530 1531 do while ("1"b); 1532 1533 if reg_status.r_lock (rx) = 0 & addr_reg (rx) = 0 1534 then do; 1535 reg_status.r_lock (rx) = 1; 1536 reg_no = substr (unspec (rx), 34, 3); 1537 addr_reg (rx) = addr_reg (rx) + 1; 1538 1539 return; 1540 end; 1541 else do; 1542 1543 rx = rx + 1; 1544 1545 if rx <= r_max 1546 then ; 1547 else if reg = 5 /*[5.2-2]*/ 1548 then do; 1549 rx, j = 1; 1550 r_max = 4; 1551 end; 1552 1553 else if reg = 2 /*[5.2-2]*/ 1554 then do; 1555 rx, j = 1; 1556 r_max = 1; 1557 end; 1558 else do; 1559 1560 do rx = 1 to 7; 1561 1562 if addr_reg (rx) = 0 1563 then do; 1564 reg_struc.what_reg = rx + 10; 1565 reg_struc.lock = 1; 1566 1567 call cobol_register$load (reg_struc_ptr); 1568 1569 reg_no = substr (reg_struc.reg_num, 2, 3); 1570 addr_reg (fixed (reg_no)) = addr_reg (fixed (reg_no)) + 1; 1571 return; 1572 end; 1573 end; 1574 1575 error_message.message = "Unable to get an index register"; 1576 call signal_ ("command_abort_", null (), addr (error_message)); 1577 1578 end; 1579 1580 end; 1581 1582 end; 1583 1584 end; 1585 1586 1587 1588 get_a_q: 1589 proc (reg); 1590 1591 /*[5.2-2]*/ 1592 dcl reg fixed bin; /* Requested A or Q register */ 1593 /* rx=8 for A-reg. rx=9 for Q-reg. */ 1594 1595 reg_struc.lock = 1; 1596 1597 /*[5.2-2]*/ 1598 if reg ^= 10 /*[5.2-2]*/ 1599 then if reg_status.r_lock (reg) = 0 /*[5.2-2]*/ 1600 then do; 1601 reg_status.r_lock (reg) = 1; /*[5.2-2]*/ 1602 addr_reg (reg) = addr_reg (reg) + 1; 1603 1604 /*[5.2-2]*/ 1605 if reg = 8 1606 then reg_struc.reg_num = "0001"b; /*[5.2-2]*/ 1607 else if reg = 9 1608 then reg_struc.reg_num = "0010"b; 1609 return; 1610 1611 end; 1612 1613 /*[5.2-2]*/ 1614 if reg = 10 1615 then reg_struc.reg_num = "0011"b; 1616 1617 1618 reg_struc.what_reg = reg - 7; 1619 1620 call cobol_register$load (reg_struc_ptr); 1621 1622 reg_no = substr (reg_struc.reg_num, 2, 3); 1623 addr_reg (fixed (reg_no)) = addr_reg (fixed (reg_no)) + 1; 1624 1625 end; 1626 1627 1628 1629 release_reg: 1630 proc (reg); 1631 1632 /*[5.2-2]*/ 1633 dcl (reg, r, ar) fixed bin; 1634 1635 /*[5.2-2]*/ 1636 r = reg; 1637 1638 /*[5.2-2]*/ 1639 if r ^= 10 /*[5.2-2]*/ 1640 then do; 1641 ar = addr_reg (r); /*[5.2-2]*/ 1642 if ar ^= 0 1643 then addr_reg (r) = ar - 1; /*[5.2-2]*/ 1644 end; 1645 1646 /*[5.2-2]*/ 1647 if r < 8 1648 then r = r + 8; 1649 else r = r - 7; 1650 1651 /*[5.2-2]*/ 1652 reg_struc.reg_num = substr (unspec (r), 33, 4); 1653 1654 call cobol_register$release (reg_struc_ptr); 1655 1656 end; 1657 1658 1659 1660 subscripts: 1661 proc; 1662 1663 /***..... dcl MY_NAME char (10) int static init ("SUBSCRIPTS"); 1664*/**/ 1665 1666 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 1667 1668 dcl desc_nn_ptr_save ptr; 1669 1670 dcl 1 token_temp based (temp_ptr), 1671 2 filler4 char (12), 1672 2 type fixed bin; 1673 1674 dcl (a_lock_save, q_lock_save) 1675 fixed bin; 1676 dcl mpy_bit bit (1) static init ("0"b); 1677 1678 dcl subs_token_ptr ptr based (subs_ptr); 1679 1680 1681 dcl (subs_no, l, n, index_temp, distance, stack_off, al_char, al_bd, index_temp_off, dtb_temp_off) 1682 fixed bin; 1683 dcl wd_count fixed bin; 1684 dcl packed_dec_bit bit (1) init ("0"b); 1685 dcl ind_count fixed bin init (0); 1686 dcl temp_save fixed bin; 1687 dcl (size_sw_save, i_save, mseg_no_save, occ_no) 1688 fixed bin; 1689 dcl (subs_ptr, dn_ptr_save, lit_ptr, temp_ptr, inst_buff_ptr, reloc_buff_ptr, reloc_ptr_save) 1690 pointer; 1691 dcl plus_sw bit (1); 1692 dcl subs_var fixed bin; 1693 1694 /* Instruction buffer */ 1695 dcl 1 inst_buff aligned, 1696 2 inst_wd (50) bit (36); 1697 dcl dtb_alloc fixed bin; 1698 1699 /* move_ data */ 1700 dcl move_in_token (1:10) ptr int static; 1701 dcl temp_wk_ptr ptr; 1702 dcl move_data_init fixed bin int static init (0); 1703 dcl move_token_ptr ptr; 1704 dcl cobol_move_gen entry (ptr); 1705 dcl cobol_make_type9$long_bin 1706 entry (ptr, fixed bin, fixed bin); 1707 1708 dcl 1 move_eos int static, 1709 2 size fixed bin (15), 1710 2 line fixed bin (15), 1711 2 column fixed bin (15), 1712 2 type fixed bin (15) init (19), 1713 2 verb fixed bin (15) init (18), 1714 2 e fixed bin (15) init (1); 1715 1716 dcl index_array_i fixed bin, 1717 index_save_flag fixed bin, 1718 save_temp_ptr ptr, 1719 index_i fixed bin, 1720 index_opti_flag fixed bin; 1721 1722 dcl 1 index_array (48), 1723 2 max fixed bin, 1724 2 min fixed bin, 1725 2 struc_l fixed bin, 1726 2 item_count fixed bin, 1727 2 seg_num fixed bin, 1728 2 offset fixed bin, 1729 2 index_reg bit (3); 1730 1731 /* Set occurs extension */ 1732 1733 occurs_ptr = addrel (dn_ptr, substr (unspec (data_name.occurs_ptr), 17, 18)); 1734 1735 /* Set subscripts token ptr */ 1736 1737 /*[5.2-1]*/ 1738 subs_ptr = addrel (baseptr (S_T.subs_segno), S_T.subs_offset); 1739 1740 /* Collect subscripts info */ 1741 1742 subs_error = 0; 1743 subs_no = occurs.dimensions; 1744 1745 if subs_no > 3 1746 then do; 1747 error_message.message = "OCCURS dimension must not be greater then 3."; 1748 1749 call signal_ ("command_abort_", null (), addr (error_message)); 1750 1751 call subs_err; 1752 return; 1753 1754 end; 1755 1756 mpy_bit = "0"b; 1757 aj_off = 0; 1758 index_array_i = 0; 1759 table_ext_off = 0; 1760 table_length = 1; 1761 1762 if data_name.ascii_packed_dec 1763 then packed_dec_bit = "1"b; 1764 1765 1766 do l = 1 to subs_no; 1767 1768 if input_struc.type = 2 | input_struc.type = 3 1769 then struc_l (l) = binary (substr (unspec (occurs.level.struc_length (l)), 1, 33)); 1770 else if packed_dec_bit 1771 then struc_l (l) = occurs.level.struc_length (l); 1772 else struc_l (l) = divide (occurs.level.struc_length (l), 2, 35, 0); 1773 1774 aj_off = aj_off + struc_l (l); 1775 max (l) = occurs.level.max (l); /*[4.2-1]*/ 1776 min (l) = 1; 1777 1778 /*[4.4-2]*/ 1779 /* table_length=table_length*max(l); */ 1780 1781 end; 1782 1783 /* Save dn_ptr of the cobol_addr caller. It must be restored at return.*/ 1784 1785 /*[4.4-2]*/ 1786 table_length = struc_l (1) * max (1); 1787 1788 large_array = "0"b; 1789 1790 if table_length > 65536 1791 then if packed_dec_bit | (table_length > 131072) 1792 then large_array = "1"b; 1793 1794 1795 1796 if fixed_common.options.oc 1797 then do; 1798 retry_tag = cobol_$next_tag; 1799 cobol_$next_tag = cobol_$next_tag + 1; 1800 1801 call cobol_define_tag_nc (retry_tag, cobol_$text_wd_off); 1802 1803 end; 1804 1805 dn_ptr_save = dn_ptr; 1806 temp_save = temp; 1807 mseg_no_save = mseg_no; 1808 reloc_ptr_save = reloc_ptr; 1809 reloc_ptr = null (); 1810 1811 /* Initialize */ 1812 1813 dtb_alloc = 0; 1814 l = 0; 1815 index_temp = 0; 1816 wd_count = 0; 1817 subs_var = 0; 1818 inst_buff_ptr = addr (inst_buff); 1819 reloc_buff_ptr = null (); 1820 1821 /* Test for token type */ 1822 /* Set temp_ptr to point at 1st token */ 1823 1824 temp_ptr = subs_token_ptr; 1825 1826 go to subs_; 1827 1828 do while ("1"b); 1829 1830 next_subs_: /* Set temp_ptr to the next token */ 1831 subs_ptr = addrel (subs_ptr, -2); 1832 temp_ptr = subs_token_ptr; 1833 1834 /* Subscripts processing */ 1835 1836 subs_: 1837 l = l + 1; 1838 item_count (l) = 1; 1839 index_save_flag = 0; 1840 index_opti_flag = 0; 1841 1842 if l > subs_no | temp_ptr = null () 1843 then do; 1844 call end_subs_proc; 1845 1846 go to subx; 1847 end; 1848 /***..... if Trace_Bit then call ioa_("^a^a^d",substr(Trace_Line,Trace_Lev+1,1)," TYPE = ",token_temp.type);/**/ 1849 1850 if token_temp.type = 10 1851 then do; 1852 ind_count = ind_count + 1; 1853 1854 call indexing; 1855 if err 1856 then call subs_err; 1857 1858 go to subx; 1859 end; 1860 1861 if token_temp.type = 2 1862 then do; 1863 nlit_ptr = temp_ptr; 1864 plus_sw = "1"b; 1865 1866 call subs_2; 1867 1868 index_temp = index_temp + distance; 1869 1870 if fixed_common.options.oc & (occ_no < 1 | occ_no > occurs.level.max (l)) 1871 then call cobol_gen_error$reg_reset (61, retry_tag); 1872 1873 go to next_subs_; 1874 1875 end; 1876 1877 /* Process type 9 data name subscript */ 1878 1879 if token_temp.type ^= 9 1880 then do; 1881 call subs_err; 1882 go to subx; 1883 end; 1884 1885 dn_ptr = temp_ptr; 1886 mseg_no = data_name.seg_num; 1887 subs_var = subs_var + 1; /* Allocate temp for object time dec_to_bin conversion */ 1888 dtb_alloc = dtb_alloc + 1; 1889 1890 if dtb_alloc = 1 1891 then do; 1892 al_char = 4; 1893 al_bd = 1; 1894 1895 call cobol_alloc$stack (al_char, al_bd, stack_off); 1896 dtb_temp_off = stack_off; 1897 1898 /* Allocate temp for index */ 1899 1900 call cobol_alloc$stack (al_char, al_bd, stack_off); 1901 index_temp_off = stack_off; 1902 1903 end; 1904 1905 /* Call move_ for overpunch sign */ 1906 1907 res = "1"b; 1908 1909 if (data_name.item_signed) & (^data_name.sign_separate) & (^data_name.bin_36) & (^data_name.bin_18) 1910 then do; 1911 call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); 1912 1913 wd_count = 0; 1914 call move_; 1915 end; 1916 else do; 1917 if wd_count ^= 0 1918 then call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); 1919 /* DTB */ 1920 wd_count = 1; 1921 1922 if data_name.bin_36 | data_name.bin_18 1923 then do; /*[5.2-2]*/ 1924 rx = 9; 1925 call get_a_q (9); 1926 1927 desc_nn_ptr_save = desc_an_ptr; 1928 desc_an_ptr = addr (inst_buff.inst_wd (wd_count)); 1929 i_save = i; 1930 size_sw_save = input_struc.operand.size_sw (i); 1931 input_struc.operand.size_sw (i) = 0; 1932 i = 1; 1933 1934 large_array_save = large_array; 1935 large_array = "0"b; 1936 1937 call desc_anp; 1938 1939 large_array = large_array_save; 1940 desc_an_ptr = desc_nn_ptr_save; 1941 i = i_save; 1942 input_struc.operand.size_sw (i) = size_sw_save; 1943 1944 if mseg_no = 3000 1945 then substr (inst_buff.inst_wd (wd_count), 19, 18) = "010011110000000100"b; 1946 else substr (inst_buff.inst_wd (wd_count), 19, 18) = "010011110001000000"b; 1947 1948 if data_name.bin_18 & (substr (unspec (data_name.offset), 35, 2) = "00"b) 1949 then do; 1950 1951 wd_count = wd_count + 1; 1952 inst_buff.inst_wd (wd_count) = "000000000000010010111011010000000000"b; 1953 1954 end; 1955 1956 res = "0"b; 1957 end; 1958 else do; 1959 inst_buff.inst_wd (wd_count) = "000000000001000000011000101101000000"b; 1960 1961 if mseg_no = 3000 1962 then substr (inst_buff.inst_wd (wd_count), 12, 7) = "0000100"b; 1963 1964 /* Get desc_nnp to build the nummeric descriptor for word 2 */ 1965 1966 /* Save info of the current instruction of the caller */ 1967 1968 wd_count = wd_count + 1; 1969 desc_nn_ptr_save = desc_nn_ptr; 1970 desc_nn_ptr = addr (inst_buff.inst_wd (wd_count)); 1971 i_save = i; 1972 1973 large_array_save = large_array; 1974 1975 large_array = "0"b; 1976 size_sw_save = input_struc.operand.size_sw (1); 1977 input_struc.operand.size_sw (1) = 0; 1978 i = 1; 1979 1980 1981 call desc_nnp; 1982 1983 /* restore caller info */ 1984 1985 large_array = large_array_save; 1986 desc_nn_ptr = desc_nn_ptr_save; 1987 i = i_save; 1988 input_struc.operand.size_sw (1) = size_sw_save; 1989 1990 /* Build DTB word 3 */ 1991 1992 wd_count = wd_count + 1; 1993 inst_buff.inst_wd (wd_count) = "110000000000000000000000000000000100"b; 1994 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (dtb_temp_off), 22, 15); 1995 1996 /* If binary data is supported and the data name is binary 1997* then the above instruction is not needed */ 1998 1999 2000 end; 2001 2002 /*[5.3-3]*/ 2003 call cobol_pointer_register$priority (2, 0, ptr_no); 2004 2005 /*[5.3-3]*/ 2006 addr_ptr (fixed (ptr_no)) = 0; 2007 2008 end; 2009 2010 2011 2012 if res 2013 then do; 2014 if wd_count ^= 0 2015 then call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); 2016 2017 /* Build LDQ instruction*/ 2018 /*[5.2-2]*/ 2019 rx = 9; 2020 call get_a_q (9); 2021 2022 wd_count = 1; 2023 inst_buff.inst_wd (wd_count) = "110000000000000000010011110001000000"b; 2024 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (dtb_temp_off), 22, 15); 2025 2026 end; 2027 2028 /* The following block are for subscript check. 5/29/76 bc */ 2029 2030 if fixed_common.options.oc 2031 then do; 2032 call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); 2033 2034 wd_count = 0; 2035 check_tag (1) = cobol_$next_tag; 2036 check_tag (2) = cobol_$next_tag + 1; 2037 cobol_$next_tag = cobol_$next_tag + 2; 2038 inst_seq (4) = "110000101000000100"b; 2039 occurs_limit_ptr = addr (min (l)); 2040 oci = 1; 2041 2042 res = "1"b; 2043 2044 do while (res); 2045 2046 /*[5.2-1]*/ 2047 temp_24 = temp; 2048 call cobol_pool (occurs_limit, 1, temp_24); 2049 2050 /*[5.2-1]*/ 2051 temp = -cobol_$text_wd_off - temp_24; 2052 substr (inst_seq (1), 1, 18) = substr (unspec (temp), 19, 18); 2053 2054 if oci = 1 2055 then do; 2056 call cobol_emit (addr (inst_seq (1)), null (), 2); 2057 call cobol_make_tagref (check_tag (oci), cobol_$text_wd_off - 1, null ()); 2058 call cobol_define_tag_nc (check_tag (2), cobol_$text_wd_off); 2059 call cobol_gen_error$reg_reset (61, retry_tag); 2060 2061 oci = 2; 2062 occurs_limit_ptr = addr (occurs.level.max (l)); 2063 inst_seq (4) = "110000101100000100"b; 2064 /* tpnz */ 2065 2066 call cobol_define_tag_nc (check_tag (1), cobol_$text_wd_off); 2067 2068 end; 2069 else do; 2070 call cobol_emit (addr (inst_seq (1)), null (), 2); 2071 call cobol_make_tagref (check_tag (oci), cobol_$text_wd_off - 1, null ()); 2072 2073 res = "0"b; 2074 end; 2075 2076 end; 2077 2078 end; 2079 2080 /* Build MPY instruction */ 2081 2082 temp = mod (struc_l (l), 262144); 2083 2084 call mpy_; 2085 2086 /* Build ASQ instruction */ 2087 2088 wd_count = wd_count + 1; 2089 inst_buff.inst_wd (wd_count) = "110000000000000000000101110001000000"b; 2090 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (index_temp_off), 22, 15); 2091 2092 if dtb_alloc = 1 2093 then substr (inst_buff.inst_wd (wd_count), 19, 9) = "111101110"b; 2094 /* Use STQ 756 */ 2095 2096 if large_array 2097 then if struc_l (l) >= 262144 2098 then do; 2099 wd_count = wd_count + 1; 2100 inst_buff.inst_wd (wd_count) = "110000000000000000010011110001000000"b; 2101 /* LDQ */ 2102 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (dtb_temp_off), 22, 15); 2103 2104 /* MPY or QLS */ 2105 temp = divide (struc_l (l), 262144, 35, 0); 2106 2107 call mpy_; 2108 2109 /*[5.2-2]*/ 2110 if mj = 0 2111 then do; 2112 wd_count = wd_count + 1; 2113 inst_buff.inst_wd (wd_count) = "000000000000010010111011110000000000"b; 2114 end; /*[5.2-2]*/ 2115 else do; 2116 mj = mj + 18; /*[5.2-2]*/ 2117 substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (mj), 19, 18); 2118 end; 2119 2120 wd_count = wd_count + 1; 2121 2122 /* ASQ pr */ 2123 inst_buff.inst_wd (wd_count) = inst_buff.inst_wd (wd_count - 3); 2124 substr (inst_buff.inst_wd (wd_count), 19, 6) = "000101"b; 2125 2126 end; 2127 2128 call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); 2129 2130 wd_count = 0; /*[5.2-2]*/ 2131 rx = 9; 2132 call release_reg (9); 2133 2134 if mpy_bit 2135 then do; 2136 mpy_bit = "0"b; /*[5.2-2]*/ 2137 rx = 8; 2138 call release_reg (8); 2139 2140 end; 2141 2142 end; 2143 2144 2145 2146 subs_err: 2147 proc; 2148 2149 error_message.message = "Subscripts or index error is encountered"; 2150 call signal_ ("command_abort_", null (), addr (error_message)); 2151 2152 subs_error = 1; 2153 2154 call end_subscription; 2155 2156 end; 2157 2158 2159 2160 2161 /*[5.2-2]*/ 2162 dcl mj fixed bin; 2163 2164 mpy_: 2165 proc; 2166 2167 /* Generate mpy instruction or qls instruction. */ 2168 /* passing temp as the constant to be multiplied.*/ 2169 2170 /*[5.2-2]*/ 2171 dcl i fixed bin, 2172 bit_temp bit (18), 2173 bit_test (18) bit (1) defined (bit_temp); 2174 2175 /*[5.2-2]*/ 2176 mj = 0; 2177 2178 if temp = 1 2179 then return; 2180 2181 2182 wd_count = wd_count + 1; 2183 2184 if temp = 0 2185 then do; 2186 inst_buff.inst_wd (wd_count) = "000000000000000000011111110000000111"b; 2187 return; 2188 end; 2189 2190 bit_temp = substr (unspec (temp), 19, 18); 2191 2192 do i = 1 to 18; 2193 2194 if bit_test (i) 2195 then do; 2196 if substr (bit_temp, i + 1, 18 - i) 2197 then go to mpy_inst; /*[5.2-2]*/ 2198 else do; 2199 mj = 18 - i; 2200 2201 go to qls_inst; 2202 end; 2203 end; 2204 end; 2205 2206 mpy_inst: /*[5.2-2]*/ 2207 if mj = 0 2208 then do; 2209 2210 if ^(mpy_bit) 2211 then do; 2212 mpy_bit = "1"b; /*[5.2-2]*/ 2213 rx = 8; 2214 call get_a_q (8); 2215 end; 2216 2217 /* mpy */ 2218 2219 inst_buff.inst_wd (wd_count) = "000000000000000000100000010000000111"b; 2220 substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (temp), 19, 18); 2221 2222 return; 2223 2224 end; 2225 2226 qls_inst: /* qls */ 2227 inst_buff.inst_wd (wd_count) = "000000000000000000111011110000000000"b; 2228 /*[5.2-2]*/ 2229 substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (mj), 19, 18); 2230 2231 end; 2232 2233 2234 2235 move_: 2236 proc; /* This procedure calls move_gen to move overpunch sign data to temp */ 2237 2238 /* init */ 2239 2240 move_token_ptr = addr (move_in_token (1)); 2241 2242 if move_data_init ^= cobol_$compile_count 2243 then do; 2244 move_token_ptr -> in_token.token_ptr (1) = null (); 2245 move_token_ptr -> in_token.token_ptr (4) = addr (move_eos); 2246 move_token_ptr -> in_token.n = 4; 2247 move_data_init = cobol_$compile_count; 2248 end; 2249 2250 temp_wk_ptr = null (); 2251 2252 call cobol_make_type9$long_bin (temp_wk_ptr, 1000, dtb_temp_off * 4); 2253 2254 move_token_ptr -> in_token.token_ptr (2) = dn_ptr;/* type 9 */ 2255 move_token_ptr -> in_token.token_ptr (3) = temp_wk_ptr; 2256 /* temp for result */ 2257 2258 call cobol_move_gen (move_token_ptr); 2259 2260 end; 2261 2262 2263 2264 2265 2266 subs_2: 2267 proc; 2268 2269 /* This procedure calculate the distance, i. e. the relative offset to 0 occurence */ 2270 2271 nlit_ptr = temp_ptr; /* Convert numeric literal to binary */ 2272 occ_no = fixed (temp_ptr -> numeric_lit.literal); 2273 distance = struc_l (l) * occ_no; 2274 if ^plus_sw 2275 then distance = -distance; 2276 2277 end; 2278 2279 2280 2281 table_ext_: 2282 proc; 2283 2284 2285 /* This procedure is used to generate those codes which 2286* builds up the table register at the execution time */ 2287 2288 wd_count = wd_count + 1; /*[5.2-2]*/ 2289 j = 5; 2290 call get_reg (5); 2291 2292 table_reg = reg_no; /*[5.2-2]*/ 2293 j = 2; 2294 call get_reg (2); 2295 2296 /*[5.0-1]*/ 2297 if ind 2298 then if ^packed_dec_bit /*[5.0-1]*/ 2299 then do; 2300 inst_buff.inst_wd (wd_count) = "00000000000000000111101101"b; 2301 /* QRS 1 */ 2302 /*[5.0-1]*/ 2303 wd_count = wd_count + 1; /*[5.0-1]*/ 2304 end; 2305 2306 inst_buff.inst_wd (wd_count) = "000000000000000000110010000000000110"b; 2307 /* EAXN 0,ql */ 2308 substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; 2309 wd_count = wd_count + 1; 2310 2311 inst_buff.inst_wd (wd_count) = "00000000000000001011101111"b; 2312 /* QLS 2 */ 2313 2314 wd_count = wd_count + 1; 2315 2316 /* STQ pr6|table_ext_off */ 2317 2318 if table_ext_off = 0 2319 then call cobol_alloc$stack (4, 1, table_ext_off); 2320 2321 inst_buff.inst_wd (wd_count) = "110000000000000000111101110001000000"b; 2322 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (table_ext_off), 22, 15); 2323 2324 /* LDXM pr6|table_ext_off */ 2325 2326 wd_count = wd_count + 1; 2327 inst_buff.inst_wd (wd_count) = "110000000000000000010010000001000000"b; 2328 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (inst_buff.inst_wd (wd_count - 1), 4, 15); 2329 substr (inst_buff.inst_wd (wd_count), 25, 3) = table_reg; 2330 wd_count = wd_count + 1; 2331 2332 /* ANXN 177777,du */ 2333 2334 inst_buff.inst_wd (wd_count) = "001111111111111111011110000000000011"b; 2335 substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; 2336 2337 end; 2338 2339 2340 2341 end_subs_proc: 2342 proc; 2343 2344 if subs_var > 0 /* load variable subscripts sum to index reg */ 2345 then do; 2346 no_reg_flag = 0; 2347 wd_count = wd_count + 1; 2348 2349 if large_array 2350 then do; 2351 rx = 9; /*[5.2-2]*/ 2352 call get_a_q (9); 2353 2354 inst_buff.inst_wd (wd_count) = "110000000000000000010011110001000000"b; 2355 2356 /* LDQ pr6|n */ 2357 2358 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (index_temp_off), 22, 15); 2359 /*[5.0-1]*/ 2360 ind = "0"b; 2361 call table_ext_; /*[5.2-2]*/ 2362 call release_reg (9); 2363 end; 2364 else do; 2365 inst_buff.inst_wd (wd_count) = "110000000000000000111010010001000000"b; 2366 2367 /* LXLN pr6|n */ 2368 2369 /*[5.2-2]*/ 2370 j = 2; 2371 call get_reg (2); 2372 substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; 2373 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (index_temp_off), 22, 15); 2374 2375 end; 2376 end; /* Add literal subscripts sum to index reg */ 2377 aj_off = aj_off - index_temp; 2378 if subs_var = 0 2379 then no_reg_flag = 1; 2380 2381 call emit; 2382 2383 end; 2384 2385 emit: 2386 proc; 2387 2388 /* Fix the bug for literal subscript in type 7 addressing. 02-24-77 */ 2389 2390 if t = 7 & index_temp ^= 0 2391 then do; 2392 2393 wd_count = wd_count + 1; 2394 2395 if wd_count = 1 /*[5.2-2]*/ 2396 then do; 2397 j = 2; 2398 call get_reg (2); 2399 inst_buff.inst_wd (1) = "000000000000000000010010000000000011"b; 2400 end; 2401 else inst_buff.inst_wd (wd_count) = "000000000000000000000110000000000011"b; 2402 2403 substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (index_temp), 19, 18); 2404 substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; 2405 2406 end; 2407 2408 /* Restore content of A & Q */ 2409 /* Emit instructions */ 2410 2411 if wd_count ^= 0 2412 then call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); 2413 2414 call end_subscription; 2415 2416 end; 2417 2418 indexing: 2419 proc; 2420 2421 /***..... dcl MY_NAME char (8) int static init ("INDEXING"); 2422* /**/ 2423 2424 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 2425 2426 err = "0"b; 2427 2428 do while ("1"b); 2429 2430 ind_ptr = temp_ptr; 2431 2432 if token_temp.type ^= 10 2433 then do; 2434 err = "1"b; 2435 go to indx; 2436 end; 2437 2438 no_reg_flag = 0; 2439 2440 if (index_array_flag ^= 0) & (^packed_dec_bit) & (item_count (l) = 1) & ^large_array & (subs_no = 1) 2441 then do; 2442 2443 save_temp_ptr = addrel (subs_ptr, -2); 2444 2445 if save_temp_ptr ^= null () 2446 then if save_temp_ptr -> token_temp.type ^= 1 2447 then do; 2448 index_save_flag = 1; 2449 2450 if index_array_i > 0 2451 then do index_i = 1 to index_array_i; 2452 2453 if (index_name.seg_num = index_array.seg_num (index_i)) 2454 & (index_name.offset = index_array.offset (index_i)) 2455 then do; 2456 index_opti_flag = 1; 2457 reg_no = index_array.index_reg (index_i); 2458 2459 call end_index_proc; 2460 call emit; 2461 2462 go to indx; 2463 2464 end; 2465 2466 end; 2467 2468 wd_count = wd_count + 1; 2469 2470 end; 2471 end; 2472 2473 else wd_count = wd_count + 1; 2474 2475 /* LDQ 236 */ 2476 2477 inst_buff.inst_wd (wd_count) = "000000000000000000010011110001000000"b; 2478 temp = binary (substr (unspec (index_name.offset), 1, 34)); 2479 mseg_no = index_name.seg_num; 2480 2481 call get_ar; 2482 2483 substr (inst_buff.inst_wd (wd_count), 1, 3) = ptr_no; 2484 substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (temp), 22, 15); 2485 2486 if ind_count > 1 2487 then substr (inst_buff.inst_wd (wd_count), 19, 9) = "000111110"b; 2488 /* ADQ 076 */ 2489 2490 /* Release the temp pointer reg. for subscript. 1/20/76 bc */ 2491 2492 call cobol_pointer_register$priority (2, 0, ptr_no); 2493 2494 addr_ptr (fixed (ptr_no)) = 0; 2495 2496 res = "1"b; 2497 2498 /* Get next token */ 2499 2500 do while (res); 2501 2502 subs_ptr = addrel (subs_ptr, -2); 2503 temp_ptr = subs_token_ptr; 2504 2505 if temp_ptr = null () 2506 then do; 2507 l = l + 1; 2508 call end_index_proc; 2509 call emit; 2510 2511 go to indx; 2512 end; 2513 else if token_temp.type = 1 2514 then do; 2515 item_count (l) = item_count (l) + 1; 2516 call indx_1; 2517 2518 if err 2519 then go to indx; 2520 2521 call subs_2; 2522 2523 index_temp = index_temp + distance; 2524 end; 2525 else do; 2526 l = l + 1; 2527 2528 if l > subs_no 2529 then do; 2530 call end_index_proc; 2531 call emit; 2532 go to indx; 2533 end; 2534 2535 item_count (l) = 1; 2536 index_save_flag = 0; 2537 index_opti_flag = 0; 2538 2539 if token_temp.type = 10 2540 then do; 2541 ind_count = ind_count + 1; 2542 res = "0"b; 2543 end; 2544 else do; 2545 if token_temp.type = 2 2546 then plus_sw = "1"b; 2547 else do; 2548 call indx_1; 2549 if err 2550 then go to indx; 2551 end; 2552 2553 call subs_2; 2554 2555 index_temp = index_temp + distance; 2556 end; 2557 end; 2558 end; 2559 2560 2561 2562 end; 2563 indx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 2564 end; 2565 2566 indx_1: 2567 proc; 2568 2569 if token_temp.type = 1 2570 then do; 2571 rw_ptr = temp_ptr; 2572 2573 if reserved_word.key = 182 2574 then plus_sw = "1"b; 2575 else plus_sw = "0"b; 2576 end; 2577 2578 subs_ptr = addrel (subs_ptr, -2); 2579 temp_ptr = subs_token_ptr; 2580 2581 if token_temp.type ^= 2 2582 then err = "1"b; 2583 2584 end; 2585 2586 2587 2588 end_index_proc: 2589 proc; 2590 2591 /* EAXn|0,QL */ 2592 /*[5.0-1]*/ 2593 if large_array /*[5.0-1]*/ 2594 then do; 2595 ind = "1"b; 2596 call table_ext_; 2597 end; 2598 2599 else if index_opti_flag = 0 2600 then do; 2601 2602 if ^packed_dec_bit 2603 then do; 2604 wd_count = wd_count + 1; 2605 inst_buff.inst_wd (wd_count) = "000000000000000001111111010000000000"b; 2606 2607 end; 2608 2609 wd_count = wd_count + 1; 2610 inst_buff.inst_wd (wd_count) = "000000000000000000110010000000000110"b; 2611 2612 /*[5.2-2]*/ 2613 j = 2; 2614 call get_reg (2); 2615 2616 substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; 2617 2618 if index_save_flag = 1 2619 then do; 2620 index_array_i = index_array_i + 1; 2621 index_array.seg_num (index_array_i) = index_name.seg_num; 2622 index_array.offset (index_array_i) = index_name.offset; 2623 index_array.index_reg (index_array_i) = reg_no; 2624 end; 2625 end; 2626 2627 aj_off = aj_off - index_temp; 2628 2629 end; 2630 2631 end_subscription: 2632 proc; 2633 2634 2635 2636 dn_ptr = dn_ptr_save; 2637 temp = temp_save; 2638 reloc_ptr = reloc_ptr_save; 2639 mseg_no = mseg_no_save; 2640 2641 end; 2642 2643 subx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 2644 end subscripts; 2645 2646 dcl dn_ptr ptr; /* dn_ptr always points to the current type 9 token.*/ 2647 2648 dcl err bit (1); 2649 2650 /* temp struc to get subscripts token pointer */ 2651 2652 dcl 1 S_T based (dn_ptr), /*[5.2-1*/ 2653 2 filler1 char (16), 2654 2 subs_segno bit (18) unaligned, 2655 2 subs_offset bit (18) unaligned, 2656 2 filler2 char (24); 2657 2658 /* emit generator */ 2659 2660 dcl cobol_emit entry (ptr, ptr, fixed bin); 2661 2662 /* Error handler */ 2663 2664 dcl signal_ entry (char (*), ptr, ptr); 2665 dcl 1 error_message, /* [3.0-1] */ 2666 2 name char (32), /* [3.0-1] */ 2667 2 length fixed bin, /* [3.0-1] */ 2668 2 message char (80); 2669 2670 2671 /*[5.2-2]*/ 2672 dcl (i, j, rxi, mseg_no, t, temp1, dec_bin_temp, aj_off, temp_p) 2673 fixed bin init (0); /*[5.2-1]*/ 2674 dcl temp fixed bin (35) init (0), 2675 temp_24 fixed bin (24); 2676 2677 dcl (ptr_no, reg_no) bit (3) init ("000"b); 2678 2679 dcl mseg_no_bit bit (36) based (addr (mseg_no)), 2680 (special_bit, reg_bit, disp_bit) 2681 bit (1) init ("0"b), 2682 mf_ptr ptr, 2683 mf_bit bit (7) based (mf_ptr), 2684 1 mf_temp based (mf_ptr), 2685 2 pr_spec bit (1) unaligned, 2686 2 reg_or_length bit (1) unaligned, 2687 2 zero2 bit (1) unaligned, 2688 2 reg_mod bit (4) unaligned; 2689 2690 dcl desc_no_char char (3) init ("123"); 2691 2692 /* For sign/unsign. */ 2693 /*dcl mvt_table char(128) static int init( 2694*/* "00000000000000000000000000000000000000000000000001234567890000000123456789123456789000000000000000000000000000000000000000000000"); 2695*/*dcl (mvt_rel_off,mvt_temp_off) fixed bin, 2696*/* mvt_init fixed bin(24) static int init(0); 2697*/*dcl mvt_off fixed bin(24) static int init(0); 2698**/ 2699 2700 dcl 1 inst_b1 aligned, 2701 2 wd bit (36), 2702 2 wd1 bit (36), 2703 2 wd2 bit (36), 2704 2 wd3 bit (36), 2705 2 wd4 bit (36); 2706 dcl cobol_reset_r$pointer_register 2707 entry (bit (3)); 2708 dcl eppr_op bit (10); 2709 dcl adwp_op bit (10); 2710 dcl res bit (1); 2711 dcl (rx, r_max) fixed bin; 2712 dcl adwp_du fixed bin (35); 2713 dcl addr_reg (0:9) fixed bin; 2714 dcl addr_ptr (0:9) fixed bin; 2715 dcl inst_b1_ptr ptr; 2716 dcl reloc_b1_ptr ptr; 2717 2718 dcl 1 reloc_b1, 2719 2 l bit (5) aligned, 2720 2 r bit (5) aligned; 2721 dcl b1_count fixed bin; 2722 2723 dcl p fixed bin; /* used by get_ar */ 2724 dcl index_array_flag fixed bin, 2725 index_array_i fixed bin; 2726 dcl ar_buff char (32); /* buffer for structure */ 2727 dcl subs_error fixed bin; /* If =1, subscripting error is encountered */ 2728 dcl aj_const_off (3) fixed bin; /* Ajust constant offset if cobol_addr emits codes */ 2729 dcl no_reg_flag fixed bin; 2730 dcl text_wd_off_save fixed bin; 2731 2732 2733 dcl large_array bit (1) init ("0"b), 2734 large_array_save bit (1), 2735 table_reg bit (3), 2736 table_para fixed bin (35) init (65536), 2737 table_range fixed bin, 2738 table_ext_off fixed bin, 2739 table_length fixed bin (35); 2740 2741 dcl opr fixed bin, 2742 ind bit (1); 2743 2744 /* subscript check. */ 2745 2746 dcl retry_tag fixed bin, 2747 check_tag (2) fixed bin, 2748 occurs_limit_ptr ptr, 2749 occurs_limit char (4) based (occurs_limit_ptr), 2750 oci fixed bin, 2751 inst_seq (6) bit (18) static init ("000000000000000000"b, "001001110000000100"b, 2752 /* cmpq range,ic */ 2753 "000000000000000010"b, "110000101000000100"b, 2754 /* tpl good,ic */ 2755 "000000000000000000"b, "111001000000000100"b); 2756 /* tra error,ic */ 2757 2758 /* Declaration for external entries. */ 2759 2760 dcl cobol_get_size entry (ptr, fixed bin, fixed bin); 2761 dcl cobol_register$release 2762 entry (ptr); 2763 dcl cobol_register$load entry (ptr); 2764 dcl cobol_define_tag_nc entry (fixed bin, fixed bin); 2765 dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); 2766 dcl cobol_pool entry (char (*), fixed bin, fixed bin (24)) ext; 2767 dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); 2768 dcl cobol_gen_error$reg_reset 2769 entry (fixed bin, fixed bin); 2770 dcl cobol_pointer_register$get 2771 entry (ptr); 2772 dcl cobol_pointer_register$priority 2773 entry (fixed bin, fixed bin, bit (3)); 2774 2775 /* Pointer register manager */ 2776 /* 2777* This entry obtains a pointer register for the caller. 2778* */ 2779 dcl struc_ptr ptr; 2780 2781 /* struc_ptr is a pointer to the following structure. (input) */ 2782 2783 dcl 1 structure based (struc_ptr), 2784 2 what_pointer fixed bin, 2785 2 pointer_no bit (3), 2786 2 lock fixed bin, 2787 2 switch fixed bin, 2788 2 segno fixed bin, 2789 2 offset fixed bin (24), 2790 2 reset fixed bin; 2791 2792 /* 2793*what_pointer specifies the pointer register to be obtained. 2794* (input) 2795* 0-7 - get this pointer register. 2796* 10 - get any temporary pointer register. 2797*pointer_no is the register that is assigned, in the 2798* range 0-7. (output) 2799*lock can have the following values. (input) 2800* 0 - did not change the lock or unlock status 2801* of this pointer. 2802* 1 - lock the pointer register. 2803* 2 - unlock all pointer registers. 2804* 3 - unlock all pointer registers and A register 2805* and Q register and all index registers. 2806*switch has the following values. (input) 2807* 0 - the register will not contain a value 2808* that is meaningful for register optimization. 2809* Segment number and offset are meaningless. 2810* 1 - a segment number and word offset are supplied. 2811* 2 - a segment number and character offset are supplied 2812*segno is the segment number. (input) 2813* values recognized are: 2814* 2 - cobol data. 2815* 1000 - stack. 2816* 3000 - constants. 2817* 3002 - multics linkage. 2818* 4000 - cobol operators. 2819* 2nnnn - cobol linkage. 2820* -n - link in multics linkage. 2821*offset is the word or character offset (depending on switch). 2822* Any case when the offset is meaningless a 0 value 2823* must be used. 2824* If a character offset is provided only the word 2825* portion is meaningful. (input) 2826*reset specifies that the caller has requested a register 2827* that must have a preset value. For example a preset 2828* register to cobol data or the pointer to pl/1 operators 2829* (likely). This is only of interest to callers 2830* who request a specific register (what_pointer = 0-7) 2831* 2832* Such callers should test reset. If it is 1, a call to 2833* 2834* cobol_reset_r should be made in order 2835* to emit instructions to reload the register to 2836* its proper value. 2837* 2838*Notes: 2839*1. If switch has a non zero value and the pointer register 2840* did not contain the specified segno and offset this 2841* utility will emit instructions to load 2842* the pointer register. 2843*2. (a) Generally a register should not be locked. 2844* (b) Exceptions would be the case when (1) several 2845* calls must be make to this utility and the caller 2846* did not wish to obtain the same register (2) Calls 2847* to this utility are interspurced with calls to the 2848* addressability utilities and the user did not wish to 2849* obtain the same register. 2850* 2851*3. There is no need to call to get pointer register 6 (the 2852* 2853* stack frame). We can always assume this is set. 2854*4. If the caller requests a specific pointer register 2855* who's priority was lock a compile time error will occur. 2856* This may change if we need more sophisticated 2857* pointer register handling. 2858* */ 2859 2860 2861 2862 /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ 2863 /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ 2864 2865 /***..... dcl Trace_Bit bit(1) static external;/**/ 2866 /***..... dcl Trace_Lev fixed bin static external;/**/ 2867 /***..... dcl Trace_Line char(36) static external;/**/ 2868 /***..... dcl ioa_ entry options(variable); /**/ 2869 2870 2871 2872 /* The followings are for the register structure */ 2873 2874 dcl reg_struc_ptr ptr, /* reg_struc_ptr is a pointer to the following structure (input) */ 2875 1 reg_struc, 2876 2 what_reg fixed bin, 2877 2 reg_num bit (4), 2878 2 lock fixed bin, 2879 2 already_there fixed bin, 2880 2 contains fixed bin, 2881 2 pointer ptr, 2882 2 literal bit (36); 2883 2884 /* 2885*what_reg specifies the register to be obtained. (input) 2886* 0 - A or Q or any index register. 2887* 1 - A register. 2888* 2 - Q register. 2889* 3 - A and Q registers. 2890* 4 - A or Q register. 2891* 5 - any index register. 2892* 1n - index register n. 2893* 2894*reg_num is the register that is assigned. (output). 2895* 1 - A register. 2896* 2 - Q register. 2897* 3 - A and Q registers. 2898* 1n - index register n. 2899* 2900*lock can have the following values. (input). 2901* 0 - do not change the lock or unlock status of the register. 2902* 1 - lock this register. 2903* 2 - unlock all index registers and the A and Q registers. 2904* 3 - unlock all index registers and the A and Q registers 2905* and all pointer registers. 2906*already_there has the followoutg values. (output). 2907* 0 - the register must be loaded. 2908* 1 - the specified contents are already in the register 2909* and it does not need to loaded. 2910* 2911*contains specifies the form of the contents of the register. (input). 2912* 0 - the register will not contain a value that is meaningful 2913* for register optimatization. 2914* pointer and literal are not meaningful. 2915* 1 - the register will contain a data item. 2916* pointer must have a meaningful value. 2917* 2 - the register will contain the value specified in "literal". 2918* 3 - the register will contain a computed subscript, pointer must 2919* have a meaningful value. 2920* 4 - the register will contain a computed index, 2921* pointer must have a meaningful value. 2922* 5 - the register will contain a modified computed index, 2923* pointer must have a meaningful value. 2924* 2925* Note: The values 3, 4 and 5 are intended for the use by 2926* the addressibility handler and should not be of interest 2927* to the most generators. 2928* 2929*pointer is one of the following: 2930* (a) - A pointer to a type 9 token. In this case "contains" is 1 (data item). 2931* (b) - A pointer to a structure (to be defined) for index or subscript 2932* computations. In this case, "contains" is 3 (subscript), 4 2933* (index) or 5 (modified index). 2934* 2935*literal is the literal value that will be in the register. 2936* 2937* */ 2938 2939 2940 dcl var_reg (3) bit (3); 2941 2942 2943 2944 2945 /***** Declaration for builtin function *****/ 2946 2947 dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, divide) 2948 builtin; 2949 2950 /***** End of declaration for builtin function *****/ 2951 1 1 1 2 /* BEGIN INCLUDE FILE ... cobol_addr_tokens.incl.pl1 */ 1 3 1 4 1 5 /****^ HISTORY COMMENTS: 1 6* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8058), 1 7* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 1 8* MCR8058 cobol_addr_tokens.incl.pl1 Change array extents to refer to 1 9* constants rather than variables. 1 10* END HISTORY COMMENTS */ 1 11 1 12 1 13 /* Last modified on 10/1/74 by tg */ 1 14 1 15 1 16 /* parameter list */ 1 17 1 18 dcl (input_ptr, inst_ptr, reloc_ptr) ptr; 1 19 1 20 1 21 /* input_struc_basic is used for type 1 addressing */ 1 22 1 23 dcl 1 input_struc_basic based (input_ptr), 1 24 2 type fixed bin, 1 25 2 operand_no fixed bin, 1 26 2 lock fixed bin, 1 27 2 segno fixed bin, 1 28 2 char_offset fixed bin (24), 1 29 2 send_receive fixed bin; 1 30 1 31 1 32 dcl 1 input_struc based (input_ptr), 1 33 2 type fixed bin, 1 34 2 operand_no fixed bin, 1 35 2 lock fixed bin, 1 36 2 operand (0 refer (input_struc.operand_no)), 1 37 3 token_ptr ptr, 1 38 3 send_receive fixed bin, 1 39 3 ic_mod fixed bin, 1 40 3 size_sw fixed bin; 1 41 1 42 /* reloc_struc is used for all types of addressing * all types */ 1 43 1 44 dcl 1 reloc_struc (input_struc.operand_no + 1) based (reloc_ptr), 1 45 2 left_wd bit (5) aligned, 1 46 2 right_wd bit (5) aligned; 1 47 1 48 /* Instruction format for 1 word instruction */ 1 49 1 50 1 51 dcl 1 inst_struc_basic based (inst_ptr) aligned, 1 52 2 y unaligned, 1 53 3 pr bit (3) unaligned, 1 54 3 wd_offset bit (15) unaligned, 1 55 2 fill1_op bit (10) unaligned, 1 56 2 zero1 bit (1) unaligned, 1 57 2 pr_spec bit (1) unaligned, 1 58 2 tm bit (2) unaligned, 1 59 2 td bit (4) unaligned; 1 60 1 61 1 62 /* The detailed definitions of the fields in this structure 1 63* can be found in the GMAP manual section 8 */ 1 64 /* EIS instruction format for 2_4 word instructions */ 1 65 1 66 dcl 1 inst_struc based (inst_ptr) aligned, 1 67 2 inst unaligned, 1 68 3 zero1 bit (2) unaligned, 1 69 3 mf3 unaligned, 1 70 4 pr_spec bit (1) unaligned, 1 71 4 reg_or_length bit (1) unaligned, 1 72 4 zero2 bit (1) unaligned, 1 73 4 reg_mod bit (4) unaligned, 1 74 3 zero3 bit (2) unaligned, 1 75 3 mf2 unaligned, 1 76 4 pr_spec bit (1) unaligned, 1 77 4 reg_or_length bit (1) unaligned, 1 78 4 zero4 bit (1) unaligned, 1 79 4 reg_mod bit (4) unaligned, 1 80 3 fill1_op bit (10) unaligned, 1 81 3 zero5 bit (1) unaligned, 1 82 3 mf1 unaligned, 1 83 4 pr_spec bit (1) unaligned, 1 84 4 reg_or_length bit (1) unaligned, 1 85 4 zero6 bit (1) unaligned, 1 86 4 reg_mod bit (4) unaligned, 1 87 2 desc_ext unaligned, 1 88 3 desc (512) unaligned, 1 89 4 desc_od bit (36) unaligned; 1 90 1 91 /* The detailed definitions of the fields in this structure 1 92* can be found in the GMAP manual section 8. 1 93* The desc_ext is the descriptor extension of this eis 1 94* instruction. The number of descriptors associated with 1 95* this instruction is equavalent to the operand number. 1 96* Depending on operand data type, the descriptor 1 97* can be alphanumeric or numeric. The structures of the 1 98* alphanumeric and the numeric descriptors are defined 1 99* below. */ 1 100 1 101 /* alphanumeric descriptor format */ 1 102 1 103 dcl 1 desc_an based (desc_an_ptr) unaligned, 1 104 2 desc_f (512) unaligned, 1 105 3 y unaligned, 1 106 4 pr bit (3) unaligned, 1 107 4 wd_offset bit (15) unaligned, 1 108 3 char_n bit (3) unaligned, 1 109 3 zero1 bit (1) unaligned, 1 110 3 ta bit (2), 1 111 3 n bit (12) unaligned; 1 112 1 113 1 114 /* The detailed definitions of the fields in this structure can 1 115* be found in the GMAP manual section 8. */ 1 116 /* numeric descriptor format */ 1 117 1 118 dcl desc_nn_ptr ptr; 1 119 dcl desc_an_ptr ptr; 1 120 1 121 1 122 dcl 1 desc_nn based (desc_nn_ptr) unaligned, 1 123 2 desc_f (512) unaligned, 1 124 3 y unaligned, 1 125 4 pr bit (3) unaligned, 1 126 4 wd_offset bit (15) unaligned, 1 127 3 digit_n bit (3) unaligned, 1 128 3 tn bit (1) unaligned, 1 129 3 sign_type bit (2) unaligned, 1 130 3 scal bit (6) unaligned, 1 131 3 n bit (6) unaligned; 1 132 1 133 1 134 /* The detailed definitions of fields in this structure can 1 135* be found in the GMAP manual section 8. */ 1 136 /* END INCLUDE FILE ... cobol_addr_tokens.incl.pl1 */ 1 137 2952 2 1 2 2 /* BEGIN INCLUDE FILE ... cobol_type9.incl.pl1 */ 2 3 /* Last modified on 11/19/76 by ORN */ 2 4 2 5 /* 2 6*A type 9 data name token is entered into the name table by the data 2 7*division syntax phase for each data name described in the data division. 2 8*The replacement phase subsequently replaces type 8 user word references 2 9*to data names in the procedure division minpral file with the corresponding 2 10*type 9 tokens from the name table. 2 11**/ 2 12 2 13 /* dcl dn_ptr ptr; */ 2 14 2 15 /* BEGIN DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 2 16 dcl 1 data_name based (dn_ptr), 3 1 3 2 /* begin include file ... cobol_TYPE9.incl.pl1 */ 3 3 /* Last modified on 06/19/77 by ORN */ 3 4 /* Last modified on 12/28/76 by FCH */ 3 5 3 6 /* header */ 3 7 2 size fixed bin, 3 8 2 line fixed bin, 3 9 2 column fixed bin, 3 10 2 type fixed bin, 3 11 /* body */ 3 12 2 string_ptr ptr, 3 13 2 prev_rec ptr, 3 14 2 searched bit (1), 3 15 2 duplicate bit (1), 3 16 2 saved bit (1), 3 17 2 debug_ind bit (1), 3 18 2 filler2 bit (3), 3 19 2 used_as_sub bit (1), 3 20 2 def_line fixed bin, 3 21 2 level fixed bin, 3 22 2 linkage fixed bin, 3 23 2 file_num fixed bin, 3 24 2 size_rtn fixed bin, 3 25 2 item_length fixed bin(24), 3 26 2 places_left fixed bin, 3 27 2 places_right fixed bin, 3 28 /* description */ 3 29 2 file_section bit (1), 3 30 2 working_storage bit (1), 3 31 2 constant_section bit (1), 3 32 2 linkage_section bit (1), 3 33 2 communication_section bit (1), 3 34 2 report_section bit (1), 3 35 2 level_77 bit (1), 3 36 2 level_01 bit (1), 3 37 2 non_elementary bit (1), 3 38 2 elementary bit (1), 3 39 2 filler_item bit (1), 3 40 2 s_of_rdf bit (1), 3 41 2 o_of_rdf bit (1), 3 42 2 bin_18 bit (1), 3 43 2 bin_36 bit (1), 3 44 2 pic_has_l bit (1), 3 45 2 pic_is_do bit (1), 3 46 2 numeric bit (1), 3 47 2 numeric_edited bit (1), 3 48 2 alphanum bit (1), 3 49 2 alphanum_edited bit (1), 3 50 2 alphabetic bit (1), 3 51 2 alphabetic_edited bit (1), 3 52 2 pic_has_p bit (1), 3 53 2 pic_has_ast bit (1), 3 54 2 item_signed bit(1), 3 55 2 sign_separate bit (1), 3 56 2 display bit (1), 3 57 2 comp bit (1), 3 58 2 ascii_packed_dec_h bit (1), /* as of 8/16/76 this field used for comp8. */ 3 59 2 ascii_packed_dec bit (1), 3 60 2 ebcdic_packed_dec bit (1), 3 61 2 bin_16 bit (1), 3 62 2 bin_32 bit (1), 3 63 2 usage_index bit (1), 3 64 2 just_right bit (1), 3 65 2 compare_argument bit (1), 3 66 2 sync bit (1), 3 67 2 temporary bit (1), 3 68 2 bwz bit (1), 3 69 2 variable_length bit (1), 3 70 2 subscripted bit (1), 3 71 2 occurs_do bit (1), 3 72 2 key_a bit (1), 3 73 2 key_d bit (1), 3 74 2 indexed_by bit (1), 3 75 2 value_numeric bit (1), 3 76 2 value_non_numeric bit (1), 3 77 2 value_signed bit (1), 3 78 2 sign_type bit (3), 3 79 2 pic_integer bit (1), 3 80 2 ast_when_zero bit (1), 3 81 2 label_record bit (1), 3 82 2 sign_clause_occurred bit (1), 3 83 2 okey_dn bit (1), 3 84 2 subject_of_keyis bit (1), 3 85 2 exp_redefining bit (1), 3 86 2 sync_in_rec bit (1), 3 87 2 rounded bit (1), 3 88 2 ad_bit bit (1), 3 89 2 debug_all bit (1), 3 90 2 overlap bit (1), 3 91 2 sum_counter bit (1), 3 92 2 exp_occurs bit (1), 3 93 2 linage_counter bit (1), 3 94 2 rnm_01 bit (1), 3 95 2 aligned bit (1), 3 96 2 not_user_writable bit (1), 3 97 2 database_key bit (1), 3 98 2 database_data_item bit (1), 3 99 2 seg_num fixed bin, 3 100 2 offset fixed bin(24), 3 101 2 initial_ptr fixed bin, 3 102 2 edit_ptr fixed bin, 3 103 2 occurs_ptr fixed bin, 3 104 2 do_rec char(5), 3 105 2 bitt bit (1), 3 106 2 byte bit (1), 3 107 2 half_word bit (1), 3 108 2 word bit (1), 3 109 2 double_word bit (1), 3 110 2 half_byte bit (1), 3 111 2 filler5 bit (1), 3 112 2 bit_offset bit (4), 3 113 2 son_cnt bit (16), 3 114 2 max_red_size fixed bin(24), 3 115 2 name_size fixed bin, 3 116 2 name char(0 refer(data_name.name_size)); 3 117 3 118 3 119 3 120 /* end include file ... cobol_TYPE9.incl.pl1 */ 3 121 2 17 2 18 /* END DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 2 19 2 20 /* END INCLUDE FILE ... cobol_type9.incl.pl1 */ 2 21 2953 4 1 4 2 /* BEGIN INCLUDE FILE ... cobol_occurs_ext.incl.pl1 */ 4 3 /* Last modified on 01/19/77 by ORN */ 4 4 4 5 /* 4 6*An occurs extension is included in a type 9 data name token when the data 4 7*name is described with an occurs clause or is subordinate to an item 4 8*described with an occurs clause. 4 9**/ 4 10 4 11 /* ***STRUCTURE SIZE INFORMATION*** */ 4 12 /* THE SIZE OF THIS STRUCTURE IN BYTES, (EXCLUDING VARIABLE 4 13* LENGTH ENTITIES), FOR EACH HARDWARE IMPLEMENTATION IS: 4 14* 4 15* HARDWARE | SIZE (BYTES) 4 16* --------------------------------- 4 17* 6180 | 12 + 24 * dimensions 4 18* P7 | 6 + 14 * dimensions 4 19* --------------------------------- 4 20**/ 4 21 4 22 /* THE OCCURS EXTENSION STRUCTURE */ 4 23 4 24 dcl occurs_ptr ptr; 4 25 4 26 dcl 1 occurs based (occurs_ptr), 4 27 2 keyed fixed bin, 4 28 2 key_number fixed bin, 4 29 2 dimensions fixed bin, 4 30 2 level (occurs.dimensions), 4 31 3 index_no fixed bin, 4 32 3 min fixed bin, 4 33 3 max fixed bin, 4 34 3 struc_length fixed bin, 4 35 3 cswd_seg fixed bin, 4 36 3 cswd_offset fixed bin(24); 4 37 4 38 4 39 4 40 /* END INCLUDE FILE ... cobol_occurs_ext.incl.pl1 */ 4 41 2954 5 1 5 2 /* BEGIN INCLUDE FILE ... cobol_.incl.pl1 */ 5 3 /* last modified Feb 4, 1977 by ORN */ 5 4 5 5 /* This file defines all external data used in the generator phase of Multics Cobol */ 5 6 5 7 /* POINTERS */ 5 8 dcl cobol_$text_base_ptr ptr ext; 5 9 dcl text_base_ptr ptr defined (cobol_$text_base_ptr); 5 10 dcl cobol_$con_end_ptr ptr ext; 5 11 dcl con_end_ptr ptr defined (cobol_$con_end_ptr); 5 12 dcl cobol_$def_base_ptr ptr ext; 5 13 dcl def_base_ptr ptr defined (cobol_$def_base_ptr); 5 14 dcl cobol_$link_base_ptr ptr ext; 5 15 dcl link_base_ptr ptr defined (cobol_$link_base_ptr); 5 16 dcl cobol_$sym_base_ptr ptr ext; 5 17 dcl sym_base_ptr ptr defined (cobol_$sym_base_ptr); 5 18 dcl cobol_$reloc_text_base_ptr ptr ext; 5 19 dcl reloc_text_base_ptr ptr defined (cobol_$reloc_text_base_ptr); 5 20 dcl cobol_$reloc_def_base_ptr ptr ext; 5 21 dcl reloc_def_base_ptr ptr defined (cobol_$reloc_def_base_ptr); 5 22 dcl cobol_$reloc_link_base_ptr ptr ext; 5 23 dcl reloc_link_base_ptr ptr defined (cobol_$reloc_link_base_ptr); 5 24 dcl cobol_$reloc_sym_base_ptr ptr ext; 5 25 dcl reloc_sym_base_ptr ptr defined (cobol_$reloc_sym_base_ptr); 5 26 dcl cobol_$reloc_work_base_ptr ptr ext; 5 27 dcl reloc_work_base_ptr ptr defined (cobol_$reloc_work_base_ptr); 5 28 dcl cobol_$pd_map_ptr ptr ext; 5 29 dcl pd_map_ptr ptr defined (cobol_$pd_map_ptr); 5 30 dcl cobol_$fixup_ptr ptr ext; 5 31 dcl fixup_ptr ptr defined (cobol_$fixup_ptr); 5 32 dcl cobol_$initval_base_ptr ptr ext; 5 33 dcl initval_base_ptr ptr defined (cobol_$initval_base_ptr); 5 34 dcl cobol_$initval_file_ptr ptr ext; 5 35 dcl initval_file_ptr ptr defined (cobol_$initval_file_ptr); 5 36 dcl cobol_$perform_list_ptr ptr ext; 5 37 dcl perform_list_ptr ptr defined (cobol_$perform_list_ptr); 5 38 dcl cobol_$alter_list_ptr ptr ext; 5 39 dcl alter_list_ptr ptr defined (cobol_$alter_list_ptr); 5 40 dcl cobol_$seg_init_list_ptr ptr ext; 5 41 dcl seg_init_list_ptr ptr defined (cobol_$seg_init_list_ptr); 5 42 dcl cobol_$temp_token_area_ptr ptr ext; 5 43 dcl temp_token_area_ptr ptr defined (cobol_$temp_token_area_ptr); 5 44 dcl cobol_$temp_token_ptr ptr ext; 5 45 dcl temp_token_ptr ptr defined (cobol_$temp_token_ptr); 5 46 dcl cobol_$token_block1_ptr ptr ext; 5 47 dcl token_block1_ptr ptr defined (cobol_$token_block1_ptr); 5 48 dcl cobol_$token_block2_ptr ptr ext; 5 49 dcl token_block2_ptr ptr defined (cobol_$token_block2_ptr); 5 50 dcl cobol_$minpral5_ptr ptr ext; 5 51 dcl minpral5_ptr ptr defined (cobol_$minpral5_ptr); 5 52 dcl cobol_$tag_table_ptr ptr ext; 5 53 dcl tag_table_ptr ptr defined (cobol_$tag_table_ptr); 5 54 dcl cobol_$map_data_ptr ptr ext; 5 55 dcl map_data_ptr ptr defined (cobol_$map_data_ptr); 5 56 dcl cobol_$ptr_status_ptr ptr ext; 5 57 dcl ptr_status_ptr ptr defined (cobol_$ptr_status_ptr); 5 58 dcl cobol_$reg_status_ptr ptr ext; 5 59 dcl reg_status_ptr ptr defined (cobol_$reg_status_ptr); 5 60 dcl cobol_$misc_base_ptr ptr ext; 5 61 dcl misc_base_ptr ptr defined (cobol_$misc_base_ptr); 5 62 dcl cobol_$misc_end_ptr ptr ext; 5 63 dcl misc_end_ptr ptr defined (cobol_$misc_end_ptr); 5 64 dcl cobol_$list_ptr ptr ext; 5 65 dcl list_ptr ptr defined (cobol_$list_ptr); 5 66 dcl cobol_$allo1_ptr ptr ext; 5 67 dcl allo1_ptr ptr defined (cobol_$allo1_ptr); 5 68 dcl cobol_$eln_ptr ptr ext; 5 69 dcl eln_ptr ptr defined (cobol_$eln_ptr); 5 70 dcl cobol_$diag_ptr ptr ext; 5 71 dcl diag_ptr ptr defined (cobol_$diag_ptr); 5 72 dcl cobol_$xref_token_ptr ptr ext; 5 73 dcl xref_token_ptr ptr defined (cobol_$xref_token_ptr); 5 74 dcl cobol_$xref_chain_ptr ptr ext; 5 75 dcl xref_chain_ptr ptr defined (cobol_$xref_chain_ptr); 5 76 dcl cobol_$statement_info_ptr ptr ext; 5 77 dcl statement_info_ptr ptr defined (cobol_$statement_info_ptr); 5 78 dcl cobol_$reswd_ptr ptr ext; 5 79 dcl reswd_ptr ptr defined (cobol_$reswd_ptr); 5 80 dcl cobol_$op_con_ptr ptr ext; 5 81 dcl op_con_ptr ptr defined (cobol_$op_con_ptr); 5 82 dcl cobol_$ntbuf_ptr ptr ext; 5 83 dcl ntbuf_ptr ptr defined (cobol_$ntbuf_ptr); 5 84 dcl cobol_$main_pcs_ptr ptr ext; 5 85 dcl main_pcs_ptr ptr defined (cobol_$main_pcs_ptr); 5 86 dcl cobol_$include_info_ptr ptr ext; 5 87 dcl include_info_ptr ptr defined (cobol_$include_info_ptr); 5 88 5 89 /* FIXED BIN */ 5 90 dcl cobol_$text_wd_off fixed bin ext; 5 91 dcl text_wd_off fixed bin defined (cobol_$text_wd_off); 5 92 dcl cobol_$con_wd_off fixed bin ext; 5 93 dcl con_wd_off fixed bin defined (cobol_$con_wd_off); 5 94 dcl cobol_$def_wd_off fixed bin ext; 5 95 dcl def_wd_off fixed bin defined (cobol_$def_wd_off); 5 96 dcl cobol_$def_max fixed bin ext; 5 97 dcl def_max fixed bin defined (cobol_$def_max); 5 98 dcl cobol_$link_wd_off fixed bin ext; 5 99 dcl link_wd_off fixed bin defined (cobol_$link_wd_off); 5 100 dcl cobol_$link_max fixed bin ext; 5 101 dcl link_max fixed bin defined (cobol_$link_max); 5 102 dcl cobol_$sym_wd_off fixed bin ext; 5 103 dcl sym_wd_off fixed bin defined (cobol_$sym_wd_off); 5 104 dcl cobol_$sym_max fixed bin ext; 5 105 dcl sym_max fixed bin defined (cobol_$sym_max); 5 106 dcl cobol_$reloc_text_max fixed bin(24) ext; 5 107 dcl reloc_text_max fixed bin(24) defined (cobol_$reloc_text_max); 5 108 dcl cobol_$reloc_def_max fixed bin(24) ext; 5 109 dcl reloc_def_max fixed bin(24) defined (cobol_$reloc_def_max); 5 110 dcl cobol_$reloc_link_max fixed bin(24) ext; 5 111 dcl reloc_link_max fixed bin(24) defined (cobol_$reloc_link_max); 5 112 dcl cobol_$reloc_sym_max fixed bin(24) ext; 5 113 dcl reloc_sym_max fixed bin(24) defined (cobol_$reloc_sym_max); 5 114 dcl cobol_$reloc_work_max fixed bin(24) ext; 5 115 dcl reloc_work_max fixed bin(24) defined (cobol_$reloc_work_max); 5 116 dcl cobol_$pd_map_index fixed bin ext; 5 117 dcl pd_map_index fixed bin defined (cobol_$pd_map_index); 5 118 dcl cobol_$cobol_data_wd_off fixed bin ext; 5 119 dcl cobol_data_wd_off fixed bin defined (cobol_$cobol_data_wd_off); 5 120 dcl cobol_$stack_off fixed bin ext; 5 121 dcl stack_off fixed bin defined (cobol_$stack_off); 5 122 dcl cobol_$max_stack_off fixed bin ext; 5 123 dcl max_stack_off fixed bin defined (cobol_$max_stack_off); 5 124 dcl cobol_$init_stack_off fixed bin ext; 5 125 dcl init_stack_off fixed bin defined (cobol_$init_stack_off); 5 126 dcl cobol_$pd_map_sw fixed bin ext; 5 127 dcl pd_map_sw fixed bin defined (cobol_$pd_map_sw); 5 128 dcl cobol_$next_tag fixed bin ext; 5 129 dcl next_tag fixed bin defined (cobol_$next_tag); 5 130 dcl cobol_$data_init_flag fixed bin ext; 5 131 dcl data_init_flag fixed bin defined (cobol_$data_init_flag); 5 132 dcl cobol_$seg_init_flag fixed bin ext; 5 133 dcl seg_init_flag fixed bin defined (cobol_$seg_init_flag); 5 134 dcl cobol_$alter_flag fixed bin ext; 5 135 dcl alter_flag fixed bin defined (cobol_$alter_flag); 5 136 dcl cobol_$sect_eop_flag fixed bin ext; 5 137 dcl sect_eop_flag fixed bin defined (cobol_$sect_eop_flag); 5 138 dcl cobol_$para_eop_flag fixed bin ext; 5 139 dcl para_eop_flag fixed bin defined (cobol_$para_eop_flag); 5 140 dcl cobol_$priority_no fixed bin ext; 5 141 dcl priority_no fixed bin defined (cobol_$priority_no); 5 142 dcl cobol_$compile_count fixed bin ext; 5 143 dcl compile_count fixed bin defined (cobol_$compile_count); 5 144 dcl cobol_$ptr_assumption_ind fixed bin ext; 5 145 dcl ptr_assumption_ind fixed bin defined (cobol_$ptr_assumption_ind); 5 146 dcl cobol_$reg_assumption_ind fixed bin ext; 5 147 dcl reg_assumption_ind fixed bin defined (cobol_$reg_assumption_ind); 5 148 dcl cobol_$perform_para_index fixed bin ext; 5 149 dcl perform_para_index fixed bin defined (cobol_$perform_para_index); 5 150 dcl cobol_$perform_sect_index fixed bin ext; 5 151 dcl perform_sect_index fixed bin defined (cobol_$perform_sect_index); 5 152 dcl cobol_$alter_index fixed bin ext; 5 153 dcl alter_index fixed bin defined (cobol_$alter_index); 5 154 dcl cobol_$list_off fixed bin ext; 5 155 dcl list_off fixed bin defined (cobol_$list_off); 5 156 dcl cobol_$constant_offset fixed bin ext; 5 157 dcl constant_offset fixed bin defined (cobol_$constant_offset); 5 158 dcl cobol_$misc_max fixed bin ext; 5 159 dcl misc_max fixed bin defined (cobol_$misc_max); 5 160 dcl cobol_$pd_map_max fixed bin ext; 5 161 dcl pd_map_max fixed bin defined (cobol_$pd_map_max); 5 162 dcl cobol_$map_data_max fixed bin ext; 5 163 dcl map_data_max fixed bin defined (cobol_$map_data_max); 5 164 dcl cobol_$fixup_max fixed bin ext; 5 165 dcl fixup_max fixed bin defined (cobol_$fixup_max); 5 166 dcl cobol_$tag_table_max fixed bin ext; 5 167 dcl tag_table_max fixed bin defined (cobol_$tag_table_max); 5 168 dcl cobol_$temp_token_max fixed bin ext; 5 169 dcl temp_token_max fixed bin defined (cobol_$temp_token_max); 5 170 dcl cobol_$allo1_max fixed bin ext; 5 171 dcl allo1_max fixed bin defined (cobol_$allo1_max); 5 172 dcl cobol_$eln_max fixed bin ext; 5 173 dcl eln_max fixed bin defined (cobol_$eln_max); 5 174 dcl cobol_$debug_enable fixed bin ext; 5 175 dcl debug_enable fixed bin defined (cobol_$debug_enable); 5 176 dcl cobol_$non_source_offset fixed bin ext; 5 177 dcl non_source_offset fixed bin defined (cobol_$non_source_offset); 5 178 dcl cobol_$initval_flag fixed bin ext; 5 179 dcl initval_flag fixed bin defined (cobol_$initval_flag); 5 180 dcl cobol_$date_compiled_sw fixed bin ext; 5 181 dcl date_compiled_sw fixed bin defined (cobol_$date_compiled_sw); 5 182 dcl cobol_$include_cnt fixed bin ext; 5 183 dcl include_cnt fixed bin defined (cobol_$include_cnt); 5 184 dcl cobol_$fs_charcnt fixed bin ext; 5 185 dcl fs_charcnt fixed bin defined (cobol_$fs_charcnt); 5 186 dcl cobol_$ws_charcnt fixed bin ext; 5 187 dcl ws_charcnt fixed bin defined (cobol_$ws_charcnt); 5 188 dcl cobol_$coms_charcnt fixed bin ext; 5 189 dcl coms_charcnt fixed bin defined (cobol_$coms_charcnt); 5 190 dcl cobol_$ls_charcnt fixed bin ext; 5 191 dcl ls_charcnt fixed bin defined (cobol_$ls_charcnt); 5 192 dcl cobol_$cons_charcnt fixed bin ext; 5 193 dcl cons_charcnt fixed bin defined (cobol_$cons_charcnt); 5 194 dcl cobol_$value_cnt fixed bin ext; 5 195 dcl value_cnt fixed bin defined (cobol_$value_cnt); 5 196 dcl cobol_$cd_cnt fixed bin ext; 5 197 dcl cd_cnt fixed bin defined (cobol_$cd_cnt); 5 198 dcl cobol_$fs_wdoff fixed bin ext; 5 199 dcl fs_wdoff fixed bin defined (cobol_$fs_wdoff); 5 200 dcl cobol_$ws_wdoff fixed bin ext; 5 201 dcl ws_wdoff fixed bin defined (cobol_$ws_wdoff); 5 202 dcl cobol_$coms_wdoff fixed bin ext; 5 203 dcl coms_wdoff fixed bin defined (cobol_$coms_wdoff); 5 204 5 205 /* CHARACTER */ 5 206 dcl cobol_$scratch_dir char (168) aligned ext; 5 207 dcl scratch_dir char (168) aligned defined (cobol_$scratch_dir); /* -42- */ 5 208 dcl cobol_$obj_seg_name char (32) aligned ext; 5 209 dcl obj_seg_name char (32) aligned defined (cobol_$obj_seg_name); /* -8- */ 5 210 5 211 /* BIT */ 5 212 dcl cobol_$xref_bypass bit(1) aligned ext; 5 213 dcl xref_bypass bit(1) aligned defined (cobol_$xref_bypass); /* -1- */ 5 214 dcl cobol_$same_sort_merge_proc bit(1) aligned ext; 5 215 dcl same_sort_merge_proc bit(1) aligned defined (cobol_$same_sort_merge_proc); /* -1- */ 5 216 5 217 5 218 /* END INCLUDE FILE ... cobol_incl.pl1*/ 5 219 5 220 2955 2956 dcl 1 ptr_status (0:7) based (cobol_$ptr_status_ptr) aligned, 6 1 6 2 /* BEGIN INCLUDE FILE ... cobol_ptr_status.incl.pl1 */ 6 3 /* Last modified June 3, 76 by bc */ 6 4 /* last modified Oct. 31,75 by tlf */ 6 5 6 6 /* 6 7*1. This structure contains the status of the object time 6 8* pointer registers. 6 9*2. The caller should provide a dcl statement in the form: 6 10* dcl 1 ptr_status (0:7) based ( cobol_$ptr_status_ptr) aligned, 6 11**/ 6 12 6 13 2 pointer_num bit (3), 6 14 2 usage fixed bin, 6 15 2 contents_sw fixed bin, 6 16 2 seg_num fixed bin, 6 17 2 wd_offset fixed bin (24), 6 18 2 p_lock fixed bin, 6 19 2 p_priority fixed bin, 6 20 2 p_reset fixed bin, 6 21 2 reset_seg_num fixed bin, 6 22 2 reset_wd_offset fixed bin (24), 6 23 02 save_stack_max fixed bin, 6 24 02 save_stack_count fixed bin, 6 25 02 save_stack (1:10) bit (36), 6 26 02 reloc_stack (1:10), 6 27 03 left_reloc_info bit (5) aligned, 6 28 03 right_reloc_info bit (5) aligned; 6 29 6 30 6 31 6 32 /* END INCLUDE FILE ... cobol_ptr_status.incl.pl1 */ 6 33 2957 2958 dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, 7 1 7 2 /* BEGIN INCLUDE FILE ... cobol_reg_status.incl.pl1 */ 7 3 /* last modified Oct. 31,75 by tlf */ 7 4 7 5 /* 7 6*1. This structure maintains the status of the object 7 7* time A,Q and index registers. 7 8*2. The caller should provide a dcl statement in the form. 7 9* dcl 1 reg_status (0:9) based ( cobol_$reg_status_ptr) aligned, 7 10**/ 7 11 7 12 2 register_num bit (4), 7 13 2 r_lock fixed bin, 7 14 2 r_priority fixed bin, 7 15 02 save_stack_max fixed bin, 7 16 02 save_stack_count fixed bin, 7 17 02 save_stack (1:10) bit (36), 7 18 02 reloc_stack (1:10), 7 19 03 left_reloc_info bit (5) aligned, 7 20 03 right_reloc_info bit (5) aligned; 7 21 7 22 7 23 7 24 /* END INCLUDE FILE ... cobol_reg_status.incl.pl1 */ 7 25 2959 8 1 8 2 /* BEGIN INCLUDE FILE ... cobol_type10.incl.pl1 */ 8 3 /* Last modified on 11/19/76 by ORN */ 8 4 /* 8 5*A type 10 index name token is entered into the name table by the data 8 6*division syntax phase for each index name appearing in the data division. 8 7*An index name is declared in the indexed by phrase of an occurs clause. 8 8*maintain the binary byte offset, within the array, corresponding to the 8 9*current setting of the index name. The right-most two bytes contain the 8 10*binary occurrence number to which the index name is set. 8 11*When the replacement phase processes the procedure division minpral file, 8 12*each reference to an index name is replaced with the type 10 token created 8 13*for that index name. 8 14**/ 8 15 8 16 dcl ind_ptr ptr; 8 17 8 18 /* BEGIN DECLARATION OF TYPE10 (INDEX NAME) TOKEN */ 8 19 dcl 1 index_name based (ind_ptr), 9 1 9 2 /* begin include file ... cobol_TYPE10.incl.pl1 9 3*/* Last modified on 01/25/77 by ORN */ 9 4 9 5 /* header */ 9 6 2 size fixed bin, 9 7 2 line fixed bin, 9 8 2 column fixed bin, 9 9 2 type fixed bin, 9 10 /* body */ 9 11 2 string_ptr ptr, 9 12 2 prev_rec ptr, 9 13 2 searched bit(1), 9 14 2 duplicate bit(1), 9 15 2 saved bit(1), 9 16 2 debug_ind bit(1), 9 17 2 filler1 bit(3), 9 18 2 subscript bit(1), 9 19 2 def_line fixed bin, 9 20 2 level fixed bin, 9 21 2 seg_num fixed bin, 9 22 2 offset fixed bin(24), 9 23 2 index_no fixed bin, 9 24 2 min fixed bin, 9 25 2 max fixed bin, 9 26 2 struc_length fixed bin, 9 27 2 cswd_seg fixed bin, 9 28 2 cswd_offset fixed bin(24), 9 29 2 name_size fixed bin, 9 30 2 name char(0 refer(index_name.name_size)); 9 31 9 32 9 33 9 34 /* end include file ... cobol_TYPE10.incl.pl1 */ 9 35 8 20 8 21 /* END DECLARATION OF TYPE10 (INDEX NAME) TOKEN */ 8 22 8 23 /* END INCLUDE FILE ... cobol_type10.incl.pl1 */ 8 24 2960 10 1 10 2 /* BEGIN INCLUDE FILE ... cobol_type1.incl.pl1 */ 10 3 /* Last modified on 11/19/76 by ORN */ 10 4 10 5 /* 10 6*A reserved word token is created in the minpral files for each occurrence 10 7*of a reserved word in the source program. The value of the key field 10 8*indicates the specific reserved word which a type 1 token represents. 10 9**/ 10 10 10 11 dcl rw_ptr ptr; 10 12 10 13 /* BEGIN DECLARATION OF TYPE1 (RESERVED WORD) TOKEN */ 10 14 dcl 1 reserved_word based (rw_ptr), 11 1 11 2 /* begin include file ... cobol_TYPE1.incl.pl1 */ 11 3 /* Last modified on 11/17/76 by ORN */ 11 4 /* Last modified on 12/28/76 by FCH */ 11 5 /* Last modified on 12/16/80 by FCH */ 11 6 11 7 /* header */ 11 8 2 size fixed bin, 11 9 2 line fixed bin, 11 10 2 column fixed bin, 11 11 2 type fixed bin, 11 12 /* body */ 11 13 2 key fixed bin, 11 14 /* procedure division class bits */ 11 15 2 verb bit (1), 11 16 2 arith_op bit (1), 11 17 2 figcon bit (1), 11 18 2 terminator bit (1), 11 19 2 end_dec bit (1), 11 20 2 rel_op bit (1), 11 21 2 imper_verb bit (1), 11 22 2 end_cobol bit (1), 11 23 /* data division class bits */ 11 24 2 section_header bit (1), 11 25 2 fs_ind bit (1), 11 26 2 fd_clause bit (1), 11 27 2 dd_clause bit (1), 11 28 2 cd_input bit (1), 11 29 2 cd_output bit (1), 11 30 2 cset_name bit (1), 11 31 2 ss_division bit (1), 11 32 2 repl_jump_ind bit (4), 11 33 2 ided_recovery bit (1), 11 34 2 report_writer bit (5), 11 35 2 ss_desc_entry bit (1), 11 36 2 jump_index fixed bin, 11 37 2 length fixed bin, 11 38 2 name char(0 refer(reserved_word.length)); 11 39 11 40 11 41 11 42 /* end include file ... cobol_TYPE1.incl.pl1 */ 11 43 10 15 10 16 /* END DECLARATION OF TYPE1 (RESERVED WORD) TOKEN */ 10 17 10 18 /* END INCLUDE FILE ... cobol_type1.incl.pl1 */ 10 19 2961 12 1 12 2 /* BEGIN INCLUDE FILE ... cobol_type2.incl.pl1 */ 12 3 /* Last modified on 11/19/76 by ORN */ 12 4 12 5 /* 12 6*A type 2 numeric literal token is entered into the minpral file by the 12 7*lexical analysis phase for each numeric literal encountered in the source 12 8*program. 12 9**/ 12 10 12 11 dcl nlit_ptr ptr; 12 12 12 13 /* BEGIN DECLARATION OF TYPE2 (NUMERIC LITERAL) TOKEN */ 12 14 dcl 1 numeric_lit based (nlit_ptr), 13 1 13 2 /* begin include file ... cobol_TYPE2.incl.pl1 */ 13 3 /* Last modified on 12/28/76 by FCH */ 13 4 13 5 /* header */ 13 6 2 size fixed bin, 13 7 2 line fixed bin, 13 8 2 column fixed bin, 13 9 2 type fixed bin, 13 10 /* body */ 13 11 2 integral bit(1), 13 12 2 floating bit(1), 13 13 2 seg_range bit(1), 13 14 2 filler1 bit(4), 13 15 2 subscript bit(1), 13 16 2 sign char(1), 13 17 2 exp_sign char(1), 13 18 2 exp_places fixed bin, 13 19 2 places_left fixed bin, 13 20 2 places_right fixed bin, 13 21 2 places fixed bin, 13 22 2 literal char(0 refer(numeric_lit.places)); 13 23 13 24 13 25 13 26 /* end include file ... cobol_TYPE2.incl.pl1 */ 13 27 12 15 12 16 /* END DECLARATION OF TYPE2 (NUMERIC LITERAL) TOKEN */ 12 17 12 18 /* END INCLUDE FILE ... cobol_type2.incl.pl1 */ 12 19 2962 14 1 14 2 /* BEGIN INCLUDE FILE ... cobol_in_token.incl.pl1 */ 14 3 14 4 /* Last modified August 22, 1974 by AEG */ 14 5 14 6 14 7 declare in_token_ptr ptr; 14 8 14 9 declare 1 in_token aligned based(in_token_ptr), 14 10 2 n fixed bin aligned, 14 11 2 code fixed bin aligned, 14 12 2 token_ptr(0 refer(in_token.n)) ptr aligned; 14 13 14 14 14 15 /* END INCLUDE FILE ... cobol_in_token.incl.pl1 */ 14 16 2963 15 1 15 2 /* BEGIN INCLUDE FILE ... cobol_type18.incl.pl1 */ 15 3 /* Last modified on 11/19/76 by ORN */ 15 4 15 5 /* 15 6*A type 18 procedure reference token is entered into the procedure division 15 7*minpral file by the replacement phase to replace each type 8 user word 15 8*reference to a procedure name. A type 18 token is constructed by changing 15 9*the type field of the appropriate type 7 procedure definition token from 15 10*the name table to 18. 15 11**/ 15 12 15 13 dcl proc_ref_ptr ptr; 15 14 15 15 /* BEGIN DECLARATION OF TYPE18 (PROCEDURE REFERENCE) TOKEN */ 15 16 dcl 1 proc_ref based (proc_ref_ptr), 16 1 16 2 /* begin include file ... cobol_TYPE18.incl.pl1 */ 16 3 /* Last modified on 11/7/76 by ORN */ 16 4 16 5 /* header */ 16 6 2 size fixed bin, 16 7 2 line fixed bin, 16 8 2 column fixed bin, 16 9 2 type fixed bin, 16 10 /* body */ 16 11 2 string_ptr ptr, 16 12 2 prev_rec ptr, 16 13 2 searched bit (1), 16 14 2 duplicate bit (1), 16 15 2 filler1 bit (1), 16 16 2 debug_ind bit (1), 16 17 2 section_name bit (1), 16 18 2 declarative_proc bit (1), 16 19 2 filler2 bit (1), 16 20 2 alterable bit (1), 16 21 2 priority char (2), 16 22 2 sort_range bit (1), 16 23 2 input_range bit (1), 16 24 2 output_range bit (1), 16 25 2 merge_range bit(1), 16 26 2 filler3 bit (5), 16 27 2 section_num fixed bin, 16 28 2 proc_num fixed bin, 16 29 2 def_line fixed bin, 16 30 2 name_size fixed bin, 16 31 2 name char (30); 16 32 16 33 /* end include file ... cobol_TYPE18.incl.pl1 */ 16 34 15 17 15 18 /* END DECLARATION OF TYPE18 (PROCEDURE REFERENCE) TOKEN */ 15 19 15 20 /* END INCLUDE FILE ... cobol_type18.incl.pl1 */ 15 21 2964 17 1 17 2 /* BEGIN INCLUDE FILE ... cobol_fixed_common.incl.pl1 */ 17 3 /* Modified on 10/27/82 by FCH, [5.1-1], cobol_cln added to save last line num, BUG543(phx13643) */ 17 4 /* Modified on 07/31/80 by FCH, [4.3-1], use_reporting field added for Report Writer */ 17 5 /* Modified on 03/30/79 by FCH, [4.1-1], -card option added */ 17 6 /* Modified on 03/30/79 by FCH, [4.0-2], -svNM option added */ 17 7 /* Modified on 03/02/79 by FCH, [4.0-1], -levNM option added */ 17 8 /* Modified by RAL on 10/13/78, [4.0-0], Added option exp from fil2. */ 17 9 /* Modified by BC on 06/20/77, descriptor added. */ 17 10 /* Modified by BC on 06/02/77, init_cd_seg, init_cd_offset added. */ 17 11 /* Modified by BC on 1/21/77, options.profile added. */ 17 12 /* Modified by FCH on 7/6/76, sysin_fno & sysout_fno deleted, accept_device & display_device added */ 17 13 /* Modified by FCH on 5/20/77, comp_level added */ 17 14 17 15 17 16 /* THE SIZE OF THIS STRUCTURE IN BYTES, (EXCLUDING VARIABLE 17 17* LENGTH ENTITIES), FOR EACH HARDWARE IMPLEMENTATION IS: 17 18* 17 19* HARDWARE | SIZE (BYTES) 17 20* --------------------------------- 17 21* 645/6180 | 464 17 22* P7 | 396 17 23* --------------------------------- 17 24* */ 17 25 17 26 dcl 1 fixed_common based ( cobol_com_ptr), 17 27 2 prog_name char (30), 17 28 2 compiler_rev_no char (25), 17 29 2 phase_name char (6), 17 30 2 currency char (1), 17 31 2 fatal_no fixed bin, 17 32 2 warn_no fixed bin, 17 33 2 proc_counter fixed bin, 17 34 2 spec_tag_counter fixed bin, 17 35 2 file_count fixed bin, 17 36 2 filedescr_offsets (20) char (5), 17 37 2 perf_alter_info char (5), 17 38 2 another_perform_info char (5), 17 39 2 sort_in_info char (5), 17 40 2 odo_info char (5), 17 41 2 size_seg fixed bin, 17 42 2 size_offset fixed bin(24), 17 43 2 size_perform_info char (5), 17 44 2 rename_info char (5), 17 45 2 report_names char (5), 17 46 2 rw_buf_seg fixed bin, 17 47 2 rw_buf_offset fixed bin(24), 17 48 2 rw_buf_length fixed bin(24), 17 49 2 file_keys char (5), 17 50 2 search_keys char (5), 17 51 2 dd_seg_size fixed bin(24), 17 52 2 pd_seg_size fixed bin(24), 17 53 2 seg_limit fixed bin , 17 54 2 number_of_dd_segs fixed bin, 17 55 2 seg_info char (5), 17 56 2 number_of_ls_pointers fixed bin, 17 57 2 link_sec_seg fixed bin, 17 58 2 link_sec_offset fixed bin(24), 17 59 2 sra_clauses fixed bin, 17 60 2 fix_up_info char (5), 17 61 2 linage_info char (5), 17 62 2 first_dd_item char (5), 17 63 2 sort_out_info char (5), 17 64 2 db_info char (5), 17 65 2 realm_info char (5), 17 66 2 rc_realm_info char (5), 17 67 2 last_file_key char (5), 17 68 2 prog_coll_seq fixed bin, 17 69 2 init_cd_seg fixed bin, 17 70 2 init_cd_offset fixed bin(24), 17 71 2 input_error_exit fixed bin, 17 72 2 output_error_exit fixed bin, 17 73 2 i_o_error_exit fixed bin, 17 74 2 extend_error_exit fixed bin, 17 75 2 dummy15 fixed bin, 17 76 2 options, 17 77 3 cu bit (1), 17 78 3 st bit (1), 17 79 3 wn bit (1), 17 80 3 obs bit (1), 17 81 3 dm bit (1), 17 82 3 xrl bit (1), 17 83 3 xrn bit (1), 17 84 3 src bit (1), 17 85 3 obj bit (1), 17 86 3 exs bit (1), 17 87 3 sck bit (1), 17 88 3 rno bit (1), 17 89 3 u_l bit (1), 17 90 3 cnv bit (1), 17 91 3 cos bit (1), 17 92 3 fmt bit (1), 17 93 3 profile bit(1), 17 94 3 nw bit (1), 17 95 3 exp bit (1), /* [4.0-0] */ 17 96 3 card bit (1), /*[4.1-1]*/ 17 97 3 fil2 bit (5), 17 98 3 m_map bit (1), 17 99 3 m_bf bit (1), 17 100 3 m_fat bit (1), 17 101 3 m_wn bit (1), 17 102 3 m_obs bit(1), 17 103 3 pd bit(1), 17 104 3 oc bit(1), 17 105 2 supervisor bit (1), 17 106 2 dec_comma bit (1), 17 107 2 init_cd bit (1), 17 108 2 corr bit (1), 17 109 2 initl bit (1), 17 110 2 debug bit (1), 17 111 2 report bit (1), 17 112 2 sync_in_prog bit (1), 17 113 2 pd_section bit (1), 17 114 2 list_switch bit (1), 17 115 2 alpha_cond bit (1), 17 116 2 num_cond bit (1), 17 117 2 spec_sysin bit (1), 17 118 2 spec_sysout bit (1), 17 119 2 cpl_files bit (1), 17 120 2 obj_dec_comma bit (1), 17 121 2 default_sign_type bit (3), 17 122 2 use_debug bit(1), 17 123 2 syntax_trace bit(1), 17 124 2 comp_defaults, 17 125 3 comp bit(1), 17 126 3 comp_1 bit(1), 17 127 3 comp_2 bit(1), 17 128 3 comp_3 bit(1), 17 129 3 comp_4 bit(1), 17 130 3 comp_5 bit(1), 17 131 3 comp_6 bit(1), 17 132 3 comp_7 bit(1), 17 133 3 comp_8 bit(1), 17 134 2 disp_defaults, 17 135 3 disp bit(1), 17 136 3 disp_1 bit(1), 17 137 3 disp_2 bit(1), 17 138 3 disp_3 bit(1), 17 139 3 disp_4 bit(1), 17 140 3 disp_5 bit(1), 17 141 3 disp_6 bit(1), 17 142 3 disp_7 bit(1), 17 143 2 descriptor bit(2), 17 144 2 levsv bit(3), /*[4.0-1]*/ 17 145 2 use_reporting bit(1), /*[4.3-1]*/ 17 146 2 cd bit(1), /*[4.4-1]*/ 17 147 2 dummy17 bit(3), 17 148 2 lvl_rstr bit(32), 17 149 2 inst_rstr bit(32), 17 150 2 comp_level char(1), 17 151 2 dummy18 char(30), 17 152 2 object_sign char (1), 17 153 2 last_print_rec char (5), 17 154 2 coll_seq_info char (5), 17 155 2 sys_status_seg fixed bin, 17 156 2 sys_status_offset fixed bin(24), 17 157 2 compiler_id fixed bin, 17 158 2 date_comp_ln fixed bin, 17 159 2 compile_mode bit(36), 17 160 2 default_temp fixed bin, 17 161 2 accept_device fixed bin, 17 162 2 display_device fixed bin, 17 163 2 cobol_cln fixed bin, /*[5.1-1]*/ 17 164 2 alphabet_offset fixed bin; 17 165 17 166 17 167 17 168 /* END INCLUDE FILE ... cobol_fixed_common.incl.pl1 */ 17 169 2965 18 1 18 2 /* BEGIN INCLUDE FILE ... cobol_ext_.incl.pl1 */ 18 3 /* Last modified on 06/17/76 by ORN */ 18 4 /* Last modified on 12/28/76 by FCH */ 18 5 /* Last modified on 12/01/80 by FCH */ 18 6 18 7 /* <<< SHARED EXTERNALS INCLUDE FILE >>> */ 18 8 18 9 18 10 dcl cobol_ext_$cobol_afp ptr ext; 18 11 dcl cobol_afp ptr defined ( cobol_ext_$cobol_afp); 18 12 dcl cobol_ext_$cobol_analin_fileno ptr ext; 18 13 dcl cobol_analin_fileno ptr defined ( cobol_ext_$cobol_analin_fileno); 18 14 dcl cobol_ext_$report_first_token ptr ext; 18 15 dcl report_first_token ptr defined( cobol_ext_$report_first_token); 18 16 dcl cobol_ext_$report_last_token ptr ext; 18 17 dcl report_last_token ptr defined ( cobol_ext_$report_last_token); 18 18 dcl cobol_ext_$cobol_eltp ptr ext; 18 19 dcl cobol_eltp ptr defined ( cobol_ext_$cobol_eltp); 18 20 dcl cobol_ext_$cobol_cmfp ptr ext; 18 21 dcl cobol_cmfp ptr defined ( cobol_ext_$cobol_cmfp); 18 22 dcl cobol_ext_$cobol_com_fileno ptr ext; 18 23 dcl cobol_com_fileno ptr defined ( cobol_ext_$cobol_com_fileno); 18 24 dcl cobol_ext_$cobol_com_ptr ptr ext; 18 25 dcl cobol_com_ptr ptr defined ( cobol_ext_$cobol_com_ptr); 18 26 dcl cobol_ext_$cobol_dfp ptr ext; 18 27 dcl cobol_dfp ptr defined ( cobol_ext_$cobol_dfp); 18 28 dcl cobol_ext_$cobol_hfp ptr ext; 18 29 dcl cobol_hfp ptr defined ( cobol_ext_$cobol_hfp); 18 30 dcl cobol_ext_$cobol_m1fp ptr ext; 18 31 dcl cobol_m1fp ptr defined ( cobol_ext_$cobol_m1fp); 18 32 dcl cobol_ext_$cobol_m2fp ptr ext; 18 33 dcl cobol_m2fp ptr defined ( cobol_ext_$cobol_m2fp); 18 34 dcl cobol_ext_$cobol_min1_fileno ptr ext; 18 35 dcl cobol_min1_fileno ptr defined ( cobol_ext_$cobol_min1_fileno); 18 36 dcl cobol_ext_$cobol_min2_fileno_ptr ptr ext; 18 37 dcl cobol_min2_fileno_ptr ptr defined ( cobol_ext_$cobol_min2_fileno_ptr); 18 38 dcl cobol_ext_$cobol_name_fileno ptr ext; 18 39 dcl cobol_name_fileno ptr defined ( cobol_ext_$cobol_name_fileno); 18 40 dcl cobol_ext_$cobol_name_fileno_ptr ptr ext; 18 41 dcl cobol_name_fileno_ptr ptr defined ( cobol_ext_$cobol_name_fileno_ptr); 18 42 dcl cobol_ext_$cobol_ntfp ptr ext; 18 43 dcl cobol_ntfp ptr defined ( cobol_ext_$cobol_ntfp); 18 44 dcl cobol_ext_$cobol_pdofp ptr ext; 18 45 dcl cobol_pdofp ptr defined ( cobol_ext_$cobol_pdofp); 18 46 dcl cobol_ext_$cobol_pfp ptr ext; 18 47 dcl cobol_pfp ptr defined ( cobol_ext_$cobol_pfp); 18 48 dcl cobol_ext_$cobol_rm2fp ptr ext; 18 49 dcl cobol_rm2fp ptr defined ( cobol_ext_$cobol_rm2fp); 18 50 dcl cobol_ext_$cobol_rmin2fp ptr ext; 18 51 dcl cobol_rmin2fp ptr defined ( cobol_ext_$cobol_rmin2fp); 18 52 dcl cobol_ext_$cobol_curr_in ptr ext; 18 53 dcl cobol_curr_in ptr defined ( cobol_ext_$cobol_curr_in); 18 54 dcl cobol_ext_$cobol_curr_out ptr ext; 18 55 dcl cobol_curr_out ptr defined ( cobol_ext_$cobol_curr_out); 18 56 dcl cobol_ext_$cobol_sfp ptr ext; 18 57 dcl cobol_sfp ptr defined ( cobol_ext_$cobol_sfp); 18 58 dcl cobol_ext_$cobol_w1p ptr ext; 18 59 dcl cobol_w1p ptr defined ( cobol_ext_$cobol_w1p); 18 60 dcl cobol_ext_$cobol_w2p ptr ext; 18 61 dcl cobol_w2p ptr defined ( cobol_ext_$cobol_w2p); 18 62 dcl cobol_ext_$cobol_w3p ptr ext; 18 63 dcl cobol_w3p ptr defined ( cobol_ext_$cobol_w3p); 18 64 dcl cobol_ext_$cobol_w5p ptr ext; 18 65 dcl cobol_w5p ptr defined ( cobol_ext_$cobol_w5p); 18 66 dcl cobol_ext_$cobol_w6p ptr ext; 18 67 dcl cobol_w6p ptr defined ( cobol_ext_$cobol_w6p); 18 68 dcl cobol_ext_$cobol_w7p ptr ext; 18 69 dcl cobol_w7p ptr defined ( cobol_ext_$cobol_w7p); 18 70 dcl cobol_ext_$cobol_x3fp ptr ext; 18 71 dcl cobol_x3fp ptr defined ( cobol_ext_$cobol_x3fp); 18 72 dcl cobol_ext_$cobol_rwdd ptr ext; 18 73 dcl cobol_rwdd ptr defined(cobol_ext_$cobol_rwdd); 18 74 dcl cobol_ext_$cobol_rwpd ptr ext; 18 75 dcl cobol_rwpd ptr defined(cobol_ext_$cobol_rwpd); 18 76 18 77 18 78 dcl cobol_ext_$cobol_fileno1 fixed bin(24)ext; 18 79 dcl cobol_fileno1 fixed bin(24)defined ( cobol_ext_$cobol_fileno1); 18 80 dcl cobol_ext_$cobol_options_len fixed bin(24)ext; 18 81 dcl cobol_options_len fixed bin(24)defined ( cobol_ext_$cobol_options_len); 18 82 dcl cobol_ext_$cobol_pdout_fileno fixed bin(24)ext; 18 83 dcl cobol_pdout_fileno fixed bin(24)defined ( cobol_ext_$cobol_pdout_fileno); 18 84 dcl cobol_ext_$cobol_print_fileno fixed bin(24)ext; 18 85 dcl cobol_print_fileno fixed bin(24)defined ( cobol_ext_$cobol_print_fileno); 18 86 dcl cobol_ext_$cobol_rmin2_fileno fixed bin(24)ext; 18 87 dcl cobol_rmin2_fileno fixed bin(24)defined ( cobol_ext_$cobol_rmin2_fileno); 18 88 dcl cobol_ext_$cobol_x1_fileno fixed bin(24)ext; 18 89 dcl cobol_x1_fileno fixed bin(24)defined ( cobol_ext_$cobol_x1_fileno); 18 90 dcl cobol_ext_$cobol_x2_fileno fixed bin(24)ext; 18 91 dcl cobol_x2_fileno fixed bin(24)defined ( cobol_ext_$cobol_x2_fileno); 18 92 dcl cobol_ext_$cobol_x3_fileno fixed bin(24)ext; 18 93 dcl cobol_x3_fileno fixed bin(24)defined ( cobol_ext_$cobol_x3_fileno); 18 94 18 95 dcl cobol_ext_$cobol_lpr char (5) ext; 18 96 dcl cobol_lpr char (5) defined ( cobol_ext_$cobol_lpr); /* -2- */ 18 97 dcl cobol_ext_$cobol_options char (120) ext; 18 98 dcl cobol_options char (120) defined ( cobol_ext_$cobol_options); /* -30- */ 18 99 18 100 dcl cobol_ext_$cobol_xlast8 bit (1) ext; 18 101 dcl cobol_xlast8 bit (1) defined ( cobol_ext_$cobol_xlast8); /* -1- */ 18 102 dcl cobol_ext_$report_exists bit (1) ext; 18 103 dcl report_exists bit (1) defined ( cobol_ext_$report_exists); 18 104 18 105 18 106 /* <<< END OF SHARED EXTERNALS INCLUDE FILE >>> */ 18 107 /* END INCLUDE FILE ... cobol_ext_.incl.pl1 */ 18 108 2966 2967 2968 end cobol_addr; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0830.4 cobol_addr.pl1 >spec>install>MR12.3-1048>cobol_addr.pl1 2952 1 05/24/89 0811.7 cobol_addr_tokens.incl.pl1 >spec>install>MR12.3-1048>cobol_addr_tokens.incl.pl1 2953 2 03/27/82 0439.9 cobol_type9.incl.pl1 >ldd>include>cobol_type9.incl.pl1 2-17 3 11/11/82 1712.7 cobol_TYPE9.incl.pl1 >ldd>include>cobol_TYPE9.incl.pl1 2954 4 11/11/82 1712.7 cobol_occurs_ext.incl.pl1 >ldd>include>cobol_occurs_ext.incl.pl1 2955 5 11/11/82 1712.7 cobol_.incl.pl1 >ldd>include>cobol_.incl.pl1 2957 6 11/11/82 1712.8 cobol_ptr_status.incl.pl1 >ldd>include>cobol_ptr_status.incl.pl1 2959 7 11/11/82 1712.8 cobol_reg_status.incl.pl1 >ldd>include>cobol_reg_status.incl.pl1 2960 8 03/27/82 0439.8 cobol_type10.incl.pl1 >ldd>include>cobol_type10.incl.pl1 8-20 9 11/11/82 1712.7 cobol_TYPE10.incl.pl1 >ldd>include>cobol_TYPE10.incl.pl1 2961 10 03/27/82 0439.8 cobol_type1.incl.pl1 >ldd>include>cobol_type1.incl.pl1 10-15 11 11/11/82 1712.8 cobol_TYPE1.incl.pl1 >ldd>include>cobol_TYPE1.incl.pl1 2962 12 03/27/82 0439.8 cobol_type2.incl.pl1 >ldd>include>cobol_type2.incl.pl1 12-15 13 11/11/82 1712.8 cobol_TYPE2.incl.pl1 >ldd>include>cobol_TYPE2.incl.pl1 2963 14 11/11/82 1712.7 cobol_in_token.incl.pl1 >ldd>include>cobol_in_token.incl.pl1 2964 15 11/11/82 1712.8 cobol_type18.incl.pl1 >ldd>include>cobol_type18.incl.pl1 15-17 16 03/27/82 0439.6 cobol_TYPE18.incl.pl1 >ldd>include>cobol_TYPE18.incl.pl1 2965 17 11/11/82 1712.8 cobol_fixed_common.incl.pl1 >ldd>include>cobol_fixed_common.incl.pl1 2966 18 03/27/82 0431.3 cobol_ext_.incl.pl1 >ldd>include>cobol_ext_.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. S_T based structure level 1 packed packed unaligned dcl 2652 addr builtin function dcl 2947 ref 64 95 104 104 110 111 153 154 360 360 389 391 393 485 485 619 620 625 699 699 729 761 844 961 1049 1049 1054 1054 1061 1061 1066 1066 1076 1076 1241 1241 1358 1358 1369 1369 1430 1430 1576 1576 1749 1749 1818 1928 1970 2039 2056 2056 2062 2070 2070 2150 2150 2240 2245 addr_ptr 000210 automatic fixed bin(17,0) array dcl 2714 set ref 92* 561 566* 566 1404 1410 1416 1422 1440* 1459* 2006* 2494* addr_reg 000176 automatic fixed bin(17,0) array dcl 2713 set ref 91* 499 502 535 539* 539 550 552 1533 1537* 1537 1562 1570* 1570 1602* 1602 1623* 1623 1641 1642* addrel builtin function dcl 2947 ref 1733 1738 1830 2443 2502 2578 adwp_du 000175 automatic fixed bin(35,0) dcl 2712 set ref 1283* 1285 1286* 1286 1287 1291 adwp_op 000171 automatic bit(10) packed unaligned dcl 2709 set ref 1276 1472* 1479* 1486* 1493* aj_const_off 000245 automatic fixed bin(17,0) array dcl 2728 set ref 150* 150* 150* 577 635* aj_off 000147 automatic fixed bin(17,0) initial dcl 2672 set ref 322 736 859 881 1757* 1774* 1774 2377* 2377 2627* 2627 2672* al_bd 000622 automatic fixed bin(17,0) dcl 1681 set ref 1893* 1895* 1900* al_char 000621 automatic fixed bin(17,0) dcl 1681 set ref 1892* 1895* 1900* alphabetic 21(21) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 alphabetic_edited 21(22) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 alphanum 21(19) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 alphanum_edited 21(20) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 ar 000603 automatic fixed bin(17,0) dcl 1633 set ref 1641* 1642 1642 ar_buff 000234 automatic char(32) packed unaligned dcl 2726 set ref 95 ar_type 000520 automatic fixed bin(17,0) dcl 1182 set ref 1200* 1202* 1206* 1208* 1211* 1213* 1214* 1216* 1218* 1220* 1224* 1227* 1230 ascii_packed_dec 21(30) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 805 817 856 919 928 1002 1109 1762 ascii_packed_dec_h 21(29) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 826 862 868 931 b1_count 000230 automatic fixed bin(17,0) dcl 2721 set ref 262* 264* bin_18 21(13) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 1909 1922 1948 bin_36 21(14) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 1909 1922 binary builtin function dcl 2947 ref 227 240 291 299 579 721 813 824 866 1768 2478 bit_offset 31(16) based bit(4) level 2 packed packed unaligned dcl 2-16 ref 826 862 bit_temp 001511 automatic bit(18) packed unaligned dcl 2171 set ref 2190* 2194 2194 2196 bit_test defined bit(1) array packed unaligned dcl 2171 ref 2194 char_n 0(18) based bit(3) array level 3 packed packed unaligned dcl 1-103 set ref 723* 724* 731* 739* 740* char_offset 4 based fixed bin(24,0) level 2 dcl 1-23 ref 227 232 240 250 check_tag 000264 automatic fixed bin(17,0) array dcl 2746 set ref 2035* 2036* 2057* 2058* 2066* 2071* cobol_$compile_count 000122 external static fixed bin(17,0) dcl 5-142 ref 2242 2247 cobol_$next_tag 000120 external static fixed bin(17,0) dcl 5-128 set ref 1798 1799* 1799 2035 2036 2037* 2037 cobol_$ptr_status_ptr 000112 external static pointer dcl 5-56 ref 1252 1252 1262 1262 1301 1301 1301 1310 1310 1319 1319 1384 1390 1396 1439 1458 cobol_$reg_status_ptr 000114 external static pointer dcl 5-58 ref 1533 1535 1598 1601 cobol_$text_wd_off 000116 external static fixed bin(17,0) dcl 5-90 set ref 151 227 291 516 1801* 2051 2057 2058* 2066* 2071 cobol_alloc$stack 000102 constant entry external dcl 2767 ref 1114 1895 1900 2318 cobol_com_ptr defined pointer dcl 18-25 ref 1796 1870 2030 cobol_define_tag_nc 000074 constant entry external dcl 2764 ref 1801 2058 2066 cobol_emit 000060 constant entry external dcl 2660 ref 144 264 333 468 1049 1054 1061 1066 1076 1131 1152 1291 1293 1337 1352 1911 1917 2014 2032 2056 2070 2128 2411 cobol_ext_$cobol_com_ptr 000124 external static pointer dcl 18-24 ref 1796 1796 1870 1870 2030 2030 cobol_gen_error$reg_reset 000104 constant entry external dcl 2768 ref 1870 2059 cobol_get_size 000066 constant entry external dcl 2760 ref 128 cobol_make_tagref 000076 constant entry external dcl 2765 ref 2057 2071 cobol_make_type9$long_bin 000130 constant entry external dcl 1705 ref 2252 cobol_move_gen 000126 constant entry external dcl 1704 ref 2258 cobol_pointer_register$get 000106 constant entry external dcl 2770 ref 1455 cobol_pointer_register$priority 000110 constant entry external dcl 2772 ref 83 84 85 564 2003 2492 cobol_pool 000100 constant entry external dcl 2766 ref 2048 cobol_register$load 000072 constant entry external dcl 2763 ref 1567 1620 cobol_register$release 000070 constant entry external dcl 2761 ref 71 79 1654 cobol_reset_r$pointer_register 000064 constant entry external dcl 2706 ref 1366 data_name based structure level 1 unaligned dcl 2-16 dec_bin_temp 000146 automatic fixed bin(17,0) initial dcl 2672 set ref 2672* desc_an based structure level 1 packed packed unaligned dcl 1-103 desc_an_ptr 000312 automatic pointer dcl 1-119 set ref 153* 579 582 715 716 722 723 724 729 730 731 739 740 754 755 760 761 768 771 773 778 1927 1928* 1940* desc_ext 1 based structure level 2 packed packed unaligned dcl 1-66 set ref 153 154 desc_f based structure array level 2 in structure "desc_nn" packed packed unaligned dcl 1-122 in procedure "cobol_addr" desc_f based structure array level 2 in structure "desc_an" packed packed unaligned dcl 1-103 in procedure "cobol_addr" desc_nn based structure level 1 packed packed unaligned dcl 1-122 desc_nn_ptr 000310 automatic pointer dcl 1-118 set ref 154* 805 807 814 834 837 838 844 845 846 871 885 886 904 905 916 917 919 921 924 931 934 939 943 948 954 960 961 1969 1970* 1986* desc_nn_ptr_save 000612 automatic pointer dcl 1668 set ref 1927* 1940 1969* 1986 desc_no_char 000162 automatic char(3) initial packed unaligned dcl 2690 set ref 696 2690* digit_n 0(18) based bit(3) array level 3 packed packed unaligned dcl 1-122 set ref 834* 837* 838* 846* 871* 885* 886* dimensions 2 based fixed bin(17,0) level 2 dcl 4-26 ref 1743 disp_bit 000157 automatic bit(1) initial packed unaligned dcl 2679 set ref 620* 625 630* 2679* distance 000617 automatic fixed bin(17,0) dcl 1681 set ref 1868 2273* 2274* 2274 2523 2555 divide builtin function dcl 2947 ref 746 876 894 1020 1283 1772 2105 dn_ptr 000100 automatic pointer dcl 2646 set ref 124* 126 128* 282* 285 291 299 305 422* 423 429 431 443 460 468 607* 608 642 664 664 675 675 675 675 675 675 675 675 675 685 721 724 734 736 748 748 768 768 768 773 805 813 817 819 819 821 824 826 826 838 849 850 850 852 856 859 862 862 868 881 898 898 914 919 921 924 928 928 931 939 943 948 953 1002 1109 1144 1224 1332 1733 1733 1738 1738 1762 1805 1885* 1886 1909 1909 1909 1909 1922 1922 1948 1948 2254 2636* dn_ptr_save 000640 automatic pointer dcl 1689 set ref 1805* 2636 dtb_alloc 000736 automatic fixed bin(17,0) dcl 1697 set ref 1813* 1888* 1888 1890 2092 dtb_temp_off 000624 automatic fixed bin(17,0) dcl 1681 set ref 1896* 1994 2024 2102 2252 eppr_op 000170 automatic bit(10) packed unaligned dcl 2708 set ref 257 1275 1330 1334 1346 1471* 1478* 1485* 1492* err 000102 automatic bit(1) packed unaligned dcl 2648 set ref 1855 2426* 2434* 2518 2549 2581* error_message 000103 automatic structure level 1 unaligned dcl 2665 set ref 104 104 360 360 485 485 699 699 1241 1241 1358 1358 1369 1369 1430 1430 1576 1576 1749 1749 2150 2150 fixed builtin function dcl 2947 ref 1570 1570 1623 1623 2006 2272 2494 fixed_common based structure level 1 unaligned dcl 17-26 i 000140 automatic fixed bin(17,0) initial dcl 2672 in procedure "cobol_addr" set ref 215* 277* 369* 387* 389 391* 414* 603 607 634 635 635 662 696 715 716 722 723 724 729 730 731 739 740 754 755 760 761 765 768 771 773 773 778 805 807 814 834 837 838 844 845 846 871 885 886 904 905 912 916 917 917 919 921 924 931 934 939 943 948 954 960 961 1163 1164 1168 1169 1172 1173 1929 1930 1931 1932* 1941* 1942 1971 1978* 1987* 2672* i 000454 automatic fixed bin(35,0) dcl 982 in procedure "offset_adjust" set ref 1004* 1008* 1018 1020 1021 1043 i 001510 automatic fixed bin(17,0) dcl 2171 in procedure "mpy_" set ref 2192* 2194 2196 2196 2199* i parameter fixed bin(17,0) dcl 1086 in procedure "st" ref 1083 1088 i_save 000632 automatic fixed bin(17,0) dcl 1687 set ref 1929* 1941 1971* 1987 ic_mod 7 based fixed bin(17,0) array level 3 dcl 1-32 set ref 634* in_token based structure level 1 dcl 14-9 ind 000261 automatic bit(1) packed unaligned dcl 2741 set ref 2297 2360* 2595* ind_count 000627 automatic fixed bin(17,0) initial dcl 1685 set ref 1685* 1852* 1852 2486 2541* 2541 ind_ptr 000316 automatic pointer dcl 8-16 set ref 2430* 2453 2453 2478 2479 2621 2622 index_array 000752 automatic structure array level 1 unaligned dcl 1722 index_array_flag 000232 automatic fixed bin(17,0) dcl 2724 set ref 159* 161* 2440 index_array_i 000744 automatic fixed bin(17,0) dcl 1716 in procedure "subscripts" set ref 1758* 2450 2450 2620* 2620 2621 2622 2623 index_array_i 000233 automatic fixed bin(17,0) dcl 2724 in procedure "cobol_addr" set ref 158* index_i 000750 automatic fixed bin(17,0) dcl 1716 set ref 2450* 2453 2453 2457* index_name based structure level 1 unaligned dcl 8-19 index_opti_flag 000751 automatic fixed bin(17,0) dcl 1716 set ref 1840* 2456* 2537* 2599 index_reg 6 000752 automatic bit(3) array level 2 packed packed unaligned dcl 1722 set ref 2457 2623* index_save_flag 000745 automatic fixed bin(17,0) dcl 1716 set ref 1839* 2448* 2536* 2618 index_temp 000616 automatic fixed bin(17,0) dcl 1681 set ref 1815* 1868* 1868 2377 2390 2403 2523* 2523 2555* 2555 2627 index_temp_off 000623 automatic fixed bin(17,0) dcl 1681 set ref 1901* 2090 2358 2373 input_ptr parameter pointer dcl 1-18 ref 51 67 96 119 121 121 124 219 227 232 240 250 279 282 356 356 379 383 387 422 496 603 607 634 662 765 912 1224 1768 1768 1930 1931 1942 1976 1977 1988 input_struc based structure level 1 unaligned dcl 1-32 input_struc_basic based structure level 1 unaligned dcl 1-23 inst based structure level 2 packed packed unaligned dcl 1-66 inst_b1 000163 automatic structure level 1 dcl 2700 set ref 110 inst_b1_ptr 000222 automatic pointer dcl 2715 set ref 110* 144* 264* 333* 468* 1131* 1152* 1291* 1293* 1337* 1352* inst_buff 000654 automatic structure level 1 dcl 1695 set ref 1818 inst_buff_ptr 000644 automatic pointer dcl 1689 set ref 1818* 1911* 1917* 2014* 2032* 2128* 2411* inst_ptr parameter pointer dcl 1-18 ref 51 153 154 217 218 225 226 228 234 235 239 243 247 248 283 284 289 290 292 297 298 317 318 340 341 366 367 368 379 383 389 391 393 416 417 418 419 420 465 474 inst_seq 000010 internal static bit(18) initial array packed unaligned dcl 2746 set ref 2038* 2052* 2056 2056 2063* 2070 2070 inst_struc based structure level 1 dcl 1-66 inst_struc_basic based structure level 1 dcl 1-51 inst_wd 000654 automatic bit(36) array level 2 dcl 1695 set ref 1928 1944* 1946* 1952* 1959* 1961* 1970 1993* 1994* 2023* 2024* 2089* 2090* 2092* 2100* 2102* 2113* 2117* 2123* 2123 2124* 2186* 2219* 2220* 2226* 2229* 2300* 2306* 2308* 2311* 2321* 2322* 2327* 2328* 2328 2329* 2334* 2335* 2354* 2358* 2365* 2372* 2373* 2399* 2401* 2403* 2404* 2477* 2483* 2484* 2486* 2605* 2610* 2616* item_count 3 000752 automatic fixed bin(17,0) array level 2 dcl 1722 set ref 1838* 2440 2515* 2515 2535* item_length 16 based fixed bin(24,0) level 2 dcl 2-16 ref 664 768 768 921 1144 item_signed 21(25) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 821 852 928 1909 j 000141 automatic fixed bin(17,0) initial dcl 2672 in procedure "cobol_addr" set ref 133* 436* 1147* 1549* 1555* 2289* 2293* 2370* 2397* 2613* 2672* j 000455 automatic fixed bin(35,0) dcl 982 in procedure "offset_adjust" set ref 1005* 1009* 1014 k 000456 automatic fixed bin(35,0) dcl 982 set ref 1020* 1024* 1038 1040 1058 key 4 based fixed bin(17,0) level 2 dcl 10-14 ref 2573 l 000615 automatic fixed bin(17,0) dcl 1681 in procedure "subscripts" set ref 1766* 1768 1768 1770 1770 1772 1772 1774 1775 1775 1776* 1814* 1836* 1836 1838 1842 1870 2039 2062 2082 2096 2105 2273 2440 2507* 2507 2515 2515 2526* 2526 2528 2535 l 000226 automatic bit(5) level 2 in structure "reloc_b1" dcl 2718 in procedure "cobol_addr" set ref 261* 1350* l 000460 automatic fixed bin(35,0) dcl 982 in procedure "offset_adjust" set ref 1014* 1088 large_array 000252 automatic bit(1) initial packed unaligned dcl 2733 set ref 65* 303* 343 472 609* 681 689 1016 1208 1788* 1790* 1934 1935* 1939* 1973 1975* 1985* 2096 2349 2440 2593 2733* large_array_save 000253 automatic bit(1) packed unaligned dcl 2733 set ref 1934* 1939 1973* 1985 left_wd based bit(5) array level 2 dcl 1-44 set ref 1163* 1168* 1172* length 10 000103 automatic fixed bin(17,0) level 2 dcl 2665 set ref 60* level 3 based structure array level 2 unaligned dcl 4-26 linkage 13 based fixed bin(17,0) level 2 dcl 2-16 ref 1332 linkage_section 21(03) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 748 898 1224 literal 11 based char level 2 packed packed unaligned dcl 12-14 ref 2272 lock 2 based fixed bin(17,0) level 2 in structure "structure" dcl 2783 in procedure "cobol_addr" set ref 1452* lock 2 000276 automatic fixed bin(17,0) level 2 in structure "reg_struc" dcl 2874 in procedure "cobol_addr" set ref 1565* 1595* lock 2 based fixed bin(17,0) level 2 in structure "input_struc" dcl 1-32 in procedure "cobol_addr" ref 67 496 m 000457 automatic fixed bin(35,0) dcl 982 set ref 1040* 1041 1046 max 5 based fixed bin(17,0) array level 3 in structure "occurs" dcl 4-26 in procedure "cobol_addr" set ref 1775 1870 2062 max 000752 automatic fixed bin(17,0) array level 2 in structure "index_array" dcl 1722 in procedure "subscripts" set ref 1775* 1786 message 11 000103 automatic char(80) level 2 packed packed unaligned dcl 2665 set ref 102* 358* 484* 696* 1239* 1356* 1368* 1429* 1575* 1747* 2149* mf1 0(29) based structure level 3 packed packed unaligned dcl 1-66 set ref 389 mf2 0(11) based structure level 3 packed packed unaligned dcl 1-66 set ref 383* 391 mf3 0(02) based structure level 3 packed packed unaligned dcl 1-66 set ref 379* 393 mf_ptr 000160 automatic pointer dcl 2679 set ref 389* 391* 393* 621 623 625 627 636 637 640 642 652 653 655 664 666 671 mf_temp based structure level 1 packed packed unaligned dcl 2679 min 1 000752 automatic fixed bin(17,0) array level 2 dcl 1722 set ref 1776* 2039 mj 001472 automatic fixed bin(17,0) dcl 2162 set ref 2110 2116* 2116 2117 2176* 2199* 2206 2229 mod builtin function dcl 2947 ref 742 830 868 872 888 1021 2082 move_data_init 000050 internal static fixed bin(17,0) initial dcl 1702 set ref 2242 2247* move_eos 000051 internal static structure level 1 unaligned dcl 1708 set ref 2245 move_in_token 000024 internal static pointer array dcl 1700 set ref 2240 move_token_ptr 000742 automatic pointer dcl 1703 set ref 2240* 2244 2245 2246 2254 2255 2258* mpy_bit 000022 internal static bit(1) initial packed unaligned dcl 1676 set ref 1756* 2134 2136* 2210 2212* mseg_no 000143 automatic fixed bin(17,0) initial dcl 2672 set ref 219* 223 232 236 250 258 285* 287 370* 423* 608* 614 614 619 620 625 632 719 729 761 811 844 961 1161 1166 1202 1202 1204 1216 1216 1218 1220 1222 1222 1227 1234 1347 1807 1886* 1944 1961 2479* 2639* 2672* mseg_no_bit based bit(36) packed unaligned dcl 2679 ref 619 620 625 729 761 844 961 mseg_no_save 000633 automatic fixed bin(17,0) dcl 1687 set ref 1807* 2639 n 0(24) based bit(12) array level 3 in structure "desc_an" packed packed unaligned dcl 1-103 in procedure "cobol_addr" set ref 760* 761* 768* 771* 773* 778* n 0(30) based bit(6) array level 3 in structure "desc_nn" packed packed unaligned dcl 1-122 in procedure "cobol_addr" set ref 916* 917* 919* 921* 960* 961* n based fixed bin(17,0) level 2 in structure "in_token" dcl 14-9 in procedure "cobol_addr" set ref 2246* name 000103 automatic char(32) level 2 packed packed unaligned dcl 2665 set ref 59* nlit_ptr 000322 automatic pointer dcl 12-11 set ref 1863* 2271* no_reg_flag 000250 automatic fixed bin(17,0) dcl 2729 set ref 315 343 650 681 689 2346* 2378* 2438* non_elementary 21(08) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 null builtin function dcl 2947 ref 104 104 121 144 144 175 191 279 333 333 360 360 372 425 468 468 485 485 603 699 699 785 964 1049 1049 1054 1054 1061 1061 1066 1066 1076 1076 1131 1131 1152 1152 1241 1241 1291 1291 1293 1293 1337 1337 1358 1358 1369 1369 1430 1430 1576 1576 1749 1749 1809 1819 1842 2056 2056 2057 2057 2070 2070 2071 2071 2150 2150 2244 2250 2445 2505 numeric 21(17) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 685 numeric_edited 21(18) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 numeric_lit based structure level 1 unaligned dcl 12-14 oc 133(31) based bit(1) level 3 packed packed unaligned dcl 17-26 ref 1796 1870 2030 occ_no 000634 automatic fixed bin(17,0) dcl 1687 set ref 1870 1870 2272* 2273 occurs based structure level 1 unaligned dcl 4-26 occurs_limit based char(4) packed unaligned dcl 2746 set ref 2048* occurs_limit_ptr 000266 automatic pointer dcl 2746 set ref 2039* 2048 2062* occurs_ptr 27 based fixed bin(17,0) level 2 in structure "data_name" dcl 2-16 in procedure "cobol_addr" ref 1733 occurs_ptr 000314 automatic pointer dcl 4-24 in procedure "cobol_addr" set ref 1733* 1743 1768 1770 1772 1775 1870 2062 oci 000270 automatic fixed bin(17,0) dcl 2746 set ref 2040* 2054 2057 2061* 2071 offset 24 based fixed bin(24,0) level 2 in structure "data_name" dcl 2-16 in procedure "cobol_addr" ref 291 299 431 443 460 468 721 724 734 813 824 838 849 1948 offset 5 000752 automatic fixed bin(17,0) array level 2 in structure "index_array" dcl 1722 in procedure "subscripts" set ref 2453 2622* offset 14 based fixed bin(24,0) level 2 in structure "index_name" dcl 8-19 in procedure "cobol_addr" ref 2453 2478 2622 offset_cmp 000013 internal static bit(18) initial array packed unaligned dcl 985 set ref 1029* 1030* 1031* 1032* 1033* 1038* 1041* 1048* 1049 1049 1053* 1054 1054 1060* 1061 1061 1065* 1066 1066 1074* 1076 1076 1088* operand 4 based structure array level 2 unaligned dcl 1-32 operand_no 1 based fixed bin(17,0) level 2 dcl 1-32 ref 119 356 356 379 383 387 opr 000260 automatic fixed bin(17,0) dcl 2741 set ref 115* 116* 119* 121 121 124 136* options 133 based structure level 2 packed packed unaligned dcl 17-26 p 000231 automatic fixed bin(17,0) dcl 2723 set ref 519* 577 579 582 1250* 1252 1252 1260* 1262 1262 1299* 1301 1301 1301 1308* 1310 1310 1317* 1319 1319 p_lock 5 based fixed bin(17,0) array level 2 dcl 2956 set ref 1384 1390 1396 1439* 1458* packed_dec_bit 000626 automatic bit(1) initial packed unaligned dcl 1684 set ref 1684* 1762* 1770 1790 2297 2440 2602 places 10 based fixed bin(17,0) level 2 dcl 12-14 ref 2272 places_left 17 based fixed bin(17,0) level 2 dcl 2-16 ref 819 850 places_right 20 based fixed bin(17,0) level 2 dcl 2-16 ref 819 850 953 plus_sw 000652 automatic bit(1) packed unaligned dcl 1691 set ref 1864* 2274 2545* 2573* 2575* pointer_no 1 based bit(3) level 2 packed packed unaligned dcl 2783 ref 1457 pr based bit(3) level 3 in structure "inst_struc_basic" packed packed unaligned dcl 1-51 in procedure "cobol_addr" set ref 247* 340* 474 pr based bit(3) array level 4 in structure "desc_nn" packed packed unaligned dcl 1-122 in procedure "cobol_addr" set ref 844* 904* pr based bit(3) array level 4 in structure "desc_an" packed packed unaligned dcl 1-103 in procedure "cobol_addr" set ref 729* 754* pr_spec 0(29) based bit(1) level 2 in structure "inst_struc_basic" packed packed unaligned dcl 1-51 in procedure "cobol_addr" set ref 226* 243* 290* 298* 418* pr_spec based bit(1) level 2 in structure "mf_temp" packed packed unaligned dcl 2679 in procedure "cobol_addr" set ref 621* 636* 640* ptr_no 000153 automatic bit(3) initial packed unaligned dcl 2677 set ref 247 340 474* 754 904 1124 1124 1127 1128 1234* 1247* 1259* 1297* 1306* 1315* 1331 1366* 1380* 1441* 1457* 2003* 2006 2483 2492* 2494 2677* ptr_status based structure array level 1 dcl 2956 r 1 000226 automatic bit(5) level 2 in structure "reloc_b1" dcl 2718 in procedure "cobol_addr" set ref 260* 1349* r 000602 automatic fixed bin(17,0) dcl 1633 in procedure "release_reg" set ref 1636* 1639 1641 1642 1647 1647* 1647 1649* 1649 1652 r_lock 1 based fixed bin(17,0) array level 2 dcl 2958 set ref 1533 1535* 1598 1601* r_max 000174 automatic fixed bin(17,0) dcl 2711 set ref 1529* 1545 1550* 1556* reg parameter fixed bin(17,0) dcl 1633 in procedure "release_reg" ref 1629 1636 reg parameter fixed bin(17,0) dcl 1592 in procedure "get_a_q" ref 1588 1598 1598 1601 1602 1602 1605 1607 1614 1618 reg parameter fixed bin(17,0) dcl 1525 in procedure "get_reg" ref 1502 1528 1547 1553 reg_bit 000156 automatic bit(1) initial packed unaligned dcl 2679 set ref 619* 623 630* 758 958 2679* reg_mod 0(03) based bit(4) level 2 packed packed unaligned dcl 2679 set ref 625* 627* 637* 642* 652* 653* 655* reg_no 000154 automatic bit(3) initial packed unaligned dcl 2677 set ref 136 142 318 331 464 465 653 778 1029 1030 1031 1074 1150 1536* 1569* 1570 1570 1622* 1623 1623 2292 2308 2335 2372 2404 2457* 2616 2623 2677* reg_num 1 000276 automatic bit(4) level 2 packed packed unaligned dcl 2874 set ref 69* 77* 1569 1605* 1607* 1614* 1622 1652* reg_or_length 0(01) based bit(1) level 2 packed packed unaligned dcl 2679 set ref 623* 664* 666* reg_status based structure array level 1 dcl 2958 reg_struc 000276 automatic structure level 1 unaligned dcl 2874 set ref 64 reg_struc_ptr 000274 automatic pointer dcl 2874 set ref 64* 71* 79* 1567* 1620* 1654* reloc_b1 000226 automatic structure level 1 unaligned dcl 2718 set ref 111 reloc_b1_ptr 000224 automatic pointer dcl 2716 set ref 111* 264* 1352* reloc_buff_ptr 000646 automatic pointer dcl 1689 set ref 1819* 1911* 1917* 2014* 2032* 2128* 2411* reloc_ptr parameter pointer dcl 1-18 set ref 51 175 191 372 425 785 964 1163 1164 1168 1169 1172 1173 1808 1809* 2638* reloc_ptr_save 000650 automatic pointer dcl 1689 set ref 1808* 2638 reloc_struc based structure array level 1 unaligned dcl 1-44 res 000172 automatic bit(1) packed unaligned dcl 2710 set ref 1907* 1956* 2012 2042* 2044 2073* 2496* 2500 2542* reserved_word based structure level 1 unaligned dcl 10-14 retry_tag 000262 automatic fixed bin(17,0) dcl 2746 set ref 1798* 1801* 1870* 2059* right_wd 1 based bit(5) array level 2 dcl 1-44 set ref 1164* 1169* 1173* rw_ptr 000320 automatic pointer dcl 10-11 set ref 2571* 2573 rx 000173 automatic fixed bin(17,0) dcl 2711 set ref 1528* 1533 1533 1535 1536 1537 1537 1543* 1543 1545 1549* 1555* 1560* 1562 1564* 1924* 2019* 2131* 2137* 2213* 2351* rxi 000142 automatic fixed bin(17,0) initial dcl 2672 set ref 74* 77* 90* 91 92* 498* 501* 506* 535 538* 539 539 550 552 561 564 564 566 566 1383* 1389* 1395* 1403* 1409* 1415* 1421* 1439 1440 1441 1451 1458 1459 1469 1476 1483 1490 2672* save_temp_ptr 000746 automatic pointer dcl 1716 set ref 2443* 2445 2445 scal 0(24) based bit(6) array level 3 packed packed unaligned dcl 1-122 set ref 954* seg_num 13 based fixed bin(17,0) level 2 in structure "index_name" dcl 8-19 in procedure "cobol_addr" ref 2453 2479 2621 seg_num 23 based fixed bin(17,0) level 2 in structure "data_name" dcl 2-16 in procedure "cobol_addr" ref 285 423 608 1886 seg_num 4 000752 automatic fixed bin(17,0) array level 2 in structure "index_array" dcl 1722 in procedure "subscripts" set ref 2453 2621* seg_num 3 based fixed bin(17,0) array level 2 in structure "ptr_status" dcl 2956 in procedure "cobol_addr" ref 1252 1262 1301 1301 1310 1319 segno 3 based fixed bin(17,0) level 2 dcl 1-23 ref 219 sign_separate 21(26) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 1909 sign_type 0(22) based bit(2) array level 3 in structure "desc_nn" packed packed unaligned dcl 1-122 in procedure "cobol_addr" set ref 924* 931* 934* 939* 943* 948* sign_type 22(13) based bit(3) level 2 in structure "data_name" packed packed unaligned dcl 2-16 in procedure "cobol_addr" ref 924 939 943 948 signal_ 000062 constant entry external dcl 2664 ref 104 360 485 699 1241 1358 1369 1430 1576 1749 2150 size_sw 10 based fixed bin(17,0) array level 3 dcl 1-32 set ref 121 662 765 912 1930 1931* 1942* 1976 1977* 1988* size_sw_save 000631 automatic fixed bin(17,0) dcl 1687 set ref 1930* 1942 1976* 1988 special_bit 000155 automatic bit(1) initial packed unaligned dcl 2679 set ref 616* 630* 727 758 842 958 2679* stack_off 000620 automatic fixed bin(17,0) dcl 1681 set ref 1895* 1896 1900* 1901 string builtin function dcl 2947 set ref 228* 292* 379* 383* 579 582* 722* 814* struc_l 2 000752 automatic fixed bin(17,0) array level 2 dcl 1722 set ref 1768* 1770* 1772* 1774 1786 2082 2096 2105 2273 struc_length 6 based fixed bin(17,0) array level 3 dcl 4-26 ref 1768 1770 1772 struc_ptr 000272 automatic pointer dcl 2779 set ref 95* 1451 1452 1453 1455* 1457 structure based structure level 1 unaligned dcl 2783 subs_error 000244 automatic fixed bin(17,0) dcl 2727 set ref 309 377* 397 449 647 1742* 2152* subs_no 000614 automatic fixed bin(17,0) dcl 1681 set ref 1743* 1745 1766 1842 2440 2528 subs_offset 4(18) based bit(18) level 2 packed packed unaligned dcl 2652 ref 1738 subs_ptr 000636 automatic pointer dcl 1689 set ref 1738* 1824 1830* 1830 1832 2443 2502* 2502 2503 2578* 2578 2579 subs_segno 4 based bit(18) level 2 packed packed unaligned dcl 2652 ref 1738 subs_token_ptr based pointer dcl 1678 ref 1824 1832 2503 2579 subs_var 000653 automatic fixed bin(17,0) dcl 1692 set ref 1817* 1887* 1887 2344 2378 subscripted 22(05) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 305 429 642 736 748 859 881 898 substr builtin function dcl 2947 set ref 77 142* 227 228 240 248 257* 259* 259 291 292 299 318* 329* 329 331* 341 431 443* 443 444* 460* 460 461* 464* 465* 468 564 564 582 619 620 625 653* 696 721 722 724* 724 729 740* 740 755 761* 761 768 773* 778* 813 814 824 834 838* 838 844 866 871 886* 886 905 917* 919 921 954 960* 961* 961 1029* 1030* 1031* 1032* 1033* 1038 1041 1074* 1088 1104* 1109* 1119* 1119 1122* 1122 1124* 1127* 1127 1128* 1128 1144* 1144 1150* 1234 1275* 1276* 1277* 1287* 1287 1330* 1331* 1333* 1333 1334* 1335* 1346* 1348* 1348 1441 1536 1569 1622 1652 1733 1768 1944* 1946* 1948 1961* 1994* 1994 2024* 2024 2052* 2052 2090* 2090 2092* 2102* 2102 2117* 2117 2124* 2190 2196 2220* 2220 2229* 2229 2308* 2322* 2322 2328* 2328 2329* 2335* 2358* 2358 2372* 2373* 2373 2403* 2403 2404* 2478 2483* 2484* 2484 2486* 2616* switch 3 based fixed bin(17,0) level 2 dcl 2783 set ref 1453* t 000144 automatic fixed bin(17,0) initial dcl 2672 set ref 96* 99 99 156 156 165 2390 2672* ta 0(22) based bit(2) array level 3 packed packed unaligned dcl 1-103 set ref 716* table_ext_off 000256 automatic fixed bin(17,0) dcl 2733 set ref 1114 1114* 1119 1759* 2318 2318* 2322 table_length 000257 automatic fixed bin(35,0) dcl 2733 set ref 1760* 1786* 1790 1790 table_para 000255 automatic fixed bin(35,0) initial dcl 2733 set ref 2733* table_reg 000254 automatic bit(3) packed unaligned dcl 2733 set ref 1032 1033 1104 2292* 2329 td 0(32) based bit(4) level 2 packed packed unaligned dcl 1-51 set ref 225* 235* 239* 289* 297* 317* 318* 420* 465* temp 000151 automatic fixed bin(35,0) initial dcl 2674 set ref 227* 228 236* 240* 248 258* 259 291* 292 299* 322* 322 324 328* 328 329 330* 341 579* 581* 581 582 721* 722 734* 736* 736 740 742 742 742* 742 746* 746 748 755 813* 814 849* 859* 859 861* 861 862* 862 866 872 872 872* 872 876* 876 881* 881 886 888 888 888* 888 894* 894 898 905 1000* 1000 1018 1020 1021* 1021 1043* 1043 1070 1079* 1088 1206 1208 1211 1211 1245* 1245 1257* 1257 1283 1285* 1285 1806 2047 2051* 2052 2082* 2105* 2178 2184 2190 2220 2478* 2484 2637* 2674* temp1 000145 automatic fixed bin(17,0) initial dcl 2672 set ref 516* 519 581 824* 826* 826 830* 830 834 866* 868* 868 871 953* 954 1332* 1333 1347* 1348 2672* temp_24 000152 automatic fixed bin(24,0) dcl 2674 set ref 2047* 2048* 2051 temp_p 000150 automatic fixed bin(17,0) initial dcl 2672 set ref 819* 821* 821 830 850* 852* 852 868 919 2672* temp_ptr 000642 automatic pointer dcl 1689 set ref 1824* 1832* 1842 1850 1861 1863 1879 1885 2271 2272 2430 2432 2503* 2505 2513 2539 2545 2569 2571 2579* 2581 temp_save 000630 automatic fixed bin(17,0) dcl 1686 set ref 1806* 2637 temp_wk_ptr 000740 automatic pointer dcl 1701 set ref 2250* 2252* 2255 text_wd_off_save 000251 automatic fixed bin(17,0) dcl 2730 set ref 151* 516 721 813 tm 0(30) based bit(2) level 2 packed packed unaligned dcl 1-51 set ref 218* 234* 284* 419* tn 0(21) based bit(1) array level 3 packed packed unaligned dcl 1-122 set ref 805* 807* token_ptr 2 based pointer array level 2 in structure "in_token" dcl 14-9 in procedure "cobol_addr" set ref 2244* 2245* 2254* 2255* token_ptr 4 based pointer array level 3 in structure "input_struc" dcl 1-32 in procedure "cobol_addr" ref 121 124 279 282 422 603 607 token_temp based structure level 1 unaligned dcl 1670 type 3 based fixed bin(17,0) level 2 in structure "token_temp" dcl 1670 in procedure "subscripts" ref 1850 1861 1879 2432 2445 2513 2539 2545 2569 2581 type based fixed bin(17,0) level 2 in structure "input_struc" dcl 1-32 in procedure "cobol_addr" ref 96 1224 1768 1768 unspec builtin function dcl 2947 ref 77 227 228 240 248 259 291 292 299 329 341 431 443 460 468 564 564 582 721 722 724 740 755 768 813 814 824 834 838 866 871 886 905 919 921 954 1038 1041 1088 1119 1144 1234 1287 1333 1348 1441 1536 1652 1733 1768 1948 1994 2024 2052 2090 2102 2117 2190 2220 2229 2322 2358 2373 2403 2478 2484 usage_index 21(34) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 675 var_reg 000307 automatic bit(3) array packed unaligned dcl 2940 set ref 116* 136* 773 917 variable_length 22(04) based bit(1) level 2 packed packed unaligned dcl 2-16 ref 126 664 768 773 914 wd 000163 automatic bit(36) level 2 dcl 2700 set ref 141* 142* 253* 257* 259* 326* 329* 331* 441* 443* 444* 458* 460* 461* 464* 1103* 1104* 1143* 1144* 1150* 1270* 1275* 1324* 1330* 1341* 1346* 1348* wd1 1 000163 automatic bit(36) level 2 dcl 2700 set ref 1106* 1109* 1276* 1277* 1287* 1331* 1333* 1334* 1335* wd2 2 000163 automatic bit(36) level 2 dcl 2700 set ref 1118* 1119* 1122 wd3 3 000163 automatic bit(36) level 2 dcl 2700 set ref 1121* 1122* 1124* 1127* 1128* wd_count 000625 automatic fixed bin(17,0) dcl 1683 set ref 1816* 1911* 1913* 1917 1917* 1920* 1928 1944 1946 1951* 1951 1952 1959 1961 1968* 1968 1970 1992* 1992 1993 1994 2014 2014* 2022* 2023 2024 2032* 2034* 2088* 2088 2089 2090 2092 2099* 2099 2100 2102 2112* 2112 2113 2117 2120* 2120 2123 2123 2124 2128* 2130* 2182* 2182 2186 2219 2220 2226 2229 2288* 2288 2300 2303* 2303 2306 2308 2309* 2309 2311 2314* 2314 2321 2322 2326* 2326 2327 2328 2328 2329 2330* 2330 2334 2335 2347* 2347 2354 2358 2365 2372 2373 2393* 2393 2395 2401 2403 2404 2411 2411* 2468* 2468 2473* 2473 2477 2483 2484 2486 2604* 2604 2605 2609* 2609 2610 2616 wd_offset 0(03) based bit(15) level 3 in structure "inst_struc_basic" packed packed unaligned dcl 1-51 in procedure "cobol_addr" set ref 248* 341* 416* wd_offset 4 based fixed bin(24,0) array level 2 in structure "ptr_status" dcl 2956 in procedure "cobol_addr" ref 1252 1262 1301 1310 1319 wd_offset 0(03) based bit(15) array level 4 in structure "desc_nn" packed packed unaligned dcl 1-122 in procedure "cobol_addr" set ref 845* 905* wd_offset 0(03) based bit(15) array level 4 in structure "desc_an" packed packed unaligned dcl 1-103 in procedure "cobol_addr" set ref 730* 755* what_pointer based fixed bin(17,0) level 2 dcl 2783 set ref 1451* what_reg 000276 automatic fixed bin(17,0) level 2 dcl 2874 set ref 1564* 1618* y based structure array level 3 in structure "desc_nn" packed packed unaligned dcl 1-122 in procedure "cobol_addr" set ref 814* y based structure array level 3 in structure "desc_an" packed packed unaligned dcl 1-103 in procedure "cobol_addr" set ref 579 582* 722* y based structure level 2 in structure "inst_struc_basic" packed packed unaligned dcl 1-51 in procedure "cobol_addr" set ref 228* 292* zero1 0(28) based bit(1) level 2 in structure "inst_struc_basic" packed packed unaligned dcl 1-51 in procedure "cobol_addr" set ref 217* 283* 417* zero1 based bit(2) level 3 in structure "inst_struc" packed packed unaligned dcl 1-66 in procedure "cobol_addr" set ref 366* zero1 0(21) based bit(1) array level 3 in structure "desc_an" packed packed unaligned dcl 1-103 in procedure "cobol_addr" set ref 715* zero2 0(02) based bit(1) level 2 packed packed unaligned dcl 2679 set ref 671* zero3 0(09) based bit(2) level 3 packed packed unaligned dcl 1-66 set ref 367* zero5 0(28) based bit(1) level 3 packed packed unaligned dcl 1-66 set ref 368* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. a_lock_save automatic fixed bin(17,0) dcl 1674 allo1_max defined fixed bin(17,0) dcl 5-171 allo1_ptr defined pointer dcl 5-67 alter_flag defined fixed bin(17,0) dcl 5-135 alter_index defined fixed bin(17,0) dcl 5-153 alter_list_ptr defined pointer dcl 5-39 cd_cnt defined fixed bin(17,0) dcl 5-197 cobol_$allo1_max external static fixed bin(17,0) dcl 5-170 cobol_$allo1_ptr external static pointer dcl 5-66 cobol_$alter_flag external static fixed bin(17,0) dcl 5-134 cobol_$alter_index external static fixed bin(17,0) dcl 5-152 cobol_$alter_list_ptr external static pointer dcl 5-38 cobol_$cd_cnt external static fixed bin(17,0) dcl 5-196 cobol_$cobol_data_wd_off external static fixed bin(17,0) dcl 5-118 cobol_$coms_charcnt external static fixed bin(17,0) dcl 5-188 cobol_$coms_wdoff external static fixed bin(17,0) dcl 5-202 cobol_$con_end_ptr external static pointer dcl 5-10 cobol_$con_wd_off external static fixed bin(17,0) dcl 5-92 cobol_$cons_charcnt external static fixed bin(17,0) dcl 5-192 cobol_$constant_offset external static fixed bin(17,0) dcl 5-156 cobol_$data_init_flag external static fixed bin(17,0) dcl 5-130 cobol_$date_compiled_sw external static fixed bin(17,0) dcl 5-180 cobol_$debug_enable external static fixed bin(17,0) dcl 5-174 cobol_$def_base_ptr external static pointer dcl 5-12 cobol_$def_max external static fixed bin(17,0) dcl 5-96 cobol_$def_wd_off external static fixed bin(17,0) dcl 5-94 cobol_$diag_ptr external static pointer dcl 5-70 cobol_$eln_max external static fixed bin(17,0) dcl 5-172 cobol_$eln_ptr external static pointer dcl 5-68 cobol_$fixup_max external static fixed bin(17,0) dcl 5-164 cobol_$fixup_ptr external static pointer dcl 5-30 cobol_$fs_charcnt external static fixed bin(17,0) dcl 5-184 cobol_$fs_wdoff external static fixed bin(17,0) dcl 5-198 cobol_$include_cnt external static fixed bin(17,0) dcl 5-182 cobol_$include_info_ptr external static pointer dcl 5-86 cobol_$init_stack_off external static fixed bin(17,0) dcl 5-124 cobol_$initval_base_ptr external static pointer dcl 5-32 cobol_$initval_file_ptr external static pointer dcl 5-34 cobol_$initval_flag external static fixed bin(17,0) dcl 5-178 cobol_$link_base_ptr external static pointer dcl 5-14 cobol_$link_max external static fixed bin(17,0) dcl 5-100 cobol_$link_wd_off external static fixed bin(17,0) dcl 5-98 cobol_$list_off external static fixed bin(17,0) dcl 5-154 cobol_$list_ptr external static pointer dcl 5-64 cobol_$ls_charcnt external static fixed bin(17,0) dcl 5-190 cobol_$main_pcs_ptr external static pointer dcl 5-84 cobol_$map_data_max external static fixed bin(17,0) dcl 5-162 cobol_$map_data_ptr external static pointer dcl 5-54 cobol_$max_stack_off external static fixed bin(17,0) dcl 5-122 cobol_$minpral5_ptr external static pointer dcl 5-50 cobol_$misc_base_ptr external static pointer dcl 5-60 cobol_$misc_end_ptr external static pointer dcl 5-62 cobol_$misc_max external static fixed bin(17,0) dcl 5-158 cobol_$non_source_offset external static fixed bin(17,0) dcl 5-176 cobol_$ntbuf_ptr external static pointer dcl 5-82 cobol_$obj_seg_name external static char(32) dcl 5-208 cobol_$op_con_ptr external static pointer dcl 5-80 cobol_$para_eop_flag external static fixed bin(17,0) dcl 5-138 cobol_$pd_map_index external static fixed bin(17,0) dcl 5-116 cobol_$pd_map_max external static fixed bin(17,0) dcl 5-160 cobol_$pd_map_ptr external static pointer dcl 5-28 cobol_$pd_map_sw external static fixed bin(17,0) dcl 5-126 cobol_$perform_list_ptr external static pointer dcl 5-36 cobol_$perform_para_index external static fixed bin(17,0) dcl 5-148 cobol_$perform_sect_index external static fixed bin(17,0) dcl 5-150 cobol_$priority_no external static fixed bin(17,0) dcl 5-140 cobol_$ptr_assumption_ind external static fixed bin(17,0) dcl 5-144 cobol_$reg_assumption_ind external static fixed bin(17,0) dcl 5-146 cobol_$reloc_def_base_ptr external static pointer dcl 5-20 cobol_$reloc_def_max external static fixed bin(24,0) dcl 5-108 cobol_$reloc_link_base_ptr external static pointer dcl 5-22 cobol_$reloc_link_max external static fixed bin(24,0) dcl 5-110 cobol_$reloc_sym_base_ptr external static pointer dcl 5-24 cobol_$reloc_sym_max external static fixed bin(24,0) dcl 5-112 cobol_$reloc_text_base_ptr external static pointer dcl 5-18 cobol_$reloc_text_max external static fixed bin(24,0) dcl 5-106 cobol_$reloc_work_base_ptr external static pointer dcl 5-26 cobol_$reloc_work_max external static fixed bin(24,0) dcl 5-114 cobol_$reswd_ptr external static pointer dcl 5-78 cobol_$same_sort_merge_proc external static bit(1) dcl 5-214 cobol_$scratch_dir external static char(168) dcl 5-206 cobol_$sect_eop_flag external static fixed bin(17,0) dcl 5-136 cobol_$seg_init_flag external static fixed bin(17,0) dcl 5-132 cobol_$seg_init_list_ptr external static pointer dcl 5-40 cobol_$stack_off external static fixed bin(17,0) dcl 5-120 cobol_$statement_info_ptr external static pointer dcl 5-76 cobol_$sym_base_ptr external static pointer dcl 5-16 cobol_$sym_max external static fixed bin(17,0) dcl 5-104 cobol_$sym_wd_off external static fixed bin(17,0) dcl 5-102 cobol_$tag_table_max external static fixed bin(17,0) dcl 5-166 cobol_$tag_table_ptr external static pointer dcl 5-52 cobol_$temp_token_area_ptr external static pointer dcl 5-42 cobol_$temp_token_max external static fixed bin(17,0) dcl 5-168 cobol_$temp_token_ptr external static pointer dcl 5-44 cobol_$text_base_ptr external static pointer dcl 5-8 cobol_$token_block1_ptr external static pointer dcl 5-46 cobol_$token_block2_ptr external static pointer dcl 5-48 cobol_$value_cnt external static fixed bin(17,0) dcl 5-194 cobol_$ws_charcnt external static fixed bin(17,0) dcl 5-186 cobol_$ws_wdoff external static fixed bin(17,0) dcl 5-200 cobol_$xref_bypass external static bit(1) dcl 5-212 cobol_$xref_chain_ptr external static pointer dcl 5-74 cobol_$xref_token_ptr external static pointer dcl 5-72 cobol_afp defined pointer dcl 18-11 cobol_analin_fileno defined pointer dcl 18-13 cobol_cmfp defined pointer dcl 18-21 cobol_com_fileno defined pointer dcl 18-23 cobol_curr_in defined pointer dcl 18-53 cobol_curr_out defined pointer dcl 18-55 cobol_data_wd_off defined fixed bin(17,0) dcl 5-119 cobol_dfp defined pointer dcl 18-27 cobol_eltp defined pointer dcl 18-19 cobol_ext_$cobol_afp external static pointer dcl 18-10 cobol_ext_$cobol_analin_fileno external static pointer dcl 18-12 cobol_ext_$cobol_cmfp external static pointer dcl 18-20 cobol_ext_$cobol_com_fileno external static pointer dcl 18-22 cobol_ext_$cobol_curr_in external static pointer dcl 18-52 cobol_ext_$cobol_curr_out external static pointer dcl 18-54 cobol_ext_$cobol_dfp external static pointer dcl 18-26 cobol_ext_$cobol_eltp external static pointer dcl 18-18 cobol_ext_$cobol_fileno1 external static fixed bin(24,0) dcl 18-78 cobol_ext_$cobol_hfp external static pointer dcl 18-28 cobol_ext_$cobol_lpr external static char(5) packed unaligned dcl 18-95 cobol_ext_$cobol_m1fp external static pointer dcl 18-30 cobol_ext_$cobol_m2fp external static pointer dcl 18-32 cobol_ext_$cobol_min1_fileno external static pointer dcl 18-34 cobol_ext_$cobol_min2_fileno_ptr external static pointer dcl 18-36 cobol_ext_$cobol_name_fileno external static pointer dcl 18-38 cobol_ext_$cobol_name_fileno_ptr external static pointer dcl 18-40 cobol_ext_$cobol_ntfp external static pointer dcl 18-42 cobol_ext_$cobol_options external static char(120) packed unaligned dcl 18-97 cobol_ext_$cobol_options_len external static fixed bin(24,0) dcl 18-80 cobol_ext_$cobol_pdofp external static pointer dcl 18-44 cobol_ext_$cobol_pdout_fileno external static fixed bin(24,0) dcl 18-82 cobol_ext_$cobol_pfp external static pointer dcl 18-46 cobol_ext_$cobol_print_fileno external static fixed bin(24,0) dcl 18-84 cobol_ext_$cobol_rm2fp external static pointer dcl 18-48 cobol_ext_$cobol_rmin2_fileno external static fixed bin(24,0) dcl 18-86 cobol_ext_$cobol_rmin2fp external static pointer dcl 18-50 cobol_ext_$cobol_rwdd external static pointer dcl 18-72 cobol_ext_$cobol_rwpd external static pointer dcl 18-74 cobol_ext_$cobol_sfp external static pointer dcl 18-56 cobol_ext_$cobol_w1p external static pointer dcl 18-58 cobol_ext_$cobol_w2p external static pointer dcl 18-60 cobol_ext_$cobol_w3p external static pointer dcl 18-62 cobol_ext_$cobol_w5p external static pointer dcl 18-64 cobol_ext_$cobol_w6p external static pointer dcl 18-66 cobol_ext_$cobol_w7p external static pointer dcl 18-68 cobol_ext_$cobol_x1_fileno external static fixed bin(24,0) dcl 18-88 cobol_ext_$cobol_x2_fileno external static fixed bin(24,0) dcl 18-90 cobol_ext_$cobol_x3_fileno external static fixed bin(24,0) dcl 18-92 cobol_ext_$cobol_x3fp external static pointer dcl 18-70 cobol_ext_$cobol_xlast8 external static bit(1) packed unaligned dcl 18-100 cobol_ext_$report_exists external static bit(1) packed unaligned dcl 18-102 cobol_ext_$report_first_token external static pointer dcl 18-14 cobol_ext_$report_last_token external static pointer dcl 18-16 cobol_fileno1 defined fixed bin(24,0) dcl 18-79 cobol_hfp defined pointer dcl 18-29 cobol_lpr defined char(5) packed unaligned dcl 18-96 cobol_m1fp defined pointer dcl 18-31 cobol_m2fp defined pointer dcl 18-33 cobol_min1_fileno defined pointer dcl 18-35 cobol_min2_fileno_ptr defined pointer dcl 18-37 cobol_name_fileno defined pointer dcl 18-39 cobol_name_fileno_ptr defined pointer dcl 18-41 cobol_ntfp defined pointer dcl 18-43 cobol_options defined char(120) packed unaligned dcl 18-98 cobol_options_len defined fixed bin(24,0) dcl 18-81 cobol_pdofp defined pointer dcl 18-45 cobol_pdout_fileno defined fixed bin(24,0) dcl 18-83 cobol_pfp defined pointer dcl 18-47 cobol_print_fileno defined fixed bin(24,0) dcl 18-85 cobol_rm2fp defined pointer dcl 18-49 cobol_rmin2_fileno defined fixed bin(24,0) dcl 18-87 cobol_rmin2fp defined pointer dcl 18-51 cobol_rwdd defined pointer dcl 18-73 cobol_rwpd defined pointer dcl 18-75 cobol_sfp defined pointer dcl 18-57 cobol_w1p defined pointer dcl 18-59 cobol_w2p defined pointer dcl 18-61 cobol_w3p defined pointer dcl 18-63 cobol_w5p defined pointer dcl 18-65 cobol_w6p defined pointer dcl 18-67 cobol_w7p defined pointer dcl 18-69 cobol_x1_fileno defined fixed bin(24,0) dcl 18-89 cobol_x2_fileno defined fixed bin(24,0) dcl 18-91 cobol_x3_fileno defined fixed bin(24,0) dcl 18-93 cobol_x3fp defined pointer dcl 18-71 cobol_xlast8 defined bit(1) packed unaligned dcl 18-101 compile_count defined fixed bin(17,0) dcl 5-143 coms_charcnt defined fixed bin(17,0) dcl 5-189 coms_wdoff defined fixed bin(17,0) dcl 5-203 con_end_ptr defined pointer dcl 5-11 con_wd_off defined fixed bin(17,0) dcl 5-93 cons_charcnt defined fixed bin(17,0) dcl 5-193 constant_offset defined fixed bin(17,0) dcl 5-157 data_init_flag defined fixed bin(17,0) dcl 5-131 date_compiled_sw defined fixed bin(17,0) dcl 5-181 debug_enable defined fixed bin(17,0) dcl 5-175 def_base_ptr defined pointer dcl 5-13 def_max defined fixed bin(17,0) dcl 5-97 def_wd_off defined fixed bin(17,0) dcl 5-95 diag_ptr defined pointer dcl 5-71 eln_max defined fixed bin(17,0) dcl 5-173 eln_ptr defined pointer dcl 5-69 fixup_max defined fixed bin(17,0) dcl 5-165 fixup_ptr defined pointer dcl 5-31 fs_charcnt defined fixed bin(17,0) dcl 5-185 fs_wdoff defined fixed bin(17,0) dcl 5-199 in_token_ptr automatic pointer dcl 14-7 include_cnt defined fixed bin(17,0) dcl 5-183 include_info_ptr defined pointer dcl 5-87 index builtin function dcl 2947 init_stack_off defined fixed bin(17,0) dcl 5-125 initval_base_ptr defined pointer dcl 5-33 initval_file_ptr defined pointer dcl 5-35 initval_flag defined fixed bin(17,0) dcl 5-179 length builtin function dcl 2947 link_base_ptr defined pointer dcl 5-15 link_max defined fixed bin(17,0) dcl 5-101 link_wd_off defined fixed bin(17,0) dcl 5-99 list_off defined fixed bin(17,0) dcl 5-155 list_ptr defined pointer dcl 5-65 lit_ptr automatic pointer dcl 1689 ls_charcnt defined fixed bin(17,0) dcl 5-191 main_pcs_ptr defined pointer dcl 5-85 map_data_max defined fixed bin(17,0) dcl 5-163 map_data_ptr defined pointer dcl 5-55 max_stack_off defined fixed bin(17,0) dcl 5-123 mf_bit based bit(7) packed unaligned dcl 2679 minpral5_ptr defined pointer dcl 5-51 misc_base_ptr defined pointer dcl 5-61 misc_end_ptr defined pointer dcl 5-63 misc_max defined fixed bin(17,0) dcl 5-159 n automatic fixed bin(17,0) dcl 1681 next_tag defined fixed bin(17,0) dcl 5-129 non_source_offset defined fixed bin(17,0) dcl 5-177 ntbuf_ptr defined pointer dcl 5-83 obj_seg_name defined char(32) dcl 5-209 op_con_ptr defined pointer dcl 5-81 para_eop_flag defined fixed bin(17,0) dcl 5-139 pd_map_index defined fixed bin(17,0) dcl 5-117 pd_map_max defined fixed bin(17,0) dcl 5-161 pd_map_ptr defined pointer dcl 5-29 pd_map_sw defined fixed bin(17,0) dcl 5-127 perform_list_ptr defined pointer dcl 5-37 perform_para_index defined fixed bin(17,0) dcl 5-149 perform_sect_index defined fixed bin(17,0) dcl 5-151 priority_no defined fixed bin(17,0) dcl 5-141 proc_ref based structure level 1 unaligned dcl 15-16 proc_ref_ptr automatic pointer dcl 15-13 ptr_assumption_ind defined fixed bin(17,0) dcl 5-145 ptr_status_ptr defined pointer dcl 5-57 q_lock_save automatic fixed bin(17,0) dcl 1674 reg_assumption_ind defined fixed bin(17,0) dcl 5-147 reg_status_ptr defined pointer dcl 5-59 rel builtin function dcl 2947 reloc_def_base_ptr defined pointer dcl 5-21 reloc_def_max defined fixed bin(24,0) dcl 5-109 reloc_link_base_ptr defined pointer dcl 5-23 reloc_link_max defined fixed bin(24,0) dcl 5-111 reloc_sym_base_ptr defined pointer dcl 5-25 reloc_sym_max defined fixed bin(24,0) dcl 5-113 reloc_text_base_ptr defined pointer dcl 5-19 reloc_text_max defined fixed bin(24,0) dcl 5-107 reloc_work_base_ptr defined pointer dcl 5-27 reloc_work_max defined fixed bin(24,0) dcl 5-115 report_exists defined bit(1) packed unaligned dcl 18-103 report_first_token defined pointer dcl 18-15 report_last_token defined pointer dcl 18-17 reswd_ptr defined pointer dcl 5-79 same_sort_merge_proc defined bit(1) dcl 5-215 scratch_dir defined char(168) dcl 5-207 sect_eop_flag defined fixed bin(17,0) dcl 5-137 seg_init_flag defined fixed bin(17,0) dcl 5-133 seg_init_list_ptr defined pointer dcl 5-41 stack_off defined fixed bin(17,0) dcl 5-121 statement_info_ptr defined pointer dcl 5-77 sym_base_ptr defined pointer dcl 5-17 sym_max defined fixed bin(17,0) dcl 5-105 sym_wd_off defined fixed bin(17,0) dcl 5-103 table_range automatic fixed bin(17,0) dcl 2733 tag_table_max defined fixed bin(17,0) dcl 5-167 tag_table_ptr defined pointer dcl 5-53 temp_token_area_ptr defined pointer dcl 5-43 temp_token_max defined fixed bin(17,0) dcl 5-169 temp_token_ptr defined pointer dcl 5-45 text_base_ptr defined pointer dcl 5-9 text_wd_off defined fixed bin(17,0) dcl 5-91 token_block1_ptr defined pointer dcl 5-47 token_block2_ptr defined pointer dcl 5-49 value_cnt defined fixed bin(17,0) dcl 5-195 ws_charcnt defined fixed bin(17,0) dcl 5-187 ws_wdoff defined fixed bin(17,0) dcl 5-201 xref_bypass defined bit(1) dcl 5-213 xref_chain_ptr defined pointer dcl 5-75 xref_token_ptr defined pointer dcl 5-73 NAMES DECLARED BY EXPLICIT CONTEXT. addr_done 000721 constant label dcl 178 ref 194 203 209 312 art 000007 constant label array(0:10) dcl 1234 set ref 1230 artx 004760 constant label dcl 1360 ref 1237 1243 1255 1265 1295 1304 1313 1322 1339 1354 cobol_addr 000267 constant entry external dcl 51 desc_anp 002354 constant entry internal dcl 706 ref 679 1937 desc_nnp 002625 constant entry internal dcl 794 ref 687 1981 emit 007636 constant entry internal dcl 2385 ref 2381 2460 2509 2531 end_addr 001676 constant entry internal dcl 489 ref 178 end_index_proc 010224 constant entry internal dcl 2588 ref 2459 2508 2530 end_subs_proc 007550 constant entry internal dcl 2341 ref 1844 end_subscription 010305 constant entry internal dcl 2631 ref 2154 2414 error_end_addr 001637 constant entry internal dcl 481 ref 106 311 362 399 451 get_a_q 005437 constant entry internal dcl 1588 ref 1925 2020 2214 2352 get_ar 004141 constant entry internal dcl 1179 ref 245 338 752 902 2481 get_length 004040 constant entry internal dcl 1137 ref 776 get_reg 005263 constant entry internal dcl 1502 ref 134 437 1148 2290 2294 2371 2398 2614 get_temp_ar 005027 constant entry internal dcl 1375 ref 255 1273 1328 1344 indexing 007713 constant entry internal dcl 2418 ref 1854 indx 010172 constant label dcl 2563 ref 2435 2462 2511 2518 2532 2549 indx_1 010173 constant entry internal dcl 2566 ref 2516 2548 md 002025 constant entry internal dcl 573 ref 523 mf 002055 constant entry internal dcl 592 ref 395 move_ 007316 constant entry internal dcl 2235 ref 1914 mpy_ 007213 constant entry internal dcl 2164 ref 2084 2107 mpy_inst 007262 constant label dcl 2206 ref 2196 next_subs_ 006046 constant label dcl 1830 ref 1873 offset_adjust 003341 constant entry internal dcl 973 ref 748 898 ptr_adjust 003717 constant entry internal dcl 1093 ref 343 475 681 689 qls_inst 007306 constant label dcl 2226 ref 2201 release_reg 005522 constant entry internal dcl 1629 ref 538 2132 2138 2362 reloc 004101 constant entry internal dcl 1158 ref 175 191 372 425 785 964 reset 004761 constant entry internal dcl 1363 ref 1252 1262 1301 1310 1319 rp 001760 constant entry internal dcl 546 ref 509 rpr 001772 constant entry internal dcl 557 ref 552 rr 001745 constant entry internal dcl 531 ref 499 502 550 set_adwp 005225 constant entry internal dcl 1465 ref 1443 1461 st 003673 constant entry internal dcl 1083 ref 1027 1036 1044 1072 subs_ 006053 constant label dcl 1836 ref 1826 subs_2 007375 constant entry internal dcl 2266 ref 1866 2521 2553 subs_err 007151 constant entry internal dcl 2146 ref 1751 1855 1881 subscripts 005561 constant entry internal dcl 1660 ref 307 447 646 subx 007150 constant label dcl 2643 ref 1846 1858 1882 table_ext_ 007425 constant entry internal dcl 2281 ref 2361 2596 tl 005144 constant entry internal dcl 1435 ref 1386 1392 1398 tpr 005166 constant entry internal dcl 1447 ref 1406 1412 1418 1424 type 000000 constant label array(7) dcl 172 ref 165 type_1 000737 constant entry internal dcl 211 ref 172 type_2 001105 constant entry internal dcl 273 ref 187 type_4 001303 constant entry internal dcl 350 ref 198 type_7 001460 constant entry internal dcl 408 ref 206 NAME DECLARED BY CONTEXT OR IMPLICATION. baseptr builtin function ref 1738 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 10724 11056 10434 10734 Length 11722 10434 132 630 267 50 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_addr 1467 external procedure is an external procedure. type_1 internal procedure shares stack frame of external procedure cobol_addr. type_2 internal procedure shares stack frame of external procedure cobol_addr. type_4 internal procedure shares stack frame of external procedure cobol_addr. type_7 internal procedure shares stack frame of external procedure cobol_addr. error_end_addr internal procedure shares stack frame of external procedure cobol_addr. end_addr internal procedure shares stack frame of external procedure cobol_addr. rr internal procedure shares stack frame of external procedure cobol_addr. rp internal procedure shares stack frame of external procedure cobol_addr. rpr internal procedure shares stack frame of external procedure cobol_addr. md internal procedure shares stack frame of external procedure cobol_addr. mf internal procedure shares stack frame of external procedure cobol_addr. desc_anp internal procedure shares stack frame of external procedure cobol_addr. desc_nnp internal procedure shares stack frame of external procedure cobol_addr. offset_adjust internal procedure shares stack frame of external procedure cobol_addr. st internal procedure shares stack frame of external procedure cobol_addr. ptr_adjust internal procedure shares stack frame of external procedure cobol_addr. get_length internal procedure shares stack frame of external procedure cobol_addr. reloc internal procedure shares stack frame of external procedure cobol_addr. get_ar internal procedure shares stack frame of external procedure cobol_addr. reset internal procedure shares stack frame of external procedure cobol_addr. get_temp_ar internal procedure shares stack frame of external procedure cobol_addr. tl internal procedure shares stack frame of external procedure cobol_addr. tpr internal procedure shares stack frame of external procedure cobol_addr. set_adwp internal procedure shares stack frame of external procedure cobol_addr. get_reg internal procedure shares stack frame of external procedure cobol_addr. get_a_q internal procedure shares stack frame of external procedure cobol_addr. release_reg internal procedure shares stack frame of external procedure cobol_addr. subscripts internal procedure shares stack frame of external procedure cobol_addr. subs_err internal procedure shares stack frame of external procedure cobol_addr. mpy_ internal procedure shares stack frame of external procedure cobol_addr. move_ internal procedure shares stack frame of external procedure cobol_addr. subs_2 internal procedure shares stack frame of external procedure cobol_addr. table_ext_ internal procedure shares stack frame of external procedure cobol_addr. end_subs_proc internal procedure shares stack frame of external procedure cobol_addr. emit internal procedure shares stack frame of external procedure cobol_addr. indexing internal procedure shares stack frame of external procedure cobol_addr. indx_1 internal procedure shares stack frame of external procedure cobol_addr. end_index_proc internal procedure shares stack frame of external procedure cobol_addr. end_subscription internal procedure shares stack frame of external procedure cobol_addr. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 inst_seq cobol_addr 000013 offset_cmp offset_adjust 000022 mpy_bit subscripts 000024 move_in_token subscripts 000050 move_data_init subscripts 000051 move_eos subscripts STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_addr 000100 dn_ptr cobol_addr 000102 err cobol_addr 000103 error_message cobol_addr 000140 i cobol_addr 000141 j cobol_addr 000142 rxi cobol_addr 000143 mseg_no cobol_addr 000144 t cobol_addr 000145 temp1 cobol_addr 000146 dec_bin_temp cobol_addr 000147 aj_off cobol_addr 000150 temp_p cobol_addr 000151 temp cobol_addr 000152 temp_24 cobol_addr 000153 ptr_no cobol_addr 000154 reg_no cobol_addr 000155 special_bit cobol_addr 000156 reg_bit cobol_addr 000157 disp_bit cobol_addr 000160 mf_ptr cobol_addr 000162 desc_no_char cobol_addr 000163 inst_b1 cobol_addr 000170 eppr_op cobol_addr 000171 adwp_op cobol_addr 000172 res cobol_addr 000173 rx cobol_addr 000174 r_max cobol_addr 000175 adwp_du cobol_addr 000176 addr_reg cobol_addr 000210 addr_ptr cobol_addr 000222 inst_b1_ptr cobol_addr 000224 reloc_b1_ptr cobol_addr 000226 reloc_b1 cobol_addr 000230 b1_count cobol_addr 000231 p cobol_addr 000232 index_array_flag cobol_addr 000233 index_array_i cobol_addr 000234 ar_buff cobol_addr 000244 subs_error cobol_addr 000245 aj_const_off cobol_addr 000250 no_reg_flag cobol_addr 000251 text_wd_off_save cobol_addr 000252 large_array cobol_addr 000253 large_array_save cobol_addr 000254 table_reg cobol_addr 000255 table_para cobol_addr 000256 table_ext_off cobol_addr 000257 table_length cobol_addr 000260 opr cobol_addr 000261 ind cobol_addr 000262 retry_tag cobol_addr 000264 check_tag cobol_addr 000266 occurs_limit_ptr cobol_addr 000270 oci cobol_addr 000272 struc_ptr cobol_addr 000274 reg_struc_ptr cobol_addr 000276 reg_struc cobol_addr 000307 var_reg cobol_addr 000310 desc_nn_ptr cobol_addr 000312 desc_an_ptr cobol_addr 000314 occurs_ptr cobol_addr 000316 ind_ptr cobol_addr 000320 rw_ptr cobol_addr 000322 nlit_ptr cobol_addr 000454 i offset_adjust 000455 j offset_adjust 000456 k offset_adjust 000457 m offset_adjust 000460 l offset_adjust 000520 ar_type get_ar 000602 r release_reg 000603 ar release_reg 000612 desc_nn_ptr_save subscripts 000614 subs_no subscripts 000615 l subscripts 000616 index_temp subscripts 000617 distance subscripts 000620 stack_off subscripts 000621 al_char subscripts 000622 al_bd subscripts 000623 index_temp_off subscripts 000624 dtb_temp_off subscripts 000625 wd_count subscripts 000626 packed_dec_bit subscripts 000627 ind_count subscripts 000630 temp_save subscripts 000631 size_sw_save subscripts 000632 i_save subscripts 000633 mseg_no_save subscripts 000634 occ_no subscripts 000636 subs_ptr subscripts 000640 dn_ptr_save subscripts 000642 temp_ptr subscripts 000644 inst_buff_ptr subscripts 000646 reloc_buff_ptr subscripts 000650 reloc_ptr_save subscripts 000652 plus_sw subscripts 000653 subs_var subscripts 000654 inst_buff subscripts 000736 dtb_alloc subscripts 000740 temp_wk_ptr subscripts 000742 move_token_ptr subscripts 000744 index_array_i subscripts 000745 index_save_flag subscripts 000746 save_temp_ptr subscripts 000750 index_i subscripts 000751 index_opti_flag subscripts 000752 index_array subscripts 001472 mj subscripts 001510 i mpy_ 001511 bit_temp mpy_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp cat_realloc_chars call_ext_out_desc call_ext_out return_mac mpfx2 mdfx1 shorten_stack ext_entry any_to_any_truncate_ THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_alloc$stack cobol_define_tag_nc cobol_emit cobol_gen_error$reg_reset cobol_get_size cobol_make_tagref cobol_make_type9$long_bin cobol_move_gen cobol_pointer_register$get cobol_pointer_register$priority cobol_pool cobol_register$load cobol_register$release cobol_reset_r$pointer_register signal_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. cobol_$compile_count cobol_$next_tag cobol_$ptr_status_ptr cobol_$reg_status_ptr cobol_$text_wd_off cobol_ext_$cobol_com_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 51 000263 2672 000274 2674 000305 2677 000306 2679 000310 2690 000313 2733 000315 59 000320 60 000323 64 000325 65 000327 67 000330 69 000336 71 000340 74 000346 77 000353 79 000356 81 000365 83 000367 84 000407 85 000427 90 000447 91 000453 92 000454 93 000455 95 000457 96 000461 99 000465 102 000470 104 000473 106 000525 107 000526 110 000527 111 000531 115 000533 116 000541 117 000545 119 000547 121 000561 124 000575 126 000577 128 000602 133 000617 134 000621 136 000624 141 000631 142 000633 144 000640 148 000657 150 000661 151 000664 153 000667 154 000674 156 000676 158 000703 159 000704 160 000706 161 000707 165 000710 172 000712 175 000713 178 000721 183 000722 187 000723 191 000724 194 000732 198 000733 203 000734 206 000735 209 000736 211 000737 215 000740 217 000741 218 000745 219 000747 223 000753 225 000755 226 000761 227 000763 228 000771 229 000775 232 000776 234 001002 235 001006 236 001010 237 001012 239 001013 240 001015 243 001021 245 001023 247 001024 248 001032 250 001037 253 001045 255 001047 257 001050 258 001055 259 001057 260 001064 261 001066 262 001067 264 001071 271 001104 273 001105 277 001106 279 001107 282 001117 283 001121 284 001124 285 001126 287 001130 289 001132 290 001136 291 001140 292 001146 293 001152 297 001153 298 001155 299 001157 303 001163 305 001164 307 001167 309 001170 311 001173 312 001174 315 001175 317 001177 318 001205 322 001212 324 001220 326 001221 328 001223 329 001230 330 001233 331 001235 333 001242 338 001261 340 001262 341 001270 343 001275 347 001302 350 001303 356 001304 358 001313 360 001316 362 001350 363 001351 366 001352 367 001355 368 001357 369 001361 370 001362 372 001364 377 001371 379 001372 383 001403 387 001410 389 001417 391 001430 393 001441 395 001447 397 001450 399 001453 400 001454 403 001455 405 001457 408 001460 414 001461 416 001463 417 001467 418 001471 419 001473 420 001475 422 001501 423 001505 425 001507 429 001514 431 001520 436 001524 437 001525 441 001530 443 001532 444 001540 445 001544 447 001545 449 001546 451 001551 452 001552 458 001553 460 001555 461 001563 464 001567 465 001574 468 001603 472 001625 474 001627 475 001635 478 001636 481 001637 484 001640 485 001643 487 001675 489 001676 496 001677 498 001705 499 001707 501 001712 502 001714 506 001717 509 001723 510 001724 516 001726 519 001732 523 001741 526 001742 529 001744 531 001745 535 001746 538 001751 539 001753 542 001756 544 001757 546 001760 550 001761 552 001765 555 001771 557 001772 561 001773 564 001777 566 002020 569 002023 571 002024 573 002025 577 002026 579 002031 581 002041 582 002047 586 002054 592 002055 603 002056 607 002071 608 002074 609 002076 614 002077 616 002103 619 002105 620 002111 621 002115 623 002121 625 002124 627 002132 628 002135 630 002136 632 002141 634 002143 635 002147 636 002151 637 002155 638 002160 640 002161 642 002165 646 002174 647 002175 650 002201 652 002203 653 002207 654 002212 655 002213 662 002217 664 002226 666 002242 671 002246 675 002252 679 002256 681 002257 684 002264 685 002265 687 002270 689 002271 692 002276 696 002277 699 002320 702 002353 706 002354 715 002355 716 002363 719 002366 721 002372 722 002400 723 002405 724 002411 725 002414 727 002415 729 002417 730 002424 731 002430 732 002433 734 002434 736 002437 739 002450 740 002454 742 002457 746 002472 748 002475 752 002506 754 002507 755 002515 758 002523 760 002527 761 002535 762 002540 765 002541 768 002550 771 002566 773 002574 776 002607 778 002610 785 002616 790 002624 794 002625 805 002626 807 002641 811 002647 813 002652 814 002657 817 002664 819 002667 821 002672 824 002676 826 002705 829 002716 830 002717 834 002723 835 002730 837 002731 838 002736 840 002741 842 002742 844 002744 845 002751 846 002756 847 002761 849 002762 850 002764 852 002767 856 002773 859 002776 861 003010 862 003013 866 003031 868 003034 871 003042 872 003047 876 003062 878 003065 881 003066 885 003077 886 003104 888 003107 894 003122 898 003125 902 003136 904 003137 905 003145 912 003153 914 003162 916 003166 917 003173 918 003201 919 003202 921 003213 924 003220 928 003230 931 003234 934 003245 939 003252 943 003264 948 003276 953 003310 954 003312 958 003317 960 003323 961 003330 964 003333 969 003340 973 003341 1000 003342 1002 003347 1004 003353 1005 003355 1006 003357 1008 003360 1009 003362 1014 003364 1016 003372 1018 003374 1020 003406 1021 003412 1022 003416 1024 003417 1027 003420 1029 003424 1030 003432 1031 003437 1032 003444 1033 003451 1036 003456 1038 003462 1040 003466 1041 003474 1043 003477 1044 003505 1046 003511 1048 003513 1049 003516 1051 003536 1053 003537 1054 003542 1058 003562 1060 003564 1061 003567 1063 003607 1065 003610 1066 003613 1069 003633 1070 003634 1072 003636 1074 003642 1076 003650 1079 003670 1081 003672 1083 003673 1088 003675 1089 003716 1093 003717 1103 003720 1104 003722 1106 003727 1109 003731 1114 003737 1118 003760 1119 003762 1121 003767 1122 003771 1124 003775 1127 004006 1128 004013 1131 004020 1133 004037 1137 004040 1143 004041 1144 004043 1147 004047 1148 004051 1150 004054 1152 004061 1154 004100 1158 004101 1161 004102 1163 004105 1164 004113 1165 004115 1166 004116 1168 004120 1169 004126 1170 004130 1172 004131 1173 004136 1175 004140 1179 004141 1200 004142 1202 004143 1204 004153 1206 004155 1208 004163 1211 004172 1213 004200 1214 004203 1215 004205 1216 004206 1218 004215 1220 004222 1222 004227 1224 004233 1226 004246 1227 004247 1230 004253 1234 004255 1237 004262 1239 004263 1241 004266 1243 004320 1245 004321 1247 004327 1250 004333 1252 004335 1255 004352 1257 004353 1259 004361 1260 004365 1262 004367 1265 004404 1270 004405 1273 004407 1275 004410 1276 004415 1277 004422 1283 004426 1285 004433 1286 004441 1287 004447 1291 004452 1293 004474 1295 004513 1297 004514 1299 004516 1301 004517 1304 004536 1306 004537 1308 004543 1310 004545 1313 004561 1315 004562 1317 004566 1319 004570 1322 004604 1324 004605 1328 004607 1330 004610 1331 004615 1332 004621 1333 004625 1334 004632 1335 004637 1337 004643 1339 004662 1341 004663 1344 004665 1346 004666 1347 004673 1348 004675 1349 004702 1350 004704 1352 004705 1354 004722 1356 004723 1358 004726 1360 004760 1363 004761 1366 004762 1368 004771 1369 004774 1371 005026 1375 005027 1380 005030 1383 005032 1384 005034 1386 005041 1387 005042 1389 005043 1390 005045 1392 005047 1393 005050 1395 005051 1396 005053 1398 005055 1399 005056 1403 005057 1404 005061 1406 005063 1407 005064 1409 005065 1410 005067 1412 005071 1413 005072 1415 005073 1416 005075 1418 005077 1419 005100 1421 005101 1422 005103 1424 005105 1425 005106 1429 005107 1430 005112 1432 005143 1435 005144 1439 005145 1440 005155 1441 005157 1443 005164 1445 005165 1447 005166 1451 005167 1452 005171 1453 005174 1455 005175 1457 005204 1458 005211 1459 005221 1461 005223 1463 005224 1465 005225 1469 005226 1471 005231 1472 005233 1473 005235 1476 005236 1478 005240 1479 005242 1480 005244 1483 005245 1485 005247 1486 005251 1487 005253 1490 005254 1492 005256 1493 005260 1496 005262 1502 005263 1528 005265 1529 005267 1531 005271 1533 005272 1535 005305 1536 005310 1537 005313 1539 005314 1543 005315 1545 005316 1547 005322 1549 005326 1550 005331 1551 005333 1553 005334 1555 005336 1556 005341 1557 005342 1560 005343 1562 005351 1564 005353 1565 005356 1567 005360 1569 005367 1570 005373 1571 005375 1573 005376 1575 005400 1576 005403 1582 005435 1584 005436 1588 005437 1595 005441 1598 005443 1601 005455 1602 005460 1605 005462 1607 005470 1609 005474 1614 005475 1618 005502 1620 005504 1622 005513 1623 005517 1625 005521 1629 005522 1636 005524 1639 005526 1641 005530 1642 005532 1647 005536 1649 005544 1652 005546 1654 005551 1656 005560 1660 005561 1684 005562 1685 005563 1733 005564 1738 005573 1742 005610 1743 005611 1745 005613 1747 005616 1749 005621 1751 005653 1752 005654 1756 005655 1757 005657 1758 005660 1759 005661 1760 005662 1762 005664 1766 005671 1768 005701 1770 005721 1772 005733 1774 005743 1775 005750 1776 005755 1781 005757 1786 005761 1788 005764 1790 005765 1796 005775 1798 006003 1799 006005 1801 006006 1805 006016 1806 006020 1807 006022 1808 006024 1809 006030 1813 006032 1814 006033 1815 006034 1816 006035 1817 006036 1818 006037 1819 006041 1824 006042 1826 006045 1830 006046 1832 006051 1836 006053 1838 006054 1839 006061 1840 006062 1842 006063 1844 006072 1846 006073 1850 006074 1852 006100 1854 006101 1855 006102 1858 006105 1861 006106 1863 006110 1864 006111 1866 006113 1868 006114 1870 006116 1873 006150 1879 006151 1881 006153 1882 006154 1885 006155 1886 006156 1887 006161 1888 006162 1890 006163 1892 006166 1893 006170 1895 006172 1896 006205 1900 006207 1901 006222 1907 006224 1909 006226 1911 006235 1913 006250 1914 006251 1915 006252 1917 006253 1920 006270 1922 006272 1924 006276 1925 006300 1927 006303 1928 006305 1929 006310 1930 006312 1931 006321 1932 006322 1934 006324 1935 006326 1937 006327 1939 006330 1940 006332 1941 006334 1942 006336 1944 006345 1946 006355 1948 006361 1951 006370 1952 006371 1956 006374 1957 006375 1959 006376 1961 006400 1968 006410 1969 006411 1970 006413 1971 006416 1973 006420 1975 006422 1976 006423 1977 006430 1978 006431 1981 006433 1985 006434 1986 006436 1987 006440 1988 006442 1992 006447 1993 006450 1994 006453 2003 006460 2006 006476 2012 006501 2014 006503 2019 006520 2020 006522 2022 006525 2023 006527 2024 006531 2030 006536 2032 006544 2034 006556 2035 006557 2036 006562 2037 006565 2038 006567 2039 006571 2040 006575 2042 006577 2044 006601 2047 006604 2048 006606 2051 006631 2052 006635 2054 006640 2056 006643 2057 006663 2058 006704 2059 006715 2061 006730 2062 006732 2063 006737 2066 006742 2068 006752 2070 006753 2071 006773 2073 007014 2076 007015 2082 007016 2084 007024 2088 007025 2089 007026 2090 007031 2092 007036 2096 007044 2099 007054 2100 007055 2102 007060 2105 007065 2107 007067 2110 007070 2112 007072 2113 007073 2114 007076 2116 007077 2117 007101 2120 007106 2123 007107 2124 007112 2128 007115 2130 007130 2131 007131 2132 007133 2134 007136 2136 007141 2137 007142 2138 007144 2142 007147 2643 007150 2146 007151 2149 007152 2150 007155 2152 007207 2154 007211 2156 007212 2164 007213 2176 007214 2178 007215 2182 007221 2184 007222 2186 007224 2187 007227 2190 007230 2192 007233 2194 007241 2196 007245 2199 007254 2201 007257 2204 007260 2206 007262 2210 007264 2212 007267 2213 007271 2214 007273 2219 007276 2220 007301 2222 007305 2226 007306 2229 007311 2231 007315 2235 007316 2240 007317 2242 007322 2244 007325 2245 007327 2246 007332 2247 007334 2250 007336 2252 007340 2254 007357 2255 007362 2258 007365 2260 007374 2266 007375 2271 007376 2272 007400 2273 007413 2274 007420 2277 007424 2281 007425 2288 007426 2289 007427 2290 007431 2292 007434 2293 007436 2294 007440 2297 007443 2300 007447 2303 007452 2306 007453 2308 007456 2309 007463 2311 007464 2314 007467 2318 007470 2321 007511 2322 007514 2326 007521 2327 007522 2328 007525 2329 007531 2330 007536 2334 007537 2335 007542 2337 007547 2341 007550 2344 007551 2346 007553 2347 007554 2349 007555 2351 007557 2352 007561 2354 007564 2358 007567 2360 007574 2361 007575 2362 007576 2363 007602 2365 007603 2370 007606 2371 007610 2372 007613 2373 007621 2377 007626 2378 007630 2381 007634 2383 007635 2385 007636 2390 007637 2393 007644 2395 007645 2397 007650 2398 007652 2399 007655 2400 007657 2401 007660 2403 007662 2404 007667 2411 007674 2414 007711 2416 007712 2418 007713 2426 007714 2428 007715 2430 007716 2432 007720 2434 007723 2435 007725 2438 007726 2440 007727 2443 007745 2445 007750 2448 007757 2450 007761 2453 007771 2456 010003 2457 010005 2459 010010 2460 010011 2462 010012 2466 010013 2468 010015 2471 010016 2473 010017 2477 010020 2478 010023 2479 010027 2481 010031 2483 010032 2484 010037 2486 010044 2492 010052 2494 010070 2496 010073 2500 010075 2502 010100 2503 010103 2505 010105 2507 010111 2508 010112 2509 010113 2511 010114 2513 010115 2515 010120 2516 010123 2518 010124 2521 010126 2523 010127 2524 010131 2526 010132 2528 010133 2530 010136 2531 010137 2532 010140 2535 010141 2536 010145 2537 010146 2539 010147 2541 010152 2542 010153 2543 010154 2545 010155 2548 010162 2549 010163 2553 010165 2555 010166 2558 010170 2562 010171 2563 010172 2566 010173 2569 010174 2571 010200 2573 010201 2575 010210 2578 010211 2579 010214 2581 010216 2584 010223 2588 010224 2593 010225 2595 010227 2596 010231 2597 010232 2599 010233 2602 010235 2604 010237 2605 010240 2609 010243 2610 010244 2613 010247 2614 010251 2616 010254 2618 010262 2620 010265 2621 010266 2622 010274 2623 010276 2627 010302 2629 010304 2631 010305 2636 010306 2637 010310 2638 010312 2639 010315 2641 010317 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved