COMPILATION LISTING OF SEGMENT cobol_rts_ Compiled by: Multics PL/I Compiler, Release 33b, of October 17, 1990 Compiled at: ACTC Technologies Inc. Compiled on: 10/19/90 1655.1 mdt Fri Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 15 /****^ HISTORY COMMENTS: 16* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090), 17* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 18* MCR8090 cobol_rts_.pl1 Disallow duplicate prime keys in Indexed Sequential 19* files. 20* 2) change(90-10-03,Zimmerman), approve(90-10-03,MCR8218), 21* audit(90-10-10,Gray), install(90-10-19,MR12.4-1048): 22* Add check for pre-MR12.3 object segs to prevent attempts to access fields 23* that do not exist. 24* END HISTORY COMMENTS */ 25 26 27 /* Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), error checking fails for ark */ 28 /* Modified on 07/17/82 by FCH, [5.1-1], REWRITE after ACCESS DYNAMIC can cause runtime abort, BUG532(phx13391) */ 29 /* Modified on 09/18/81 by FCH, [5.0-1], WRITE with alt keys can abort in rts, BUG 506 */ 30 /* Modified on 06/11/81 by FCH, [4.4-2], RTS(62) added for STOP RUN with CD INITIAL */ 31 /* Modified on 02/19/81 by FCH, [4.4-1], REWRITE invalid detection not correct, RTS(61) added, BUG464 */ 32 /* Modified on 12/13/79 by PRP, [4.1-1], day of year fixed for leap year */ 33 /* Modified on 09/14/79 by FCH, [4.0-4], iox_$attach_ptr replaces iox_$attach_iocb */ 34 /* Modified on 09/06/79 by FCH, [4.0-3], rewrite with alt rec keys */ 35 /* Modified on 08/24/79 by PRP, [4.0-2], rts(60) added for alternate key start control */ 36 /* Modified on 08/13/79 by FCH, [4.0-1], icode value changed in start statement */ 37 /* Modified since Version 4.0 */ 38 39 40 41 42 /* This is the cobol run time interface procedure. 43* It is called by the cobol_operators_ with the parameters are set in the stack frame 44* starting from the 68th word. 45* From the 68th word up through the 107th word are reserved for this interfacinguse. 46* From the 108th word up through the 137th word are reserved for the condition 47* handling use. 48* The 68th word up through the 73th word are used to set the parameter rts_stack_ptr. 49* The rts_code is the 88th words of the stack frame, it is used to decide the run time 50* procedure that cobol_rts_ is going to call. 51*Register Usage 52* 53* $pr0 cobol_operators_ 54* $pr1 fsb pointer 55* $pr2 temporary 56* $pr3 cobol_data_area 57* $pr4 cobol_linkage_area 58* $pr5 cobol_data_area(extension) 59* $pr6 stack_prame pointer 60* $pr7 temporary 61* 62* Run Time Stack Frame 63* 64* 0 0 65* 1 1 66* 2 2 67* 3 3 68* 4 4 69* 5 5 70* 6 6 71* 7 7 72* 8 10 73* 9 11 74* 10 12 75* 11 13 76* 12 14 77* 13 15 78* 14 16 79* 15 17 80* 16 20 S.prev_sp, S.condition_word, S.flag_word 81* 17 21 82* 18 22 S.next_sp, S.signaller_word 83* 19 23 84* 20 24 S.return_ptr 85* 21 25 86* 22 26 S.entry_ptr 87* 23 27 88* 24 30 S.operator_ptr, S.lp_ptr 89* 25 31 90* 26 32 S.arg_ptr 91* 27 33 92* 28 34 S.static_ptr 93* 29 35 S.support_ptr 94* 30 36 S.on_unit_relptrs, on_unit_ptr 95* 31 37 S.operator_ret_ptr, S.translator_id, op_return_offset 96* 32 40 S.regs, display_ptr 97* 33 41 98* 34 42 descriptor_ptr 99* 35 43 100* 36 44 linkage_ptr 101* 37 45 102* 38 46 text_base_ptr 103* 39 47 text_base_off 104* 40 50 mcode 105* 41 51 icode 106* 42 52 status12 107* 43 53 status3 108* 44 54 retrycode, cobol_open_mode 109* 45 55 110* 46 56 multics_open_mode 111* 47 57 112* 48 60 S.min_length 113* 49 61 114* 50 62 115* 51 63 116* 52 64 117* 53 65 118* 54 66 119* 55 67 120* 56 70 121* 57 71 122* 58 72 123* 59 73 124* 60 74 125* 61 75 126* 62 76 127* 63 77 128* 64 100 return_to_main_ptr 129* 65 101 return_to_main_off 130* 66 102 rts_code_ptr 131* 67 103 132* 68 104 133* 69 105 134* 70 106 135* 71 107 136* 72 110 rts_code args to cobol_rts 137* 73 111 use_code 138* 74 112 iocb_ptr 139* 75 113 140* 76 114 mcode_ptr 141* 77 115 142* 78 116 buff_ptr 143* 79 117 144* 80 120 buff_len 145* 81 121 actual_ptr 146* 82 122 stack_buff_ptr, cobol_open_mode 147* 83 123 cobol_options 148* 84 124 vfile_open_mode 149* 85 125 key of ref 150* 86 126 fsb_ptr iox_, arg-1 args for iox_calls 151* 87 127 152* 88 130 file_desc_ptr iox_, arg-2 153* 89 131 cobol_error_code 154* 90 132 iox_, arg-3 155* 91 133 156* 92 134 iox_, arg-4 157* 93 135 158* 94 136 159* 95 137 160* 96 140 161* 97 141 162* 98 142 163* 99 143 164*100 144 x6_save 165*101 145 166*102 145 167*103 147 168*104 150 169*105 151 170*106 152 subr_return_save 171*107 153 subr_return_save_off 172*108 154 pr4_save 173*109 155 174*110 156 pr3_save 175*111 157 176*112 160 pr5_save 177*113 161 178*114 162 rts_save 179*115 163 180*116 164 ind_mask 181*117 165 182* ENTRY OPTIONS 183* 184*FUNCTION NAME COBOL OPERATORS 185* 186*(1) cobol_error_ 187*(2) cobol_control_ 188*(3) sort_initiate 189*(4) sort_release 190*(5) sort_return 191*(6) sort_terminate 192*(7) sort_commence 193*(8) stop_literal 194*(9) stop_run 195*(10) cancel 196*(11) iox_$control 23 197*(129 check_close_error 27,29,36,38 198*(13) check_open_error 199*(14) iox_$find_iocb 200*(15) iox_$attach_iocb 29,35,36 201*(16) check_seek_errors 41,54,67 202*(17) iox_$read_key 55 203*(18) accept 204*(19) 205*(20) accept_id 206*(21) accept_id 207*(22) accept_id 208*(23) inspect 209*(24) inspect 210*(25) seek_for_delete 57,58 211*(26) read_key_status_code 69 212*(27) check_read_record 65,66 213*(28) check_get_line 64 214*(29) 215*(30) merge_init 216*(31) merge_comp 217*(32) merge_return 218*(33) 219*(34) 220*(35) 221*(36) 222*(37) 223*(38) 224*(39) 225*(40) receive_comm 226*(41) accept_comm 227*(42) purge_comm 228*(43) send_comm 229*(44) enable_comm 230*(45) disable_comm 231*(46) alt_file_open 232*(47) alt_read_record 233* 234* Status_Key_1 (Status_Key_2) 235* 236*org = seq 237* 0(0)1(0)3(0,4)9 238*org = rel 239* 0(0)1(0)2(2,3,4)3(0)9 240*org=ind 241* 0(0,2)1(0)2(1,2,3,4)3(0)9 242* 243*Status_Key_1 = 0 success 244* 1 at end 245* 2 invalid 246* 3 permanent error 247* 9 implementor defined 248* 249*Status_Key_2 = 0 no more information 250* 1 sequence error 251* 2 duplicate key 252* 3 no record found 253* 4 boundary violation 254* 255*Status_Key_3 pic 9999 wxyz 256* 257* w: cobol i/o statement 258* x: vfile_command 259* y: same as key_1 260* z: specific cause of error 261* 262*vfile_commands and error codes 263* 264* attach_ptr (not_detached) 265* close (not_open) 266* delete_record (no_record) 267* detach_iocb (not_attached, not_closed) 268* find_iocb () 269* get_chars (short_record,end_of_info) 270* get_line (short_record,end_of_info) 271* open (not_attached,not_closed) 272* position (no_record,end_of_info) 273* read_key (end_of_info,no_record) 274* read_length (end_of_info,no_record) 275* read_record (end_of_info,no_record,long_record) 276* record_status) (no_room_for_lock,no_record,no_key) 277* rewrite_record (no_record) 278* seek_head (no_record) 279* seek_key (no_record,key_order) 280* write_record (no_key) 281* 282**/ 283 284 285 286 287 288 /* format: style3 */ 289 cobol_rts_: 290 proc (rts_ptr); 291 292 dcl 1 rts_stack based (rts_stack_ptr), 293 2 rts_code fixed bin; 294 295 dcl temp_mcode fixed bin (35); 296 dcl rts_stack_ptr ptr; 297 dcl rts_ptr ptr; 298 299 rts_stack_ptr = rts_ptr; 300 goto rts (rts_stack.rts_code); 301 302 /* ******************************* 303* * * 304* * cobol_error_ * 305* * * 306* *******************************/ 307 308 rts (1): /* This label is for cobol error */ 309 /* The declaration for the rts stack frame */ 310 dcl 1 error_stack based (rts_stack_ptr), 311 2 rts_code fixed bin, 312 2 use_code fixed bin, 313 2 filler1 char (60), 314 2 cobol_code fixed bin, 315 2 multics_code fixed bin (35), 316 2 filler2 fixed bin, 317 2 line_no1 fixed bin, 318 2 line_no2 fixed bin, 319 2 error_ptr ptr, 320 2 progname_ptr ptr, 321 2 progname_length fixed bin; 322 323 dcl progname char (65) based (progname_ptr); 324 325 326 327 328 if error_stack.use_code = 0 329 then call cobol_error_ (error_stack.cobol_code, error_stack.multics_code, error_stack.line_no1, 330 error_stack.line_no2, substr (progname, 1, error_stack.progname_length), error_stack.error_ptr); 331 else do; 332 error_stack.use_code = 0; 333 call cobol_error_$use (error_stack.cobol_code, error_stack.multics_code, error_stack.line_no1, 334 error_stack.line_no2, substr (progname, 1, error_stack.progname_length), error_stack.error_ptr); 335 end; 336 return; 337 338 339 340 /* ******************************* 341* * * 342* * cobol_control_ * 343* * * 344* *******************************/ 345 346 rts (2): /* This label is for cobol control */ 347 /* This stack frame is for cobol_contool_ rts stack frame. */ 348 dcl 1 control_stack based (rts_stack_ptr), 349 2 rts_code fixed bin, 350 2 filler char (4), 351 2 pr4_save_ptr ptr; 352 353 354 355 call cobol_control_$cobol_rts_control_ (control_stack.pr4_save_ptr); 356 return; 357 358 /* *******************************************************************************************/ 359 360 /* BEGIN SORT PACKAGE */ 361 362 /* *******************************************************************************************/ 363 364 365 366 /* ******************************* 367* * * 368* * sort_initiate * 369* * * 370* *******************************/ 371 372 rts (3): /* This label is for sort_initiate */ 373 /* The declaration for the rts stack frame */ 374 dcl 1 sort_initiate_stack 375 based (rts_stack_ptr), 376 2 filler1 char (8), 377 2 exit_ptr ptr, 378 2 control_ptr ptr, 379 2 filler2 char (8), 380 2 status_code fixed bin (35); 381 382 dcl 1 exits based (sort_initiate_stack.exit_ptr), 383 2 version fixed bin, 384 2 compare entry, 385 2 input_record entry, 386 2 output_record entry; 387 388 389 390 exits.input_record = sort_$noexit; 391 exits.output_record = sort_$noexit; 392 controlp = sort_initiate_stack.control_ptr; 393 394 if sort_file_size = 0.0 395 then sort_file_size = 1.0; 396 if sort_dir_len = 0 397 then call sort_$initiate ("", null (), sort_initiate_stack.exit_ptr, "-bf", sort_file_size, 398 sort_initiate_stack.status_code); 399 else call sort_$initiate (substr (sort_dir, 1, sort_dir_len), null (), sort_initiate_stack.exit_ptr, "-bf", 400 sort_file_size, sort_initiate_stack.status_code); 401 return; 402 403 404 405 406 407 408 /* ******************************* 409* * * 410* * sort_release * 411* * * 412* *******************************/ 413 414 rts (4): /* This label is for sort_release */ 415 /* The declaration for the rts stack frame */ 416 dcl 1 sort_release_stack 417 based (rts_stack_ptr), 418 2 filler1 char (8), 419 2 data_ptr ptr, 420 2 data_length fixed bin (21), 421 2 filler2 char (12), 422 2 status_code fixed bin (35); 423 424 dcl sort_$release entry (ptr, fixed bin (21), fixed bin (35)); 425 426 427 428 call sort_$release (sort_release_stack.data_ptr, sort_release_stack.data_length, sort_release_stack.status_code) 429 ; 430 return; 431 432 433 434 435 436 /* ******************************* 437* * * 438* * sort_return * 439* * * 440* *******************************/ 441 442 rts (5): /* This label is for sort_return */ 443 /* The declaration for the rts stack frame */ 444 dcl 1 sort_return_stack based (rts_stack_ptr), 445 2 filler1 char (8), 446 2 buff_ptr ptr, 447 2 record_length fixed bin (21), 448 2 filler2 char (12), 449 2 status_code fixed bin (35); 450 451 452 453 call sort_$return (sort_return_stack.buff_ptr, sort_return_stack.record_length, sort_return_stack.status_code); 454 if sort_return_stack.status_code = 0 455 then return; 456 else if sort_return_stack.status_code = error_table_$end_of_info 457 then do; 458 sort_return_stack.record_length = 0; 459 sort_return_stack.status_code = 0; 460 end; 461 return; 462 463 464 465 466 /* ******************************* 467* * * 468* * sort_terminate * 469* * * 470* *******************************/ 471 472 rts (6): /* This label is for sort_terminate */ 473 /* The declaration for the rts stack frame */ 474 dcl 1 sort_terminate_stack 475 based (rts_stack_ptr), 476 2 filler1 char (8), 477 2 status_code fixed bin (35), 478 2 filler2 char (20), 479 2 prev_status_code 480 fixed bin (35); 481 482 483 484 call sort_$terminate (sort_terminate_stack.status_code); 485 486 return; 487 488 489 /* ******************************* 490* * * 491* * sort_commence * 492* * * 493* *******************************/ 494 495 rts (7): /* This label is for sort_commence */ 496 /* The declaration for the rts stack frame */ 497 dcl 1 sort_commence_stack 498 based (rts_stack_ptr), 499 2 filler1 char (32), 500 2 status_code fixed bin (35); 501 502 503 504 505 call sort_$commence (sort_commence_stack.status_code); 506 return; 507 508 509 /* *******************************************************************************************/ 510 511 /* END SORT PACKAGE */ 512 513 /* *******************************************************************************************/ 514 515 516 517 /* ******************************* 518* * * 519* * stop literal * 520* * * 521* *******************************/ 522 523 rts (8): /* This label is for "stop literal". It is used to eleminate the link for cu_$cl.*/ 524 call cu_$cl; 525 return; 526 527 528 529 530 531 /* ******************************* 532* * * 533* * stop run * 534* * * 535* *******************************/ 536 537 rts (9): /* This label is for "stop run". It is used to eleminate the link for cobol_stoprun_. */ 538 dcl temp_ptr ptr based; /* temporary pointer. */ 539 540 stat_ptr = addrel (rts_stack_ptr, 36) -> temp_ptr;/* linkage section */ 541 stat_ptr = addrel (stat_ptr, 8); /* static section */ 542 controlp = stat.control_ptr; 543 544 rts9: 545 if control.main_prog_sw ^= 0 546 then call signal_ ("stop_run", null (), stat_ptr); 547 call cobol_stop_run_ (stat_ptr, 0, 0, 0); 548 call signal_ ("command_abort_", null (), null ()); 549 return; 550 551 rts (62): /*[4.4-2]*/ 552 dcl cobol_mcs_$stop_run entry; 553 554 /*[4.4-2]*/ 555 stat_ptr = addrel (rts_stack_ptr, 36) -> temp_ptr;/* linkage section */ 556 /*[4.4-2]*/ 557 stat_ptr = addrel (stat_ptr, 8); /* static section */ 558 /*[4.4-2]*/ 559 controlp = stat.control_ptr; 560 561 /*[4.4-2]*/ 562 call cobol_mcs_$stop_run; 563 564 go to rts9; 565 566 567 568 569 570 571 572 573 /* ******************************* 574* * * 575* * cancel * 576* * * 577* *******************************/ 578 579 580 rts (10): /* this label is for cancel code to call cobol_control_$cancel */ 581 dcl 1 cancel_stack based (rts_stack_ptr), 582 2 filler char (8), 583 2 name_ptr ptr, 584 2 name_length fixed bin, 585 2 cancel_code fixed bin; 586 587 dcl cancel_name char (65) based (cancel_stack.name_ptr); 588 589 call cobol_control_$cancel (substr (cancel_name, 1, cancel_stack.name_length), 0, 0, cancel_code); 590 return; 591 592 /* *******************************************************************************************/ 593 594 /* BEGIN IO PACKAGE */ 595 596 /* *******************************************************************************************/ 597 598 599 /****************************** 600* * * 601* * iox_$control * 602* * * 603* *******************************/ 604 605 rts (11): /* This label is for iox_$control */ 606 dcl 1 iox_control_stack based (error_block.offset_ptr), 607 2 iocb_ptr ptr, 608 2 control_ptr ptr; 609 dcl 1 struc based (iox_control_stack.control_ptr), 610 2 relation fixed bin, 611 2 keylen fixed bin, 612 2 key char (0 refer (keylen)); 613 614 dcl order_name char (9) init ("seek_head"); 615 dcl control_iocb_ptr ptr based (iox_control_stack.iocb_ptr); 616 617 618 619 call iox_$control (control_iocb_ptr, order_name, iox_control_stack.control_ptr, mcode); 620 621 if mcode ^= 0 622 then do; 623 if mcode = error_table_$no_record 624 then do; 625 error_block.status12 = "23"; 626 error_block.status3 = "6723"; /*[4.0-1] */ 627 icode = 4; 628 end; 629 else do; 630 error_block.status12 = "30"; 631 error_block.status3 = "6732"; 632 end; 633 end; 634 return; 635 636 637 638 /* The declaration for the rts stack frame */ 639 640 dcl 1 io_stack_hdr based (rts_stack_ptr), 641 2 rts_code fixed bin, 642 2 use_code fixed bin, 643 2 iocb_ptr ptr, 644 2 mcode_ptr ptr, 645 2 buff_ptr ptr, 646 2 buff_len fixed bin (21), 647 2 actual_len fixed bin (21), 648 2 stack_buff_ptr ptr; 649 dcl 1 read_key_based based (addr (io_stack_hdr.stack_buff_ptr)), 650 2 filler fixed bin, 651 2 read_key_eof fixed bin; 652 dcl 1 error_block based (io_stack_hdr.mcode_ptr), 653 2 mcode fixed bin (35), 654 2 icode fixed bin, 655 2 status12 char (2) aligned, 656 2 status3 char (4) aligned, 657 2 retrycode fixed bin, 658 2 filler1 char (4), 659 2 option_flag fixed bin, 660 2 filler2 char (4), 661 2 offset_ptr ptr, 662 2 filler13 char (16), 663 2 temp_flag fixed bin; 664 665 666 /* ******************************* 667* * * 668* * check close error * 669* * * 670* *******************************/ 671 672 rts (12): /* This label is for check close error */ 673 /* The fields referenced are in dcl error_block. */ 674 check_close_error: 675 error_block.status12 = "30"; 676 if mcode = error_table_$no_operation 677 then error_block.status3 = "2332"; 678 else if mcode = error_table_$bad_file 679 then error_block.status3 = "2392"; 680 else error_block.status3 = "2390"; 681 return; 682 683 684 685 686 687 688 /****************************** 689* * * 690* * check open error * 691* * * 692* *******************************/ 693 694 rts (13): /* This label is for check open error */ 695 /* The fields referenced are in dcl error_block. */ 696 check_open_error: 697 error_block.status12 = "30"; 698 if mcode = error_table_$no_operation 699 then error_block.status3 = "1232"; 700 else if mcode = error_table_$file_busy 701 then error_block.status3 = "1291"; 702 else if mcode = error_table_$incompatible_attach 703 then error_block.status3 = "1294"; 704 else if mcode = error_table_$bad_file 705 then error_block.status3 = "1292"; 706 else if mcode = error_table_$noentry 707 then error_block.status3 = "1295"; 708 else error_block.status3 = "1290"; 709 return; 710 711 712 /****************************** 713* * * 714* * iox_$find_iocb * 715* * * 716* *******************************/ 717 718 rts (14): /* This label is for iox_$find_iocb */ 719 dcl 1 find_iocb_stack based (error_block.offset_ptr), 720 2 fsb_ptr ptr, 721 2 switchlen fixed bin, 722 2 filler2 char (4), 723 2 switchname char (0 refer (find_iocb_stack.switchlen)); 724 725 dcl find_iocb_ptr ptr based (find_iocb_stack.fsb_ptr); 726 727 728 729 call iox_$find_iocb (find_iocb_stack.switchname, find_iocb_ptr, error_block.mcode); 730 731 return; 732 733 734 735 736 737 /******************************* 738* * * 739* * iox_$attach_ptr * 740* * * 741* *******************************/ 742 743 rts (15): /* This labe is for iox_$attach_iocb */ 744 dcl 1 attach_iocb_stack based (error_block.offset_ptr), 745 2 fsb_ptr ptr, 746 2 atdlen fixed bin, 747 2 filler2 char (4), 748 2 atd char (0 refer (attach_iocb_stack.atdlen)); 749 750 dcl attach_iocb_ptr ptr based (attach_iocb_stack.fsb_ptr); 751 752 753 754 /*[4.0-4]*/ 755 call iox_$attach_ptr (attach_iocb_ptr, attach_iocb_stack.atd, null (), error_block.mcode); 756 757 return; 758 759 760 761 762 /****************************** 763* * * 764* * check seek errors * 765* * * 766* *******************************/ 767 768 rts (16): /* This label is for check seek key errors */ 769 check_seek_error: 770 if temp_flag = 1 771 then do; 772 if mcode = error_table_$key_order 773 then do; 774 icode = 1; 775 error_block.status12 = "21"; 776 error_block.status3 = "3621"; 777 end; 778 else if mcode = error_table_$no_record 779 then do; 780 icode = 1; 781 error_block.status12 = "23"; 782 error_block.status3 = "3623"; 783 end; 784 else do; 785 error_block.status12 = "30"; 786 if mcode = error_table_$no_operation 787 then error_block.status3 = "3632"; 788 else error_block.status3 = "3630"; 789 end; 790 end; 791 else do; 792 if mcode = error_table_$no_record 793 then do; 794 error_block.status12 = "00"; 795 error_block.status3 = "0000"; 796 mcode = 0; 797 end; 798 else if mcode = error_table_$key_order 799 then do; 800 error_block.status12 = "21"; 801 error_block.status3 = "4621"; 802 end; 803 else do; 804 805 806 error_block.status12 = "21"; 807 error_block.status3 = "4622"; 808 end; 809 end; 810 811 812 return; 813 814 815 816 /******************************* 817* * * 818* * iox_$read_key * 819* * * 820* *******************************/ 821 822 rts (17): /* This label is for iox_$read_key errors */ 823 read_key_error: /* don't report EOF now, wait for seek */ 824 if mcode = error_table_$end_of_info 825 then do; 826 error_block.status12 = "00"; 827 error_block.status3 = "0000"; 828 read_key_based.read_key_eof = 1; 829 mcode = 0; 830 end; 831 else if mcode = error_table_$no_record 832 then do; 833 error_block.status12 = "10"; 834 error_block.status3 = "3830"; 835 end; 836 return; 837 838 839 840 841 842 843 /* ******************************* 844* * * 845* * accept * 846* * * 847* *******************************/ 848 849 rts (18): /* This label is interfacing with accept_gen for accpting user's word. */ 850 call iox_$get_line (iox_$user_input, io_stack_hdr.buff_ptr, io_stack_hdr.buff_len, io_stack_hdr.actual_len, 851 error_block.mcode); 852 853 if error_block.mcode = error_table_$long_record 854 then do while (error_block.mcode = error_table_$long_record); 855 call iox_$get_line (iox_$user_input, io_stack_hdr.stack_buff_ptr, 64, io_stack_hdr.actual_len, 856 error_block.mcode); 857 io_stack_hdr.actual_len = 0; 858 end; 859 return; 860 861 862 rts (20): 863 rts (21): 864 rts (22): /* These labels are for accept from day (time,day of week, and date). */ 865 dcl 1 time_stack based (rts_stack_ptr), 866 2 rts_code fixed bin, 867 2 use_code fixed bin, 868 2 month fixed bin, 869 2 filler1 char (4), 870 2 dom fixed bin, /* day of the month */ 871 2 filler2 char (4), 872 2 year fixed bin, 873 2 filler3 char (4), 874 2 tod fixed bin (71), /*time of the day */ 875 2 dow fixed bin, /*day of the week */ 876 2 zone char (3) aligned, /* time zone */ 877 2 day_return fixed bin, /* day in the form yy||doy */ 878 2 filler4 char (4), 879 2 doy fixed bin, /* day of the year */ 880 2 filler5 char (4), 881 2 date char (6); /* day in the form yy||mm||dd */ 882 883 dcl date_time fixed bin (71), 884 d_array (12) fixed bin static init (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334), 885 day_temp char (8); 886 887 date_time = clock_ (); 888 889 if time_stack.rts_code = 22 890 then do; 891 call date_time_ (date_time, day_temp); 892 date = substr (day_temp, 7, 2) || substr (day_temp, 1, 2) || substr (day_temp, 4, 2); 893 return; 894 end; 895 896 call decode_clock_value_ (date_time, month, dom, year, tod, dow, zone); 897 if time_stack.rts_code ^= 20 898 then return; 899 900 doy = d_array (month) + dom; 901 902 if mod (year, 4) = 0 & month > 2 /* [4.1-1] */ 903 then doy = doy + 1; 904 else /*do nothing */ 905 ; 906 return; 907 908 909 910 /* ******************************* 911* * * 912* * inspect * 913* * * 914* *******************************/ 915 916 rts (23): 917 rts (24): /* These labels are for inspect to call cobol_su_$tally and cobol_su_$replace. */ 918 dcl 1 inspect_stack based (rts_stack_ptr), 919 2 rts_code fixed bin, 920 2 filler char (4), 921 2 work_ptr ptr, 922 2 output_length fixed bin; 923 924 if inspect_stack.rts_code = 24 925 then call cobol_su_$replace (inspect_stack.work_ptr); 926 else call cobol_su_$tally (inspect_stack.work_ptr, inspect_stack.output_length); 927 return; 928 929 930 931 932 933 934 /* ***************************************** 935* * * 936* * seek for delete * 937* * * 938* *******************************/ 939 940 rts (25): /* This label is for delete seek and delete record. */ 941 if mcode = error_table_$no_record 942 then do; 943 error_block.status12 = "00"; 944 error_block.status3 = "0000"; 945 mcode = 0; 946 end; 947 return; 948 949 950 /******************************* 951* * * 952* * check_read_key * 953* * * 954* *******************************/ 955 956 rts (26): /* This label is used to set up status code for read key */ 957 /* don't report EOF now, wait for seek */ 958 if mcode = error_table_$end_of_info 959 then do; 960 error_block.status12 = "10"; 961 error_block.status3 = "3810"; 962 icode = 1; 963 end; 964 else if mcode = error_table_$no_record 965 then do; 966 icode = 1; 967 error_block.status12 = "10"; 968 error_block.status3 = "3830"; 969 end; 970 else if mcode = error_table_$no_operation 971 then do; 972 error_block.status12 = "30"; 973 error_block.status3 = "3832"; 974 end; 975 else do; 976 error_block.status12 = "30"; 977 error_block.status3 = "3830"; 978 end; 979 return; 980 981 982 983 /******************************* 984* * * 985* * check_read_record * 986* * * 987* *******************************/ 988 989 rts (27): /* This label is used to set up status code for read record */ 990 if mcode = error_table_$short_record 991 then do; 992 mcode = 0; 993 error_block.status12 = "00"; 994 error_block.status3 = "3001"; 995 end; 996 else if mcode = error_table_$no_record 997 then do; 998 if temp_flag = 1 999 then do; 1000 error_block.status12 = "23"; 1001 error_block.status3 = "3423"; 1002 end; 1003 else do; 1004 error_block.status12 = "10"; 1005 error_block.status3 = "3430"; 1006 end; 1007 icode = 1; 1008 end; 1009 else if mcode = error_table_$end_of_info 1010 then do; 1011 icode = 1; 1012 if temp_flag = 0 1013 then do; 1014 error_block.status12 = "10"; 1015 error_block.status3 = "3410"; 1016 end; 1017 else do; 1018 error_block.status12 = "30"; 1019 error_block.status3 = "3430"; 1020 end; 1021 end; 1022 else do; 1023 error_block.status12 = "30"; 1024 if mcode = error_table_$no_operation 1025 then error_block.status3 = "3432"; 1026 else do; 1027 error_block.status12 = "10"; /* force END OF FILE condition */ 1028 error_block.status3 = "3410"; 1029 end; 1030 end; 1031 return; 1032 1033 1034 1035 /******************************* 1036* * * 1037* * check_get_line * 1038* * * 1039* *******************************/ 1040 1041 rts (28): /* This label is used to set up status codes for get_line. */ 1042 if mcode = error_table_$end_of_info 1043 then do; 1044 icode = 1; 1045 error_block.status12 = "10"; 1046 error_block.status3 = "3510"; 1047 end; 1048 else if mcode = error_table_$long_record 1049 then do; 1050 error_block.status12 = "30"; 1051 error_block.status3 = "3535"; 1052 end; 1053 else do; 1054 error_block.status12 = "30"; 1055 error_block.status3 = "3535"; 1056 end; 1057 return; 1058 1059 1060 1061 1062 1063 1064 1065 /* *******************************************************************************************/ 1066 1067 /* END IO PACKAGE */ 1068 1069 /* *******************************************************************************************/ 1070 1071 1072 /* *******************************************************************************************/ 1073 1074 /* BEGIN MERGE PACKAGE */ 1075 1076 /* *******************************************************************************************/ 1077 1078 1079 /* The declaration for the communication stack frame which is shared by all merge rts package. */ 1080 1081 dcl 1 merge_comm_stack based (rts_stack_ptr), 1082 2 rts_code fixed bin, 1083 2 filler char (28), 1084 2 merge_stack_off_rts 1085 fixed bin, 1086 2 file_n_rts fixed bin, 1087 2 merge_record_ptr_rts 1088 ptr, 1089 2 tree_ptr_rts ptr, 1090 2 comp_ptr_rts ptr, 1091 2 merge_controlp ptr; 1092 1093 /* static internal data for merge communication stack frame in case the 1094* merge_comm_stack is destoryed by other rts call. */ 1095 1096 dcl 1 merge_comm_static static, 1097 2 merge_stack_off fixed bin, /* start offset for record ptr. */ 1098 2 file_n fixed bin, /* no of using file. */ 1099 2 merge_record_ptr 1100 ptr, /* base of record (pointers) */ 1101 2 tree_ptr ptr, /* base of tree (fixed bin) */ 1102 2 comp_ptr ptr, /* base of compare entry. */ 1103 2 merge_seg_ptr ptr; /* pointer for cobol_temp_merge_file_. */ 1104 1105 /* compare entry */ 1106 1107 dcl 1 cmp_entry based (merge_comm_static.comp_ptr), 1108 2 merge_compare entry (ptr, ptr, fixed bin); 1109 1110 /* pointers to the cra of each using file. */ 1111 1112 dcl 1 merge_record based (merge_comm_static.merge_record_ptr), 1113 2 record (merge_comm_static.file_n) ptr; 1114 1115 /* temporary locations for compare usage. */ 1116 1117 dcl 1 merge_tree based (merge_comm_static.tree_ptr), 1118 2 tree (2 * merge_comm_static.file_n - 1) fixed bin, 1119 2 compare_code fixed bin; 1120 1121 /* Automatic data for merge package. */ 1122 1123 dcl (i, j, k, w) fixed bin; 1124 1125 1126 1127 /* ******************************* 1128* * * 1129* * merge_init * 1130* * * 1131* *******************************/ 1132 1133 rts (30): /* Initialize the stack frame for merge and trees. */ 1134 merge_comm_static.file_n = merge_comm_stack.file_n_rts; 1135 merge_comm_static.merge_record_ptr = merge_comm_stack.merge_record_ptr_rts; 1136 merge_comm_static.tree_ptr = merge_comm_stack.tree_ptr_rts; 1137 merge_comm_static.comp_ptr = merge_comm_stack.comp_ptr_rts; 1138 controlp = merge_controlp; 1139 1140 call hcs_$terminate_name ("cobol_temp_merge_file_", temp_mcode); 1141 1142 if sort_dir_len = 0 1143 then do; 1144 sort_dir = get_pdir_ (); 1145 sort_dir_len = index (sort_dir, " ") - 1; 1146 end; 1147 1148 call hcs_$make_seg (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", "cobol_temp_merge_file_", 1149 01011b, merge_seg_ptr, temp_mcode); 1150 call hcs_$truncate_seg (merge_seg_ptr, 0, temp_mcode); 1151 1152 do i = 1 to merge_comm_static.file_n; 1153 merge_tree.tree (i) = i; 1154 end; 1155 1156 return; 1157 1158 1159 /* ******************************* 1160* * * 1161* * merge_comp * 1162* * * 1163* *******************************/ 1164 1165 rts (31): /* Set up to call merge compare. */ 1166 if merge_comm_static.file_n = 1 1167 then return; 1168 do i = 1 by 2 to (2 * merge_comm_static.file_n - 3); 1169 call merge_call_compare (i, i + 1); 1170 end; 1171 return; 1172 1173 1174 1175 /* ******************************* 1176* * * 1177* * merge_return * 1178* * * 1179* *******************************/ 1180 1181 rts (32): /* handle return statement for merge. */ 1182 k = 2 * merge_comm_static.file_n - 1; 1183 if k = 1 1184 then return; 1185 i = tree (k); 1186 do while (i < k); 1187 if mod (i, 2) = 0 1188 then j = i - 1; 1189 else j = i + 1; 1190 call merge_call_compare (i, j); 1191 i = w; 1192 end; 1193 return; 1194 1195 /* *******************************************************************************************/ 1196 1197 /* INTERNAL SUBROUTINE FOR MERGE COMPARE SET UP */ 1198 1199 /* *******************************************************************************************/ 1200 1201 merge_call_compare: 1202 proc (i, j); 1203 1204 /* This subroutine is used to set up tree on the stack frame through the compare 1205* entry on the cobol object code. */ 1206 1207 dcl (i, j) fixed bin; 1208 1209 w = merge_comm_static.file_n + (i + 1) / 2; 1210 if merge_tree.tree (i) = 0 1211 then merge_tree.tree (w) = merge_tree.tree (j); /* eof of file i */ 1212 else if merge_tree.tree (j) = 0 1213 then merge_tree.tree (w) = merge_tree.tree (i); /* eof of file j */ 1214 else do; 1215 call merge_compare (merge_record.record (merge_tree.tree (i)), 1216 merge_record.record (merge_tree.tree (j)), merge_tree.compare_code); 1217 if merge_tree.compare_code = -1 1218 then merge_tree.tree (w) = merge_tree.tree (i); 1219 else if merge_tree.compare_code = 1 1220 then merge_tree.tree (w) = merge_tree.tree (j); 1221 else if merge_tree.tree (i) < merge_tree.tree (j) 1222 then merge_tree.tree (w) = merge_tree.tree (i); 1223 else merge_tree.tree (w) = merge_tree.tree (j); 1224 end; 1225 return; 1226 1227 end merge_call_compare; 1228 1229 1230 1231 /* *******************************************************************************************/ 1232 1233 /* END MERGE PACKAGE */ 1234 1235 /* *******************************************************************************************/ 1236 1237 1238 /* *******************************************************************************************/ 1239 1240 /* BEGIN COMMUNICATION PACKAGE */ 1241 1242 /* *******************************************************************************************/ 1243 1244 1245 /* ******************************* 1246* * * 1247* * receive_comm * 1248* * * 1249* *******************************/ 1250 1251 rts (40): 1252 dcl 1 receive_comm_stack 1253 based (rts_stack_ptr), 1254 2 rts_code fixed bin, 1255 2 filler fixed bin, 1256 2 mcs_icdp ptr, 1257 2 mesp ptr, 1258 2 type fixed bin, 1259 2 max_meslen fixed bin, 1260 2 filler1 fixed bin, 1261 2 no_data fixed bin, 1262 2 filler2 char (8), 1263 2 code fixed bin (35); 1264 1265 if receive_comm_stack.type >= 2 1266 then do; 1267 receive_comm_stack.type = receive_comm_stack.type - 2; 1268 call cobol_mcs_$receive (receive_comm_stack.mcs_icdp, receive_comm_stack.type, 1269 receive_comm_stack.mesp, receive_comm_stack.max_meslen, receive_comm_stack.code); 1270 if receive_comm_stack.code = cmcs_error_table_$no_message 1271 then do; 1272 receive_comm_stack.code = 0; 1273 receive_comm_stack.no_data = 1; 1274 end; 1275 else receive_comm_stack.no_data = 0; 1276 end; 1277 else do; 1278 call cobol_mcs_$receive_wait (receive_comm_stack.mcs_icdp, receive_comm_stack.type, 1279 receive_comm_stack.mesp, receive_comm_stack.max_meslen, receive_comm_stack.code); 1280 end; 1281 return; 1282 1283 1284 1285 1286 1287 /* ******************************* 1288* * * 1289* * accept_comm * 1290* * * 1291* *******************************/ 1292 1293 1294 rts (41): 1295 dcl 1 accept_comm_stack based (rts_stack_ptr), 1296 2 rts_code fixed bin, 1297 2 filler fixed bin, 1298 2 mcs_icdp ptr, 1299 2 filler1 char (32), 1300 2 code fixed bin (35); 1301 1302 call cobol_mcs_$accept (accept_comm_stack.mcs_icdp, accept_comm_stack.code); 1303 return; 1304 1305 1306 /* ******************************* 1307* * * 1308* * purge_comm * 1309* * * 1310* *******************************/ 1311 1312 1313 1314 1315 1316 1317 1318 rts (42): 1319 dcl 1 purge_comm_stack based (rts_stack_ptr), 1320 2 rts_code fixed bin, 1321 2 filler fixed bin, 1322 2 mcs_icdp ptr, 1323 2 filler1 char (32), 1324 2 code fixed bin (35); 1325 1326 call cobol_mcs_$purge (purge_comm_stack.mcs_icdp, purge_comm_stack.code); 1327 return; 1328 1329 1330 1331 1332 1333 1334 1335 /* ******************************* 1336* * * 1337* * send_comm * 1338* * * 1339* *******************************/ 1340 1341 rts (43): 1342 dcl 1 send_comm_stack based (rts_stack_ptr), 1343 2 rts_code fixed bin, 1344 2 filler fixed bin, 1345 2 mcs_ocdp ptr, 1346 2 mesp ptr, 1347 2 max_meslen char (4), 1348 2 end_indicator char (1), 1349 2 filler2 char (3), 1350 2 line_control bit (36), 1351 2 filler1 char (12), 1352 2 code fixed bin (35); 1353 1354 call cobol_mcs_$send (send_comm_stack.mcs_ocdp, send_comm_stack.mesp, send_comm_stack.max_meslen, 1355 send_comm_stack.end_indicator, send_comm_stack.line_control, send_comm_stack.code); 1356 return; 1357 1358 1359 1360 1361 /* ******************************* 1362* * * 1363* * enable_comm * 1364* * * 1365* *******************************/ 1366 1367 rts (44): 1368 dcl 1 enable_comm_stack based (rts_stack_ptr), 1369 2 rts_code fixed bin, 1370 2 filler fixed bin, 1371 2 mcs_icdp ptr, 1372 2 password_ptr ptr, 1373 2 password_length fixed bin, 1374 2 in_or_out fixed bin, 1375 2 terminal_flag fixed bin, 1376 2 filler1 char (12), 1377 2 code fixed bin (35); 1378 1379 dcl password char (30) based (enable_comm_stack.password_ptr); 1380 1381 if enable_comm_stack.in_or_out = 0 1382 then do; 1383 if enable_comm_stack.terminal_flag = 1 1384 then call cobol_mcs_$enable_input_terminal (enable_comm_stack.mcs_icdp, 1385 substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); 1386 else call cobol_mcs_$enable_input_queue (enable_comm_stack.mcs_icdp, 1387 substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); 1388 end; 1389 else call cobol_mcs_$enable_output (enable_comm_stack.mcs_icdp, 1390 substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); 1391 return; 1392 1393 rts (45): /* Disable use the same stack as enable. */ 1394 if enable_comm_stack.in_or_out = 0 1395 then do; 1396 if enable_comm_stack.terminal_flag = 1 1397 then call cobol_mcs_$disable_input_terminal (enable_comm_stack.mcs_icdp, 1398 substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); 1399 else call cobol_mcs_$disable_input_queue (enable_comm_stack.mcs_icdp, 1400 substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); 1401 end; 1402 else call cobol_mcs_$disable_output (enable_comm_stack.mcs_icdp, 1403 substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); 1404 return; 1405 1406 1407 1408 /* 1409* 1410* 1411**/ 1412 /* *******************************************************************************************/ 1413 1414 /* BEGIN ALTERNATE RECORD KEY PACKAGE */ 1415 1416 /* *******************************************************************************************/ 1417 1418 1419 1420 1421 dcl 1 alt_stack_hdr based (rts_stack_ptr), 1422 2 rts_code fixed bin (35), 1423 2 use_code fixed bin (35), 1424 2 iocb_ptr ptr, 1425 2 mcode_ptr ptr, 1426 2 file_rec_buf_ptr 1427 ptr, 1428 2 file_desc_ptr ptr, 1429 2 cobol_open_mode fixed bin (35), 1430 2 cobol_options fixed bin (35), 1431 2 vfile_open_mode fixed bin (35), 1432 2 key_of_ref fixed bin (35), 1433 2 fsb_ptr ptr, /*[5.3-1]*/ 1434 2 arg2_ptr ptr, /*[5.3-1]*/ 1435 2 arg3_ptr ptr, /*[5.3-1]*/ 1436 2 arg4_ptr ptr, /*[5.3-1]*/ 1437 2 arg5_ptr ptr; 1438 1439 dcl 1 seek_info, 1440 2 relation_type fixed bin, 1441 2 n fixed bin, 1442 2 search_key char (256); 1443 1444 declare mode fixed bin; 1445 1446 /* 1447* where: 1448* 1449* relation_type 0 = search_key 1450* 1 >= search_key 1451* 2 > search_key 1452* 1453* n is the length of the search_key 1454* 1455* search_key is the character string used to match indeies 1456* 1457**/ 1458 1459 /* *******************************************************************************************/ 1460 1461 /* AUTOMATIC VARIABLES FOR ALTERNATE RECORD KEYS */ 1462 1463 /* *******************************************************************************************/ 1464 1465 1466 declare file_record_buffer char (1000000) based (buff_ptr); 1467 declare rs_record_buffer char (1000000) based (rs_info.record_ptr); 1468 1469 dcl dummy_buffer char (1); 1470 dcl char1 char (1); 1471 1472 dcl rec_len fixed bin (21); 1473 dcl save_sw bit (1); 1474 1475 declare key_num fixed bin (35); 1476 declare (buff_ptr, alt_key_desc_ptr) 1477 ptr; 1478 declare KEY_OF_REF fixed bin static internal; 1479 declare (CODE, KEY_NUM) fixed bin (35); 1480 declare REC_LEN fixed bin (21); 1481 declare READ_KEY char (256) varying; 1482 1483 declare 1 status_info, 1484 2 info aligned like rs_info; 1485 1486 declare 1 GK_INFO, 1487 2 HDR like gk_header, 1488 2 KEY char (256); 1489 declare 1 AK_INFO, 1490 2 HDR like ak_header, 1491 2 KEY char (256); 1492 1493 declare MCODE fixed bin (35) based (alt_stack_hdr.mcode_ptr); 1494 /*[5.3-1]*/ 1495 dcl BUFF_LEN fixed bin (21) based; /*[5.3-1]*/ 1496 dcl REC_LGT fixed bin (21) based; /*[5.3-1]*/ 1497 dcl BUFF_PTR ptr; /*[4.4-1]*/ 1498 declare key_status (512) bit (1) static internal; 1499 1500 /* ******************************* 1501* * * 1502* * open * 1503* * * 1504* *******************************/ 1505 1506 rts (46): /* This label is for the OPEN statement with alternate record keys */ 1507 fsb_ptr = alt_stack_hdr.fsb_ptr; 1508 fsb.file_desc_ptr = alt_stack_hdr.file_desc_ptr; 1509 file_desc_1_ptr = fsb.file_desc_ptr; 1510 fsb.vfile_open_mode = alt_stack_hdr.vfile_open_mode; 1511 fsb.cobol_open_mode = alt_stack_hdr.cobol_open_mode; 1512 fsb.last_cobol_op = 1; /* open */ 1513 alt_stack_hdr.fsb_ptr -> fsb.key_of_ref = 511; /* prime key */ 1514 fsb.crp.prime_key = ""; 1515 1516 /*[5.3-1]*/ 1517 if fsb.fsb_skel.mod1 1518 then fsb.last_key_read = ""; 1519 1520 if fsb.cobol_open_mode = 29 | /* input(seq) */ fsb.cobol_open_mode = 30 1521 | /* input(ran) */ fsb.cobol_open_mode = 31 | /* input(dyn) */ fsb.cobol_open_mode = 45 1522 | /* i-o(seq) */ fsb.cobol_open_mode = 46 | /* i-o(ran */ fsb.cobol_open_mode = 47 1523 /* i-o(dyn) */ 1524 then do; /* position the file */ 1525 seek_info.relation_type = 0; 1526 seek_info.n = 1; /*[4.4-1]*/ 1527 unspec (char1) = "111111111"b; /*[4.4-1]*/ 1528 seek_info.search_key = char1; 1529 1530 call iox_$control (fsb.iocb_ptr, "seek_head", addr (seek_info), MCODE); 1531 end; 1532 return; 1533 1534 1535 1536 1537 /* ******************************* 1538* * * 1539* * close * 1540* * * 1541* *******************************/ 1542 1543 1544 rts (47): /* This label is for the CLOSE statement with alternate record keys */ 1545 /*[4.4-1]*/ 1546 call set_up; 1547 1548 fsb.last_cobol_op = 2; /* close */ 1549 /*[5.3-1]*/ 1550 if fsb.fsb_skel.mod1 1551 then fsb.last_key_read = ""; 1552 return; 1553 1554 1555 1556 /* ******************************* 1557* * * 1558* * start * 1559* * * 1560* *******************************/ 1561 1562 1563 rts (48): /* OP79(start) */ 1564 /*[4.4-1]*/ 1565 call set_up; 1566 1567 fsb.last_cobol_op = 3; /* start */ 1568 fsb.key_of_ref = KEY_OF_REF; 1569 return; 1570 1571 1572 1573 1574 /* ******************************* 1575* * * 1576* * read next * 1577* * * 1578* *******************************/ 1579 1580 1581 rts (49): /* OP80(read next) */ 1582 /*[4.4-1]*/ 1583 call set_up; 1584 1585 fsb.last_cobol_op = 4; /* read next */ 1586 return; 1587 1588 1589 1590 1591 /* ******************************* 1592* * * 1593* * read key * 1594* * * 1595* *******************************/ 1596 1597 1598 rts (50): /* OP(1(read key) */ 1599 /*[4.4-1]*/ 1600 call set_up; 1601 1602 fsb.last_cobol_op = 5; /* read key */ 1603 1604 if fsb.cobol_open_mode = 31 /* ind-dyn(i) */ | fsb.cobol_open_mode = 63 /* ind-dyn(o) */ 1605 | fsb.cobol_open_mode = 47 /* ind-dyn(io) */ 1606 then fsb.key_of_ref = KEY_OF_REF; 1607 return; 1608 1609 1610 1611 /* ******************************* 1612* * * 1613* * write * 1614* * * 1615* *******************************/ 1616 1617 1618 rts (51): /* OP91(write) */ 1619 /*[4.4-1]*/ 1620 call set_up; 1621 1622 unspec (char1) = "111111111"b; 1623 buff_ptr = alt_stack_hdr.file_rec_buf_ptr; 1624 rs_info_ptr = addr (status_info); 1625 alt_key_desc_ptr = addr (file_desc_1.alt_key (1)); 1626 1627 if fsb.cobol_open_mode = 61 /* output seq */ 1628 then if char1 || substr (fsb.key, 1, fsb.keylen_sw) /* keys not sequential */ <= fsb.crp.prime_key 1629 then do; 1630 MCODE = error_table_$key_order; 1631 return; 1632 end; 1633 1634 save_sw = "0"b; 1635 1636 call save_NRP; 1637 1638 if fsb.vfile_open_mode ^= 9 /* keyed sequential output */ 1639 then /*[4.4-1]*/ 1640 do; 1641 key_len_ptr = addr (vfile_key.size); 1642 key_ptr = addr (vfile_key.key); 1643 1644 do key_num = 1 to file_desc_1.alt_key_count; 1645 1646 /*[5.0-1]*/ 1647 call set_off_sz; 1648 1649 /*[4.4-1]*/ 1650 call form_alt_key (buff_ptr); /*[4.4-1]*/ 1651 call iox_$seek_key (fsb.iocb_ptr, substr (vfile_key.key, 1, vfile_key.size), rec_len, MCODE); 1652 1653 if MCODE = 0 /* duplicate exists */ 1654 then if file_desc_1.alt_key (key_num).size >= 0 1655 then do; /* duplicate exists and not legal */ 1656 if save_sw 1657 then call restore_NRP; 1658 1659 MCODE = error_table_$key_duplication; 1660 return; 1661 end; 1662 1663 end; /*[4.4-1]*/ 1664 end; 1665 fsb.key = char1 || substr (fsb.key, 1, fsb.keylen_sw); 1666 fsb.keylen_sw = fsb.keylen_sw + 1; 1667 1668 MCODE = 0; 1669 1670 return; 1671 1672 1673 1674 1675 rts (52): /* OP87(delete) */ 1676 /*[4.4-1]*/ 1677 call set_up; /*[4.4-1]*/ 1678 call rec_status; 1679 1680 /*[4.4-1]*/ 1681 if MCODE ^= 0 1682 then return; 1683 1684 /*[5.3-1]*/ 1685 if fsb.cobol_open_mode = 45 /*[5.3-1]*/ 1686 then if fsb.last_cobol_op ^= 4 /* read */ 1687 /*[5.3-1]*/ 1688 then do; 1689 error_block.status12 = "30"; /*[5.3-1]*/ 1690 error_block.status3 = "7033"; /*[5.3-1]*/ 1691 MCODE = error_table_$no_record; /*[5.3-1]*/ 1692 return; /*[5.3-1]*/ 1693 end; 1694 1695 1696 /*[4.4-1]*/ 1697 call init_ak_info ("delete_key"); 1698 1699 /*[4.4-1]*/ 1700 do key_num = 1 by 1 to file_desc_1.alt_key_count; 1701 1702 /*[4.4-1]*/ 1703 call set_off_sz; 1704 1705 /*[4.4-1]*/ 1706 call process_key (rs_info.record_ptr); 1707 1708 /*[4.4-1]*/ 1709 end; 1710 1711 MCODE = 0; 1712 1713 return; 1714 1715 1716 1717 /* ******************************* 1718* * * 1719* * rewrite * 1720* * * 1721* *******************************/ 1722 1723 rts (61): /* OP93(rewrite) */ 1724 /*[4.4-1]*/ 1725 call set_up; /*[4.4-1]*/ 1726 call rec_status; 1727 1728 /*[4.4-1]*/ 1729 if MCODE ^= 0 1730 then return; 1731 1732 /*[4.4-1]*/ 1733 buff_ptr = alt_stack_hdr.file_rec_buf_ptr; /*[4.4-1]*/ 1734 alt_key_desc_ptr = addr (file_desc_1.alt_key (1)); 1735 1736 /*[4.4-1]*/ 1737 call init_gk_info; 1738 gk_info.header.reset_pos = "1"b; 1739 string (key_status) = "0"b; 1740 1741 /*[4.4-1]*/ 1742 do key_num = 1 by 1 to file_desc_1.alt_key_count; 1743 1744 /*[4.4-1]*/ 1745 call set_off_sz; 1746 call keys_unequal; 1747 1748 /*[4.4-1]*/ 1749 if sz >= 0 /*[4.4-1]*/ 1750 then if key_comp /*[4.4-1]*/ 1751 then do; /*[4.4-1]*/ 1752 call process_key (buff_ptr); /*[4.4-1]*/ 1753 if MCODE = 0 /*[4.4-1]*/ 1754 then do; 1755 MCODE = error_table_$key_duplication; 1756 /*[4.4-1]*/ 1757 return; /*[4.4-1]*/ 1758 end; /*[4.4-1]*/ 1759 end; 1760 1761 /*[4.4-1]*/ 1762 end; 1763 1764 /*[4.4-1]*/ 1765 call init_ak_info ("delete_key"); 1766 1767 /*[4.4-1]*/ 1768 do key_num = 1 by 1 to file_desc_1.alt_key_count; 1769 1770 /*[4.4-1]*/ 1771 call set_off_sz; 1772 1773 /*[4.4-1]*/ 1774 if key_status (key_num) 1775 then call process_key (rs_info.record_ptr); 1776 1777 /*[4.4-1]*/ 1778 end; 1779 1780 /*[4.4-1]*/ 1781 return; 1782 1783 /*[4.4-1]*/ 1784 declare (sz_abs, sz, off) fixed bin; /*[4.4-1]*/ 1785 declare (key_len_ptr, key_ptr, info_ptr) 1786 ptr; /*[4.4-1]*/ 1787 declare key_op char (10); 1788 1789 /*[4.4-1]*/ 1790 declare 1 vfile_key, /*[4.4-1]*/ 1791 2 size fixed bin, /*[4.4-1]*/ 1792 2 key char (256); 1793 1794 set_off_sz: 1795 proc; 1796 1797 /*[4.4-1]*/ 1798 off = file_desc_1.alt_key.offset (key_num) + 1; /*[4.4-1]*/ 1799 sz = file_desc_1.alt_key.size (key_num); 1800 1801 /*[4.4-1]*/ 1802 sz_abs = abs (sz); 1803 1804 end; /*[4.4-1]*/ 1805 declare key_comp bit (1); 1806 keys_unequal: 1807 proc; 1808 1809 /*[4.4-1]*/ 1810 if substr (rs_record_buffer, off, sz_abs) ^= substr (file_record_buffer, off, sz_abs) 1811 /*[4.4-1]*/ 1812 then do; 1813 key_comp = "1"b; 1814 key_status (key_num) = "1"b; 1815 end; /*[4.4-1]*/ 1816 else key_comp = "0"b; 1817 1818 end; 1819 1820 process_key: 1821 proc (loc); /* add_key, delete_key, get_key */ 1822 /*[4.4-1]*/ 1823 declare loc ptr; 1824 1825 /*[4.4-1]*/ 1826 call form_alt_key (loc); /*[4.4-1]*/ 1827 call iox_$control (fsb.iocb_ptr, key_op, info_ptr, MCODE); 1828 1829 end; 1830 1831 form_alt_key: 1832 proc (rec_ptr); 1833 1834 /*[4.4-1]*/ 1835 declare rec_ptr ptr; /*[4.4-1]*/ 1836 declare alt_key_num char (1); 1837 1838 /*[4.4-1]*/ 1839 declare key_len fixed bin based (key_len_ptr);/*[4.4-1]*/ 1840 declare key char (256) based (key_ptr); /*[4.4-1]*/ 1841 declare record char (1000000) based (rec_ptr); 1842 1843 /*[4.4-1]*/ 1844 key_len = sz_abs + 1; /*[4.4-1]*/ 1845 unspec (alt_key_num) = substr (unspec (key_num), 28, 9); 1846 1847 /*[4.4-1]*/ 1848 substr (key, 1, key_len) = alt_key_num || substr (record, off, key_len); 1849 1850 end; 1851 1852 set_up: 1853 proc; 1854 1855 /*[4.4-1]*/ 1856 fsb_ptr = alt_stack_hdr.fsb_ptr; /*[4.4-1]*/ 1857 if fsb.fsb_skel.mod1 then 1858 file_desc_1_ptr = fsb.file_desc_ptr; 1859 else if unspec (fsb.file_desc_ptr) = (2) "040040040040"b3 then /* pre [5.3-1] initialization */ 1860 file_desc_1_ptr = null (); 1861 else file_desc_1_ptr = fsb.file_desc_ptr; 1862 1863 1864 1865 end; 1866 1867 rec_status: 1868 proc; 1869 1870 /*[4.4-1]*/ 1871 call init_rs_info; /*[4.4-1]*/ 1872 call iox_$control (fsb.iocb_ptr, "record_status", rs_info_ptr, MCODE); 1873 1874 end; 1875 1876 1877 1878 1879 /* ******************************* 1880* * * 1881* * delete * 1882* * * 1883* *******************************/ 1884 1885 rts (53): /* OP86(delete) */ 1886 /*[4.4-1]*/ 1887 call set_up; 1888 1889 fsb.last_cobol_op = 7; 1890 1891 return; 1892 1893 1894 1895 1896 /* ******************************* 1897* * * 1898* * make key read * 1899* * * 1900* *******************************/ 1901 1902 rts (54): /* OP82(start) */ 1903 mode = 0; 1904 1905 rts54: /*[4.4-1]*/ 1906 call set_up; 1907 1908 unspec (char1) = substr (unspec (alt_stack_hdr.key_of_ref), 28, 9); 1909 call make_key (char1, mode); 1910 1911 KEY_OF_REF = alt_stack_hdr.key_of_ref; 1912 return; 1913 1914 1915 1916 1917 1918 /* ******************************* 1919* * * 1920* * make key write * 1921* * * 1922* *******************************/ 1923 1924 1925 rts (55): /* OP85(delete,rewrite) */ 1926 /*[4.4-1]*/ 1927 call set_up; 1928 1929 unspec (char1) = "111111111"b; 1930 1931 call save_NRP; 1932 1933 /*[4.0-3]*/ 1934 call make_key (char1, 1); 1935 1936 return; 1937 1938 1939 1940 /* ******************************* 1941* * * 1942* * add keys * 1943* * * 1944* *******************************/ 1945 1946 rts (56): /* OP90(write) */ 1947 /*[4.4-1]*/ 1948 call set_up; 1949 1950 buff_ptr = alt_stack_hdr.file_rec_buf_ptr; 1951 1952 if fsb.cobol_open_mode = 61 1953 then fsb.crp.prime_key = substr (fsb.key, 1, fsb.keylen_sw); 1954 1955 /*[4.4-1]*/ 1956 call init_ak_info ("add_key"); 1957 1958 /*[4.4-1]*/ 1959 do key_num = 1 by 1 to file_desc_1.alt_key_count; 1960 1961 /*[4.4-1]*/ 1962 call set_off_sz; 1963 1964 /*[4.4-1]*/ 1965 call process_key (buff_ptr); 1966 1967 /*[4.4-1]*/ 1968 end; 1969 1970 fsb.last_cobol_op = 8; /* write */ 1971 return; 1972 1973 1974 1975 1976 /* ******************************* 1977* * * 1978* * read restore * 1979* * * 1980* *******************************/ 1981 1982 rts (57): /* OP92(read) */ 1983 /*[4.4-1]*/ 1984 call set_up; 1985 1986 rs_info_ptr = addr (status_info); 1987 1988 if fsb.last_cobol_op = 6 | /* rewrite */ fsb.last_cobol_op = 7 | /* delete */ fsb.last_cobol_op = 8 1989 /* write */ 1990 then call restore_NRP; 1991 1992 /*[5.1-1]*/ 1993 if MCODE ^= 0 1994 then return; 1995 call iox_$read_key (fsb.iocb_ptr, READ_KEY, REC_LEN, CODE); 1996 1997 /*[5.1-1]*/ 1998 if CODE ^= 0 /*[5.1-1]*/ 1999 then MCODE = CODE; /*[5.1-1]*/ 2000 else call eof_test (addr (READ_KEY)); 2001 2002 /*[5.1-1]*/ 2003 return; 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 /* 2015* 2016* 2017* 2018* 2019* 2020*/* ******************************* 2021* * * 2022* * rewrite add keys * 2023* * * 2024* *******************************/ 2025 2026 rts (58): /* OP88(rewrite) */ 2027 /*[4.4-1]*/ 2028 call set_up; 2029 buff_ptr = alt_stack_hdr.file_rec_buf_ptr; /*[4.4-1]*/ 2030 call rec_status; 2031 2032 if MCODE ^= 0 2033 then return; 2034 2035 /*[4.4-1]*/ 2036 call init_ak_info ("add_key"); 2037 2038 /*[4.4-1]*/ 2039 do key_num = 1 by 1 to file_desc_1.alt_key_count; 2040 2041 /*[4.4-1]*/ 2042 call set_off_sz; 2043 2044 /*[4.4-1]*/ 2045 if key_status (key_num) 2046 then call process_key (buff_ptr); 2047 2048 /*[4.4-1]*/ 2049 end; 2050 2051 fsb.last_cobol_op = 6; /* rewrite */ 2052 2053 return; 2054 2055 rts (59): /* OP84(read) */ 2056 mode = 1; 2057 2058 go to rts54; 2059 2060 2061 /*[4.0-2]*/ 2062 rts (60): 2063 dcl rlen fixed bin (21, 0); 2064 dcl new_key char (256) varying; 2065 2066 call iox_$control (control_iocb_ptr, order_name, iox_control_stack.control_ptr, mcode); 2067 2068 if mcode = 0 2069 then call iox_$read_key (control_iocb_ptr, new_key, rlen, mcode); 2070 2071 if mcode ^= 0 2072 then do; 2073 if mcode = error_table_$no_record 2074 then do; 2075 error_block.status12 = "23"; 2076 error_block.status3 = "6723"; /*[4.0-1] */ 2077 icode = 4; 2078 end; 2079 else do; 2080 error_block.status12 = "30"; 2081 error_block.status3 = "6732"; 2082 end; 2083 return; 2084 end; 2085 2086 2087 if substr (struc.key, 1, 1) ^= substr (new_key, 1, 1) 2088 then do; 2089 mcode = error_table_$no_record; 2090 error_block.status12 = "23"; 2091 error_block.status3 = "6723"; 2092 end; 2093 2094 return; 2095 2096 rts (63): /* OP65(read) */ 2097 /*[5.3-1]*/ 2098 call set_up; 2099 2100 /*[5.3-1]*/ 2101 BUFF_PTR = alt_stack_hdr.arg2_ptr -> temp_ptr; 2102 2103 /*[5.3-1]*/ 2104 call iox_$read_record /*[5.3-1]*/ (alt_stack_hdr.fsb_ptr -> temp_ptr, 2105 /* iocb ptr */ 2106 /*[5.3-1]*/ 2107 BUFF_PTR, /* buffer ptr */ 2108 /*[5.3-1]*/ 2109 alt_stack_hdr.arg3_ptr -> BUFF_LEN, /* buffer length */ 2110 /*[5.3-1]*/ 2111 alt_stack_hdr.arg4_ptr -> REC_LGT, /* record length */ 2112 /*[5.3-1]*/ 2113 alt_stack_hdr.arg5_ptr -> MCODE /* error code */ /*[5.3-1]*/); 2114 2115 /*[5.3-1]*/ 2116 if ^fsb.fsb_skel.mod1 | alt_stack_hdr.arg5_ptr -> MCODE ^= 0 2117 then return; /*[5.3-1]*/ 2118 if fsb.cobol_open_mode = 45 /*[5.3-1]*/ 2119 then fsb.last_key_read /*[5.3-1]*/ = substr (BUFF_PTR -> file_record_buffer, 2120 /*[5.3-1]*/ 2121 file_desc_1.prime_key.offset + 1, /*[5.3-1]*/ 2122 file_desc_1.prime_key.size /*[5.3-1]*/); 2123 2124 /*[5.3-1]*/ 2125 return; 2126 2127 rts (64): /* OP59(rewrite) */ 2128 /*[5.3-1]*/ 2129 call set_up; 2130 2131 /*[5.3-1]*/ 2132 if fsb.cobol_open_mode = 45 /* i/o,ind,seq */ 2133 /*[5.3-1]*/ 2134 then do; 2135 if fsb.last_cobol_op ^= 4 /* must be read */ 2136 /*[5.3-1]*/ 2137 then do; 2138 error_block.status12 = "30"; /*[5.3-1]*/ 2139 error_block.status3 = "5033"; 2140 2141 /*[5.3-1]*/ 2142 return; /*[5.3-1]*/ 2143 end; 2144 2145 /*[5.3-1]*/ 2146 BUFF_PTR = alt_stack_hdr.arg2_ptr -> temp_ptr; 2147 2148 /*[5.3-1]*/ 2149 if fsb.fsb_skel.mod1 then /*[5.3-1]*/ 2150 if /*[5.3-1]*/ fsb.last_key_read /*[5.3-1]*/ 2151 ^= substr /*[5.3-1]*/ (BUFF_PTR -> file_record_buffer, 2152 /*[5.3-1]*/ 2153 file_desc_1.prime_key.offset + 1, /*[5.3-1]*/ 2154 file_desc_1.prime_key.size /*[5.3-1]*/) 2155 /*[5.3-1]*/ 2156 then do; 2157 error_block.status12 = "30"; /*[5.3-1]*/ 2158 error_block.status3 = "5024"; 2159 2160 /*[5.3-1]*/ 2161 alt_stack_hdr.arg5_ptr -> MCODE = error_table_$no_record; 2162 2163 /*[5.3-1]*/ 2164 return; /*[5.3-1]*/ 2165 end; /*[5.3-1]*/ 2166 end; 2167 2168 /*[5.3-1]*/ 2169 call iox_$rewrite_record /*[5.3-1]*/ (alt_stack_hdr.fsb_ptr -> temp_ptr, 2170 /* iocb ptr */ 2171 /*[5.3-1]*/ 2172 BUFF_PTR, /* buffer ptr */ 2173 /*[5.3-1]*/ 2174 alt_stack_hdr.arg3_ptr -> REC_LGT, /* record length */ 2175 /*[5.3-1]*/ 2176 alt_stack_hdr.arg4_ptr -> MCODE /* error code */ /*[5.3-1]*/); 2177 2178 /*[5.3-1]*/ 2179 return; 2180 2181 2182 2183 /* *******************************************************************************************/ 2184 2185 /* ALTERNATE RECORD KEY PACKAGE INTERNAL SUBROUTINES */ 2186 2187 /* *******************************************************************************************/ 2188 2189 /*[5.1-1]*/ 2190 dcl res bit (1); 2191 2192 make_key: 2193 proc (char1, mode); 2194 2195 dcl p ptr, 2196 mode fixed bin, 2197 char1 char (1); 2198 2199 dcl 1 SEEK_KEY based (p), 2200 2 rel fixed bin, 2201 2 n fixed bin, 2202 2 seek_key char (256); 2203 2204 declare 1 SK based (p), 2205 2 n fixed bin, 2206 2 seek_key char (256); 2207 2208 p = alt_stack_hdr.iocb_ptr; 2209 2210 if mode = 0 2211 then do; 2212 substr (SEEK_KEY.seek_key, 1, SEEK_KEY.n + 1) = char1 || substr (SEEK_KEY.seek_key, 1, SEEK_KEY.n); 2213 SEEK_KEY.n = SEEK_KEY.n + 1; 2214 end; 2215 else do; 2216 substr (SK.seek_key, 1, SK.n + 1) = char1 || substr (SK.seek_key, 1, SK.n); 2217 SK.n = SK.n + 1; 2218 end; 2219 2220 end make_key; 2221 2222 2223 /*[4.4-1]*/ 2224 declare read_key_key char (256) varying; 2225 2226 save_NRP: 2227 proc; 2228 2229 2230 if (fsb.cobol_open_mode = 45 | /* i-o(seq) */ fsb.cobol_open_mode = 46 2231 | /* i-o(ran) */ fsb.cobol_open_mode = 47 /* i-o(dyn ) */) 2232 & 2233 /*[5.1-1]*/ (fsb.last_cobol_op = 1 | /* open */ fsb.last_cobol_op = 3 | /* start */ fsb.last_cobol_op = 4 2234 | /* read next */ fsb.last_cobol_op = 5 /* read key */ /*[5.1-1]*/) 2235 then do; /* save the keys for the next record */ 2236 call iox_$read_key (fsb.iocb_ptr, read_key_key, rec_len, MCODE); 2237 save_sw = "1"b; 2238 2239 if MCODE = error_table_$end_of_info 2240 then fsb.crp.prime_key = ""; 2241 else if MCODE = error_table_$no_record 2242 then fsb.crp.prime_key = ""; 2243 else do; 2244 2245 /*[5.1-1]*/ 2246 call eof_test (addr (read_key_key)); 2247 /*[5.1-1]*/ 2248 if MCODE ^= 0 /*[5.1-1]*/ 2249 then do; 2250 fsb.crp.prime_key = ""; 2251 /*[5.1-1]*/ 2252 return; /*[5.1-1]*/ 2253 end; 2254 2255 /*[4.4-1]*/ 2256 call rec_status; /*[4.4-1]*/ 2257 if MCODE ^= 0 2258 then return; 2259 2260 fsb.crp.prime_key = 2261 substr (rs_record_buffer, (file_desc_1.prime_key.offset + 1), 2262 file_desc_1.prime_key.size); 2263 2264 /*[4.4-1]*/ 2265 key_num = fsb.key_of_ref; 2266 call set_off_sz; 2267 2268 /*[4.4-1]*/ 2269 if key_num ^= 511 2270 then do; 2271 2272 fsb.crp.alt_key = substr (rs_record_buffer, 2273 /*[4.4-1]*/ 2274 off, /*[4.4-1]*/ 2275 sz_abs); 2276 2277 end; 2278 2279 fsb.crp.descriptor = rs_info.descriptor; 2280 end; 2281 2282 end; 2283 2284 end save_NRP; 2285 2286 restore_NRP: 2287 proc; 2288 2289 declare key_len fixed bin, 2290 key_ptr ptr; /*[4.0-3]*/ 2291 declare key_string char (512) varying based (key_ptr); 2292 2293 if fsb.crp.prime_key = "" 2294 then do; 2295 MCODE = error_table_$end_of_info; 2296 return; 2297 end; 2298 2299 if fsb.key_of_ref = 511 2300 then do; 2301 key_len = length (fsb.prime_key) + 1; 2302 key_ptr = addr (fsb.prime_key); 2303 end; 2304 else do; 2305 key_len = length (fsb.alt_key) + 1; 2306 key_ptr = addr (fsb.alt_key); 2307 end; 2308 2309 unspec (char1) = substr (unspec (fsb.key_of_ref), 28, 9); 2310 2311 /*[5.1-1]*/ 2312 if fsb.key_of_ref = 511 /* prime key */ /*[5.1-1]*/ | /*[5.1-1]*/ file_desc_1.alt_key.size (fsb.key_of_ref) >= 0 2313 /* dupl illeg */ 2314 /*[5.1-1]*/ 2315 then res = "1"b; /*[5.1-1]*/ 2316 else res = "0"b; 2317 2318 /*[5.1-1]*/ 2319 if res /*[5.1-1]*/ 2320 then do; 2321 2322 call init_gk_info; 2323 2324 gk_info.header.descrip = fsb.crp.descriptor; 2325 gk_info.header.key_len = key_len + 1; 2326 gk_info.key = char1 || substr (key_string, 1, key_len); 2327 2328 2329 gk_info.flags.position_specification.head_size = gk_info.header.key_len; 2330 2331 call iox_$control (fsb.iocb_ptr, "get_key", gk_info_ptr, MCODE); 2332 2333 if MCODE = 0 2334 then return; 2335 2336 end; 2337 2338 seek_info.relation_type = 1; /* >= */ 2339 seek_info.n = key_len + 1; 2340 seek_info.search_key = char1 || substr (key_string, 1, key_len); 2341 2342 /*[5.1-1]*/ 2343 call iox_sh; 2344 2345 if MCODE ^= 0 2346 then do; 2347 MCODE = error_table_$end_of_info; 2348 return; 2349 end; 2350 2351 if res 2352 then return; 2353 2354 /*[4.4-1]*/ 2355 call rec_status; 2356 2357 /*[5.1-1]*/ 2358 if MCODE ^= 0 2359 then return; 2360 2361 2362 2363 2364 2365 /*[5.1-1]*/ 2366 call key_compare; 2367 2368 /*[5.1-1]*/ 2369 if res 2370 then return; 2371 2372 2373 i = 1; 2374 2375 do while ("1"b); 2376 2377 /*[5.1-1]*/ 2378 call iox_rr; 2379 2380 if MCODE = error_table_$long_record 2381 then MCODE = 0; 2382 else if MCODE ^= 0 2383 then return; 2384 2385 /*[4.4-1]*/ 2386 call rec_status; 2387 2388 if MCODE ^= 0 2389 then return; 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 /*[5.1-1]*/ 2401 call key_compare; 2402 2403 /*[5.1-1]*/ 2404 if res 2405 then do; 2406 2407 /*[5.1-1]*/ 2408 call iox_sh; 2409 2410 if MCODE ^= 0 2411 then return; 2412 2413 2414 do j = 1 to i - 1 by 1; 2415 2416 /*[5.1-1]*/ 2417 call iox_rr; 2418 2419 2420 if MCODE = error_table_$long_record 2421 then MCODE = 0; 2422 else if MCODE ^= 0 2423 then return; 2424 2425 end; 2426 2427 return; 2428 2429 end; 2430 2431 i = i + 1; 2432 2433 end; 2434 2435 end restore_NRP; 2436 2437 2438 2439 2440 init_rs_info: 2441 proc; /* record_status */ 2442 /*[4.4-1]*/ 2443 rs_info_ptr = addr (status_info); 2444 2445 rs_info.version = rs_info_version_2; 2446 rs_info.lock_sw = "0"b; 2447 rs_info.unlock_sw = "0"b; 2448 rs_info.create_sw = "0"b; 2449 rs_info.locate_sw = "0"b; 2450 rs_info.inc_ref_count = "0"b; 2451 rs_info.dec_ref_count = "0"b; 2452 rs_info.locate_pos_sw = "0"b; 2453 rs_info.mbz1 = "0"b; 2454 rs_info.mbz2 = 0; 2455 rs_info.descriptor = 0; 2456 2457 end init_rs_info; 2458 2459 init_gk_info: 2460 proc; 2461 2462 /*[4.4-1]*/ 2463 gk_info_ptr = addr (GK_INFO); 2464 2465 /*[4.4-1]*/ 2466 key_len_ptr = addr (gk_info.header.key_len); /*[4.4-1]*/ 2467 key_ptr = addr (gk_info.key); /*[4.4-1]*/ 2468 key_op = "get_key"; /*[4.4-1]*/ 2469 info_ptr = gk_info_ptr; 2470 2471 gk_info.header.flags.input_key = "1"b; 2472 gk_info.header.flags.input_desc = "1"b; 2473 gk_info.header.version = gk_info_version_0; 2474 gk_info.header.flags.position_specification.rel_type = 0; 2475 /* = */ 2476 gk_info.header.flags.reset_pos = "0"b; 2477 gk_info.header.pad = "0"b; 2478 2479 end; 2480 2481 init_ak_info: 2482 proc (op); /* add_key, delete_key */ 2483 /*[4.4-1]*/ 2484 declare op char (*); 2485 2486 /*[4.4-1]*/ 2487 ak_info_ptr = addr (AK_INFO); 2488 2489 /*[4.4-1]*/ 2490 key_len_ptr = addr (ak_info.header.key_len); /*[4.4-1]*/ 2491 key_ptr = addr (ak_info.key); /*[4.4-1]*/ 2492 key_op = op; /*[4.4-1]*/ 2493 info_ptr = ak_info_ptr; 2494 2495 /*[4.4-1]*/ 2496 ak_info.header.input_key = "1"b; /*[4.4-1]*/ 2497 ak_info.header.descrip = 0b; /*[4.4-1]*/ 2498 ak_info.header.mbz = "0"b; 2499 2500 end; 2501 2502 key_compare: 2503 proc; 2504 2505 /*[5.1-1]*/ 2506 if substr /*[5.1-1]*/ (rs_record_buffer, /*[5.1-1]*/ 2507 file_desc_1.alt_key.offset (fsb.key_of_ref) + 1, 2508 /*[5.1-1]*/ 2509 abs (file_desc_1.alt_key.size (fsb.key_of_ref)) /*[5.1-1]*/) /*[5.1-1]*/ ^= fsb.crp.alt_key /*[5.1-1]*/ 2510 | /*[5.1-1]*/ substr /*[5.1-1]*/ (rs_record_buffer, 2511 /*[5.1-1]*/ 2512 file_desc_1.prime_key.offset + 1, /*[5.1-1]*/ 2513 file_desc_1.prime_key.size /*[5.1-1]*/) /*[5.1-1]*/ = fsb.crp.prime_key 2514 /*[5.1-1]*/ 2515 then res = "1"b; /*[5.1-1]*/ 2516 else res = "0"b; 2517 2518 end; 2519 2520 iox_sh: 2521 proc; 2522 2523 /*[5.1-1]*/ 2524 call iox_$control (fsb.iocb_ptr, "seek_head", addr (seek_info), MCODE); 2525 2526 end; 2527 2528 iox_rr: 2529 proc; 2530 2531 /*[5.1-1]*/ 2532 call iox_$read_record (fsb.iocb_ptr, addr (dummy_buffer), 1, rec_len, MCODE); 2533 2534 end; 2535 2536 eof_test: 2537 proc (key_loc); 2538 2539 /*[5.1-1]*/ 2540 dcl key_loc ptr; /*[5.1-1]*/ 2541 dcl key_str char (256) varying based (key_loc); 2542 2543 /*[5.1-1]*/ 2544 KEY_NUM = 0; /*[5.1-1]*/ 2545 substr (unspec (KEY_NUM), 28, 9) = unspec (substr (key_str, 1, 1)); 2546 2547 /*[5.1-1]*/ 2548 if KEY_NUM ^= fsb.key_of_ref 2549 then MCODE = error_table_$end_of_info; 2550 else MCODE = 0; 2551 2552 end; 2553 2554 2555 2556 /* Please insert the next run time package before this line. */ 2557 2558 2559 2560 2561 2562 /* EXTERNAL_NAMES */ 2563 2564 dcl iox_$user_input ptr ext; 2565 2566 2567 dcl cobol_error_ entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (*), ptr); 2568 dcl cobol_error_$use entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (*), ptr); 2569 dcl cobol_control_$cobol_rts_control_ 2570 entry (ptr); 2571 2572 dcl sort_$initiate entry (char (*), ptr, ptr, char (*), float bin (27), fixed bin (35)); 2573 dcl sort_$noexit entry ext; 2574 2575 2576 dcl error_table_$end_of_info 2577 fixed bin (35) ext; 2578 dcl error_table_$key_duplication 2579 fixed bin (35) ext; 2580 dcl error_table_$long_record 2581 fixed bin (35) ext; 2582 dcl error_table_$short_record 2583 fixed bin (35) ext; 2584 dcl error_table_$no_record 2585 fixed bin (35) external; 2586 dcl error_table_$key_order 2587 fixed bin (35) external; 2588 dcl error_table_$incompatible_attach 2589 fixed bin (35) external; 2590 dcl error_table_$noentry 2591 fixed bin (35) external; 2592 dcl error_table_$file_busy 2593 fixed bin (35) external; 2594 dcl error_table_$no_operation 2595 fixed bin (35) external; 2596 dcl error_table_$bad_file 2597 fixed bin (35) external; 2598 2599 dcl sort_$return entry (ptr, fixed bin (21), fixed bin (35)); 2600 2601 dcl sort_$terminate entry (fixed bin (35)); 2602 2603 dcl sort_$commence entry (fixed bin (35)); 2604 2605 dcl cu_$cl entry; 2606 2607 dcl cobol_stop_run_ entry (ptr, fixed bin, fixed bin, fixed bin), 2608 signal_ entry (char (*), ptr, ptr); 2609 declare iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); 2610 declare iox_$control entry (ptr, char (*), ptr, fixed bin (35)); 2611 declare iox_$find_iocb entry (char (*), ptr, fixed bin (35)); 2612 declare iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 2613 declare iox_$read_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); 2614 declare iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 2615 declare iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); 2616 declare iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); 2617 2618 dcl cobol_control_$cancel 2619 entry (char (*), fixed bin, fixed bin, fixed bin); 2620 2621 2622 dcl clock_ entry returns (fixed bin (71)), 2623 date_time_ entry (fixed bin (71), char (*)), 2624 decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, 2625 char (3) aligned); 2626 2627 dcl cobol_su_$tally entry (ptr, fixed bin), 2628 cobol_su_$replace entry (ptr); 2629 2630 dcl hcs_$terminate_name entry (char (*), fixed bin (35)); 2631 dcl get_pdir_ entry returns (char (168)); 2632 dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); 2633 dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); 2634 2635 dcl cobol_mcs_$receive entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35)), 2636 cobol_mcs_$receive_wait 2637 entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35)); 2638 2639 dcl cmcs_error_table_$no_message 2640 fixed bin (35) ext; 2641 2642 dcl cobol_mcs_$accept entry (ptr, fixed bin (35)); 2643 2644 dcl cobol_mcs_$purge entry (ptr, fixed bin (35)); 2645 2646 dcl cobol_mcs_$send entry (ptr, ptr, char (4), char (1), bit (36), fixed bin (35)); 2647 2648 dcl cobol_mcs_$enable_input_terminal 2649 entry (ptr, char (*), fixed bin (35)), 2650 cobol_mcs_$enable_input_queue 2651 entry (ptr, char (*), fixed bin (35)), 2652 cobol_mcs_$enable_output 2653 entry (ptr, char (*), fixed bin (35)); 2654 2655 2656 dcl cobol_mcs_$disable_input_terminal 2657 entry (ptr, char (*), fixed bin (35)), 2658 cobol_mcs_$disable_input_queue 2659 entry (ptr, char (*), fixed bin (35)), 2660 cobol_mcs_$disable_output 2661 entry (ptr, char (*), fixed bin (35)); 2662 2663 /* BUILTIN FUNCTIONS */ 2664 2665 dcl (substr, mod, abs, addr, addrel, length, string, unspec, null, index) 2666 builtin; 2667 1 1 1 2 /* BEGIN INCLUDE FILE ... cobol_stack_frame.incl.pl1 */ 1 3 /* Last modified on Apr 27, 1976 by BC */ 1 4 /* Last modified on Jan 1, 1975 by ORN */ 1 5 1 6 dcl stack_frame_ptr ptr; 1 7 dcl 1 stack_frame based(stack_frame_ptr) aligned, 1 8 2 pad1 (16) fixed bin, 1 9 2 prev_stack_frame_ptr ptr, 1 10 2 next_stack_frame_ptr ptr, 1 11 2 return_ptr ptr, 1 12 2 entry_ptr ptr, 1 13 2 operator_link_ptr ptr, 1 14 2 argument_ptr ptr, 1 15 2 reserved (2) fixed bin, 1 16 2 on_unit_rel_ptrs (2) bit(18) unaligned, 1 17 2 operator_return_offset bit(18), 1 18 2 pad2 (4) fixed bin, 1 19 2 link_ptr ptr, 1 20 2 pad3 (2) fixed bin, 1 21 2 scratch (24) fixed bin, 1 22 2 new_return_ptr ptr; 1 23 1 24 /* END INCLUDE FILE ... cobol_stack_frame.incl.pl1 */ 1 25 2668 2 1 2 2 /* BEGIN INCLUDE FILE ... cobol_control.incl.pl1 */ 2 3 /* Last modified May 5, 1977 by BC */ 2 4 2 5 dcl controlp ptr static init(null()); 2 6 dcl 1 control based(controlp) aligned, 2 7 2 sense_sw (8) fixed bin, 2 8 2 next_data_ptr ptr, /* not currently used - each program has own data segment for now */ 2 9 2 name char(65) aligned, /* name of the run-unit */ 2 10 2 flags bit(27) unaligned, 2 11 2 ind_mask bit(9) unaligned, 2 12 2 mpname char(65) varying aligned, /* name of the main program of the run-unit */ 2 13 2 fofl_handler_ptr ptr, /* a ptr to the entry pt of the cobol fixedoverflow handler cobol_fofl_handler_ */ 2 14 2 main_prog_ptr ptr, /* a ptr to the entry point of the main program - valid only if main_prog_sw^=0 */ 2 15 2 main_prog_sw fixed bin aligned, 2 16 2 sort_file_size float bin(27), 2 17 2 sort_dir_len fixed bin, 2 18 2 sort_dir char(168), 2 19 2 no_of_segs fixed bin, 2 20 2 statptr (0 refer(control.no_of_segs)) ptr; 2 21 2 22 /* END INCLUDE FILE ... cobol_control.incl.pl1 */ 2 23 2669 3 1 3 2 /* BEGIN INCLUDE FILE ... cobol_fixed_static.incl.pl1 */ 3 3 /* Last Modified May 5, 1977 by BC */ 3 4 3 5 /* This structure exists in the static data portion of the 3 6*linkage section of each cobol object segment. This 3 7*include file provides a "based" template for it. */ 3 8 3 9 /* This include file also contains internal static initialized 3 10*variables that define the offset of each field in this static 3 11*data portion of the linkage section from the 3 12*pointer upon which it is based. */ 3 13 3 14 3 15 /* WARNING: The fields in this structure,data_ptr 3 16*up to, but not including reserved, 3 17*must retain their positions in this structure forever. 3 18*No new fields not having space already allocated may be 3 19*defined as the position of the first link which follows 3 20*this fixed static area (to cobol_rts_) is in a fixed location 3 21*known to cobol_operators_. */ 3 22 dcl stat_ptr ptr; 3 23 dcl 1 stat based(stat_ptr) aligned, 3 24 2 data_ptr ptr aligned, 3 25 2 control_ptr ptr aligned, 3 26 2 file_info_ptr ptr aligned, 3 27 2 call_cnt fixed bin aligned, 3 28 2 data_len fixed bin aligned, 3 29 2 entry_pt_ptr ptr aligned, 3 30 2 prog_id_len fixed bin aligned, 3 31 2 prog_id char(65) aligned, 3 32 2 line_no (2) fixed bin aligned, 3 33 2 fo_flag fixed bin aligned, 3 34 2 fo_disp fixed bin aligned, 3 35 2 main_prog_sw fixed bin aligned, 3 36 2 sort_merge_sw fixed bin aligned, 3 37 2 ind_mask bit(36), /* overflow masking indicator bits. */ 3 38 2 pr3_save ptr, 3 39 2 pr5_save ptr, 3 40 2 user_output_ptr ptr, 3 41 2 error_output_ptr ptr, 3 42 2 user_input_ptr ptr, 3 43 2 error_con char(30) varying, 3 44 2 trace_control_word fixed bin aligned; 3 45 3 46 3 47 /* INTERNAL STATIC INITIALIZED VARIABLES THAT DEFINE THE 3 48*OFFSET OF EACH FIELD IN THE STATIC PORTION OF THE LINKAGE 3 49*SEGMENT. */ 3 50 3 51 dcl fixed_static_length fixed bin static options(constant) init(56); 3 52 dcl first_link_offset fixed bin static options(constant) init(64); 3 53 /*dcl stat_data_ptr_off fixed bin static options(constant) init(0); 3 54*/*dcl stat_control_ptr_off fixed bin static options(constant) init(2); 3 55*/*dcl stat_file_info_ptr_off fixed bin static options(constant) init(4); 3 56*/*dcl stat_call_cnt_off fixed bin static options(constant) init(6); 3 57*/*dcl stat_data_len_off fixed bin static options(constant) init(7); 3 58*/*dcl stat_entry_pt_ptr_off fixed bin static options(constant) init(8); 3 59*/*dcl stat_prog_id_len_off fixed bin static options(constant) init(10); 3 60*/*dcl stat_prog_id_off fixed bin static options(constant) init(11); 3 61*/*dcl stat_line_no_off fixed bin static options(constant) init(28); 3 62*/*dcl stat_fo_flag_off fixed bin static options(constant) init(30); 3 63*/*dcl stat_fo_disp_off fixed bin static options(constant) init(31); 3 64*/*dcl stat_main_prog_sw_off fixed bin static options(constant) init(32); 3 65*/*dcl stat_pr3_ptr_off fixed bin static options(constant) init(34); 3 66*/*dcl stat_pr5_ptr_off fixed bin static options(constant) init(36); 3 67*/*dcl stat_user_output_ptr_off fixed bin static options(constant) init(38); 3 68*/*dcl stat_error_output_ptr_off fixed bin static options(constant) init(40); 3 69*/*dcl stat_user_input_ptr_off fixed bin static options(constant) init(42); 3 70*/*dcl stat_error_con_off fixed bin static options(constant) init(44); 3 71*/*dcl stat_trace_control_word_off fixed bin static options(constant) init(53); 3 72*/**/ 3 73 3 74 /* END INCLUDE FILE ... cobol_fixed_static.incl.pl1 */ 3 75 2670 4 1 /* BEGIN INCLUDE FILE ... cobol_fsb_type_1.incl.pl1 */ 4 2 4 3 4 4 /****^ HISTORY COMMENTS: 4 5* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090), 4 6* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 4 7* MCR8090 cobol_fsb_type_1.incl.pl1 Disallow duplicate prime keys in Indexed 4 8* Sequential files. 4 9* END HISTORY COMMENTS */ 4 10 4 11 4 12 /* Modified on 12/14/84 by FCH, [5.3-1], BUG574, save last prime key read */ 4 13 /* Last Modified on Oct. 16, 1978 by FCH */ 4 14 4 15 4 16 dcl fsb_ptr ptr; 4 17 4 18 dcl 1 fsb based (fsb_ptr), 4 19 2 fsb_skel aligned like fsbskel, 4 20 2 key_of_ref fixed bin (35), 4 21 2 crp, 4 22 3 prime_key char (256) varying, 4 23 3 alt_key char (256) varying, 4 24 3 descriptor fixed bin (35), 4 25 2 last_key_read char (256) varying; /*[5.3-1]*/ 4 26 4 27 /* 4 28* 4 29*FIELD CONTENTS 4 30* 4 31*key_of_ref key of reference 4 32* 1 ,... ,510: alternate key 4 33* 511: prime key 4 34*crp current record pointer 4 35*prime_key value of prime key 4 36* "" designates end-of-file 4 37*alt_key value of key of reference 4 38*descriptor descriptor for key of reference 4 39*last_read_key value of the prime key in the last record read 4 40**/ 4 41 4 42 /* END INCLUDE FILE ... cobol_fsb_type_1.incl.pl1 */ 2671 5 1 5 2 /* BEGIN INCLUDE FILE ... cobol_fsbskel.incl.pl1 */ 5 3 5 4 5 5 /****^ HISTORY COMMENTS: 5 6* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090), 5 7* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 5 8* MCR8090 cobol_fsbskel.incl.pl1 Disallow duplicate prime keys in Indexed 5 9* Sequential files. 5 10* END HISTORY COMMENTS */ 5 11 5 12 5 13 /* Modified on 12/19/84 by FCH */ 5 14 /* Last Modified on Oct. 16, 1978 by FCH */ 5 15 5 16 dcl 1 fsbskel aligned based, 5 17 2 iocb_ptr ptr, 5 18 2 open_mode fixed bin (35), 5 19 2 max_cra_size fixed bin (35), 5 20 2 relkeylen fixed bin (35), 5 21 2 relkey fixed bin (35), 5 22 2 keylen_sw fixed bin (35), 5 23 2 key char (256) aligned, 5 24 2 open_close_name char (65) unal, 5 25 2 attach_flag bit (1) unal, /* only cobol_control seems to use this item */ 5 26 2 linage_counter char (8) aligned, 5 27 2 indicators, 5 28 3 optional bit (2), 5 29 3 opened bit (1), /* initialized to "" by 5.3 and previous versions */ 5 30 3 internal bit (1) unal, /* initialized to "" by 5.3 and previous versions */ 5 31 3 lock bit (1) unal, 5 32 3 mod1 bit (1) unal, 5 33 2 vfile_open_mode fixed bin (35), 5 34 2 file_desc_ptr ptr, 5 35 2 cobol_open_mode fixed bin (35), 5 36 2 last_cobol_op fixed bin (35), 5 37 2 code fixed bin (35); 5 38 5 39 /* 5 40* 5 41*FIELD CONTENTS 5 42* 5 43*iocb_ptr pointer to iocb, set by open 5 44*opened file opened at least once 5 45*internal 0 if external, 1 if internal 5 46*lock 0 if no lock, 1 if lock, reset by start of new 5 47* run unit 5 48*mod1 set to "1"b if the fsb contains the key of the 5 49* last record read from the file, present in 5.3 5 50* and subsequent versions 5 51*file_desc_ptr pointer to the file description 5 52*vfile_open_mode open mode established by iox_$open 5 53* 1,2,3 stream_(i o i-o) 5 54* 4,5,6,7 seq_(i o i-o u) 5 55* 8,9,10 k_s_(i o u) 5 56* 11,12,13 d_(i o u) 5 57*cobol_open_mode open mode established by open statement 5 58* 21 i, seq 5 59* 53 o, seq 5 60* 37 i-o, seq 5 61* 5 e, seq 5 62* 5 63* 25,26,27 i, rel(seq,ran,dyn) 5 64* 57,58,59 o, rel(seq,ran,dyn) 5 65* 41,42,43 i-o,rel(seq,ran,dyn) 5 66* 5 67* 29,30,31 i, ind(seq,ran,dyn) 5 68* 61,62,63 o, ind(seq,ran,dyn) 5 69* 45,46,47 i-o, ind(seq,ran,dyn) 5 70*last_cobol_op COBOL I/O statement last executed 5 71* 1 open 5 read key 5 72* 2 close 6 rewrite 5 73* 3 start 7 delete 5 74* 4 read next 8 write 5 75*code last vfile_ error code 5 76**/ 5 77 5 78 /* END INCLUDE FILE ... cobol_fsbskel.incl.pl1 */ 5 79 2672 6 1 /* BEGIN INCLUDE FILE ... cobol_file_desc_1.incl.pl1 */ 6 2 /* Last Modified on Oct. 14, 1978 by FCH */ 6 3 6 4 dcl file_desc_1_type fixed bin static init(1) options(constant); 6 5 dcl file_desc_1_ptr ptr; 6 6 6 7 dcl 1 file_desc_1 based(file_desc_1_ptr), 6 8 2 type fixed bin, 6 9 2 alt_key_count fixed bin, 6 10 2 prime_key, 6 11 3 offset fixed bin, 6 12 3 size fixed bin, 6 13 2 alt_key(0 refer(file_desc_1.alt_key_count)), 6 14 3 offset fixed bin, 6 15 3 size fixed bin; 6 16 6 17 /* 6 18* 6 19*FIELD CONTENTS 6 20* 6 21*type file type 6 22*alt_key_count alternate_key_count 6 23*prime key prime record key 6 24*alt_key alternate record keys 6 25*offset offset (in bytes) of key field in record 6 26*size size (in bytes) of key field in record 6 27* negative if duplicates legal 6 28* 6 29**/ 6 30 6 31 /* END INCLUDE FILE ... cobol_file_desc_1.incl.pl1 */ 2673 7 1 /* include file for info structure used with record_status control order 7 2* created by M. Asherman 1/6/76 */ 7 3 /* modified 6/15/77 to support stationary type records */ 7 4 7 5 dcl rs_info_ptr ptr; 7 6 dcl 1 rs_info based (rs_info_ptr) aligned, 7 7 2 version fixed, /* must be set to 1 or 2 (Input) */ 7 8 2 flags aligned, 7 9 3 lock_sw bit (1) unal, /* Input -- if ="1"b try to lock record */ 7 10 3 unlock_sw bit (1) unal, /* Input -- if ="1"b try to unlock record */ 7 11 3 create_sw bit (1) unal, /* Input--if set creat new record */ 7 12 3 locate_sw bit (1) unal, /* Input--if set causes current rec to be 7 13* located outside the index by descrip, or created without key */ 7 14 3 inc_ref_count bit (1) unal, /* Input--bump reference count of record, if stationary */ 7 15 3 dec_ref_count bit (1) unal, /* Input--decrement ref count if this flag set and record stationary */ 7 16 3 locate_pos_sw bit (1) unal, /* Input--if set the record_length is taken 7 17* as an input argument specifying the absolute logical record positioni to which both the current and next positions will be set */ 7 18 3 mbz1 bit (29) unal, /* must be set to "0"b, reserved for future use */ 7 19 2 record_length fixed (21), /* length in bytes, Input if create_sw set */ 7 20 2 max_rec_len fixed (21), /* max length of contained record 7 21* Input if create_sw is set--overrides min_block_size in effect */ 7 22 2 record_ptr ptr, /* points to first byte of record--will be word aligned */ 7 23 2 descriptor fixed (35), /* Input if locate_sw set and create_sw="0"b */ 7 24 2 ref_count fixed (34), /* Output--should match number of keys on this record-- = -1 if non-stationary record */ 7 25 2 time_last_modified fixed (71), /* Output */ 7 26 2 modifier fixed (35), /* Output--also Input when locking */ 7 27 2 block_ptr ptr unal, /* Output */ 7 28 2 last_image_modifier 7 29 fixed (35), 7 30 2 mbz2 fixed; 7 31 7 32 dcl 1 rs_desc based (addr (rs_info.descriptor)), 7 33 /* record block descriptor structure */ 7 34 2 comp_num fixed (17) unal, /* msf component number */ 7 35 2 offset bit (18) unal; /* word offset of record block */ 7 36 7 37 dcl 1 seq_desc based (addr (rs_info.descriptor)), 7 38 /* for sequential files */ 7 39 2 bitno bit (6) unal, 7 40 2 comp_num fixed (11) unal, /* msf component number */ 7 41 2 wordno bit (18) unal; /* word offset */ 7 42 7 43 dcl rs_info_version_1 static internal fixed init (1); 7 44 dcl rs_info_version_2 static internal fixed init (2); 7 45 2674 8 1 /* ak_info -- include file for info structures used by the following vfile_ 8 2* control orders: "add_key", "delete_key", "get_key", and "reassign_key". 8 3* Created by M. Asherman 3/23/76 8 4* Modified 5/13/77 to add separate gk_info structure */ 8 5 8 6 dcl 1 ak_info based (ak_info_ptr), 8 7 2 header like ak_header, 8 8 2 key char (ak_key_len refer (ak_info.header.key_len)); 8 9 8 10 dcl 1 ak_header based (ak_info_ptr), 8 11 2 flags aligned, 8 12 3 input_key bit (1) unal, /* set if key is input arg */ 8 13 3 input_desc bit (1) unal, /* set if descriptor is an input arg */ 8 14 3 mbz bit (34) unal, /* not used for the present */ 8 15 2 descrip fixed (35), /* record designator */ 8 16 2 key_len fixed; 8 17 8 18 dcl ak_info_ptr ptr; 8 19 dcl ak_key_len fixed; 8 20 8 21 8 22 dcl 1 rk_info based (rk_info_ptr), 8 23 2 header like rk_header, 8 24 2 key char (rk_key_len refer (rk_info.header.key_len)); 8 25 8 26 dcl 1 rk_header based (rk_info_ptr), 8 27 2 flags aligned, 8 28 3 input_key bit (1) unal, /* same as above */ 8 29 3 input_old_desc bit (1) unal, /* set if specified entry has initial descrip 8 30* given by old_descrip */ 8 31 3 input_new_desc bit (1) unal, /* set if new val for descrip is input in this struc */ 8 32 3 mbz bit (33) unal, 8 33 2 old_descrip fixed (35), /* used if first flag is set */ 8 34 2 new_descrip fixed (35), /* used only if second flag is set */ 8 35 2 key_len fixed; 8 36 8 37 dcl rk_info_ptr ptr; 8 38 dcl rk_key_len fixed; 8 39 8 40 8 41 dcl 1 gk_info based (gk_info_ptr), /* structure for get_key order */ 8 42 2 header like gk_header, 8 43 2 key char (gk_key_len refer (gk_info.header.key_len)); 8 44 /* may be Input as well as Output */ 8 45 8 46 dcl 1 gk_header based (gk_info_ptr), 8 47 2 flags aligned, 8 48 3 input_key bit (1) unal, /* if set, use key in this structure */ 8 49 3 input_desc bit (1) unal, /* if set, descriptor given in this structure */ 8 50 3 desc_code fixed (2) unal, /* 0=any, 1=current -- applies when input_desc="0"b */ 8 51 3 position_specification 8 52 unal, 8 53 4 current bit (1) unal, /* otherwise next */ 8 54 4 rel_type fixed (2) unal, /* as in seek_head, if input_key = "1"b */ 8 55 4 head_size fixed bin (9) unsigned unaligned, 8 56 /* size of head for initial seek */ 8 57 3 reset_pos bit (1) unal, /* if set, final position unchanged by this operation */ 8 58 3 pad bit (8) unal, 8 59 3 version fixed (8) unal, 8 60 2 descrip fixed (35), /* Output, except when input_desc="1"b */ 8 61 2 key_len fixed; /* Input when input_key="1"b, also Output in all cases */ 8 62 8 63 dcl gk_info_ptr ptr; 8 64 dcl gk_key_len fixed; 8 65 8 66 dcl gk_info_version_0 internal static fixed options (constant) init (0); 8 67 8 68 /* end ak_info.incl.pl1 */ 2675 2676 end cobol_rts_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/19/90 1655.1 cobol_rts_.pl1 >spec>install>1048>cobol_rts_.pl1 2668 1 03/27/82 0539.8 cobol_stack_frame.incl.pl1 >ldd>include>cobol_stack_frame.incl.pl1 2669 2 03/27/82 0539.3 cobol_control.incl.pl1 >ldd>include>cobol_control.incl.pl1 2670 3 10/10/83 1830.8 cobol_fixed_static.incl.pl1 >ldd>include>cobol_fixed_static.incl.pl1 2671 4 05/24/89 1159.1 cobol_fsb_type_1.incl.pl1 >ldd>include>cobol_fsb_type_1.incl.pl1 2672 5 05/24/89 1159.1 cobol_fsbskel.incl.pl1 >ldd>include>cobol_fsbskel.incl.pl1 2673 6 03/27/82 0539.4 cobol_file_desc_1.incl.pl1 >ldd>include>cobol_file_desc_1.incl.pl1 2674 7 07/19/79 1647.0 rs_info.incl.pl1 >ldd>include>rs_info.incl.pl1 2675 8 07/19/79 1647.0 ak_info.incl.pl1 >ldd>include>ak_info.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. AK_INFO 000461 automatic structure level 1 unaligned dcl 1489 set ref 2487 BUFF_LEN based fixed bin(21,0) dcl 1495 set ref 2104* BUFF_PTR 000564 automatic pointer dcl 1497 set ref 2101* 2104* 2118 2146* 2149 2169* CODE 000234 automatic fixed bin(35,0) dcl 1479 set ref 1995* 1998 1998 GK_INFO 000356 automatic structure level 1 unaligned dcl 1486 set ref 2463 KEY_NUM 000235 automatic fixed bin(35,0) dcl 1479 set ref 2544* 2545 2548 KEY_OF_REF 000022 internal static fixed bin(17,0) dcl 1478 set ref 1568 1604 1911* MCODE based fixed bin(35,0) dcl 1493 set ref 1530* 1630* 1651* 1653 1659* 1668* 1681 1691* 1711* 1729 1753 1755* 1827* 1872* 1993 1998* 2032 2104* 2116 2161* 2169* 2236* 2239 2241 2248 2257 2295* 2331* 2333 2345 2347* 2358 2380 2380* 2382 2388 2410 2420 2420* 2422 2524* 2532* 2548* 2550* READ_KEY 000237 automatic varying char(256) dcl 1481 set ref 1995* 2000 2000 REC_LEN 000236 automatic fixed bin(21,0) dcl 1480 set ref 1995* REC_LGT based fixed bin(21,0) dcl 1496 set ref 2104* 2169* SEEK_KEY based structure level 1 unaligned dcl 2199 SK based structure level 1 unaligned dcl 2204 abs builtin function dcl 2665 ref 1802 2506 accept_comm_stack based structure level 1 unaligned dcl 1294 actual_len 11 based fixed bin(21,0) level 2 dcl 640 set ref 849* 855* 857* addr builtin function dcl 2665 ref 828 1530 1530 1624 1625 1641 1642 1734 1986 2000 2000 2246 2246 2302 2306 2443 2463 2466 2467 2487 2490 2491 2524 2524 2532 2532 addrel builtin function dcl 2665 ref 540 541 555 557 ak_header based structure level 1 unaligned dcl 8-10 ak_info based structure level 1 unaligned dcl 8-6 ak_info_ptr 001122 automatic pointer dcl 8-18 set ref 2487* 2490 2491 2493 2496 2497 2498 alt_key 4 based structure array level 2 in structure "file_desc_1" unaligned dcl 6-7 in procedure "cobol_rts_" set ref 1625 1734 alt_key 245 based varying char(256) level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 2272* 2305 2306 2506 alt_key_count 1 based fixed bin(17,0) level 2 dcl 6-7 ref 1644 1700 1742 1768 1959 2039 alt_key_desc_ptr 000232 automatic pointer dcl 1476 set ref 1625* 1734* alt_key_num 001174 automatic char(1) packed unaligned dcl 1836 set ref 1845* 1848 alt_stack_hdr based structure level 1 unaligned dcl 1421 arg2_ptr 20 based pointer level 2 dcl 1421 ref 2101 2146 arg3_ptr 22 based pointer level 2 dcl 1421 ref 2104 2169 arg4_ptr 24 based pointer level 2 dcl 1421 ref 2104 2169 arg5_ptr 26 based pointer level 2 dcl 1421 ref 2104 2116 2161 atd 4 based char level 2 packed packed unaligned dcl 743 set ref 755* atdlen 2 based fixed bin(17,0) level 2 dcl 743 ref 755 755 attach_iocb_ptr based pointer dcl 750 set ref 755* attach_iocb_stack based structure level 1 unaligned dcl 743 buff_len 10 based fixed bin(21,0) level 2 dcl 640 set ref 849* buff_ptr 2 based pointer level 2 in structure "sort_return_stack" dcl 442 in procedure "cobol_rts_" set ref 453* buff_ptr 6 based pointer level 2 in structure "io_stack_hdr" dcl 640 in procedure "cobol_rts_" set ref 849* buff_ptr 000230 automatic pointer dcl 1476 in procedure "cobol_rts_" set ref 1623* 1650* 1733* 1752* 1810 1950* 1965* 2029* 2045* cancel_code 5 based fixed bin(17,0) level 2 dcl 580 set ref 589* cancel_name based char(65) packed unaligned dcl 587 ref 589 589 cancel_stack based structure level 1 unaligned dcl 580 char1 000224 automatic char(1) packed unaligned dcl 1470 in procedure "cobol_rts_" set ref 1527* 1528 1622* 1627 1665 1908* 1909* 1929* 1934* 2309* 2326 2340 char1 parameter char(1) packed unaligned dcl 2195 in procedure "make_key" ref 2192 2212 2216 clock_ 000150 constant entry external dcl 2622 ref 887 cmcs_error_table_$no_message 000176 external static fixed bin(35,0) dcl 2639 ref 1270 cmp_entry based structure level 1 unaligned dcl 1107 cobol_code 21 based fixed bin(17,0) level 2 dcl 308 set ref 328* 333* cobol_control_$cancel 000146 constant entry external dcl 2618 ref 589 cobol_control_$cobol_rts_control_ 000056 constant entry external dcl 2569 ref 355 cobol_error_ 000052 constant entry external dcl 2567 ref 328 cobol_error_$use 000054 constant entry external dcl 2568 ref 333 cobol_mcs_$accept 000200 constant entry external dcl 2642 ref 1302 cobol_mcs_$disable_input_queue 000216 constant entry external dcl 2656 ref 1399 cobol_mcs_$disable_input_terminal 000214 constant entry external dcl 2656 ref 1396 cobol_mcs_$disable_output 000220 constant entry external dcl 2656 ref 1402 cobol_mcs_$enable_input_queue 000210 constant entry external dcl 2648 ref 1386 cobol_mcs_$enable_input_terminal 000206 constant entry external dcl 2648 ref 1383 cobol_mcs_$enable_output 000212 constant entry external dcl 2648 ref 1389 cobol_mcs_$purge 000202 constant entry external dcl 2644 ref 1326 cobol_mcs_$receive 000172 constant entry external dcl 2635 ref 1268 cobol_mcs_$receive_wait 000174 constant entry external dcl 2635 ref 1278 cobol_mcs_$send 000204 constant entry external dcl 2646 ref 1354 cobol_mcs_$stop_run 000046 constant entry external dcl 551 ref 562 cobol_open_mode 12 based fixed bin(35,0) level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 1511 cobol_open_mode 140 based fixed bin(35,0) level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1511* 1520 1520 1520 1520 1520 1520 1604 1604 1604 1627 1685 1952 2118 2132 2230 2230 2230 cobol_stop_run_ 000122 constant entry external dcl 2607 ref 547 cobol_su_$replace 000160 constant entry external dcl 2627 ref 924 cobol_su_$tally 000156 constant entry external dcl 2627 ref 926 code 14 based fixed bin(35,0) level 2 in structure "receive_comm_stack" dcl 1251 in procedure "cobol_rts_" set ref 1268* 1270 1272* 1278* code 14 based fixed bin(35,0) level 2 in structure "enable_comm_stack" dcl 1367 in procedure "cobol_rts_" set ref 1383* 1386* 1389* 1396* 1399* 1402* code 14 based fixed bin(35,0) level 2 in structure "purge_comm_stack" dcl 1318 in procedure "cobol_rts_" set ref 1326* code 14 based fixed bin(35,0) level 2 in structure "send_comm_stack" dcl 1341 in procedure "cobol_rts_" set ref 1354* code 14 based fixed bin(35,0) level 2 in structure "accept_comm_stack" dcl 1294 in procedure "cobol_rts_" set ref 1302* comp_ptr 6 000010 internal static pointer level 2 dcl 1096 set ref 1137* 1215 comp_ptr_rts 16 based pointer level 2 dcl 1081 ref 1137 compare_code based fixed bin(17,0) level 2 dcl 1117 set ref 1215* 1217 1219 control based structure level 1 dcl 2-6 control_iocb_ptr based pointer dcl 615 set ref 619* 2066* 2068* control_ptr 2 based pointer level 2 in structure "stat" dcl 3-23 in procedure "cobol_rts_" ref 542 559 control_ptr 2 based pointer level 2 in structure "iox_control_stack" dcl 605 in procedure "cobol_rts_" set ref 619* 2066* 2087 control_ptr 4 based pointer level 2 in structure "sort_initiate_stack" dcl 372 in procedure "cobol_rts_" ref 392 control_stack based structure level 1 unaligned dcl 346 controlp 000042 internal static pointer initial dcl 2-5 set ref 392* 394 394 396 396 399 399 399 399 399 542* 544 559* 1138* 1142 1144 1145 1145 1148 1148 1148 1148 create_sw 1(02) based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2448* crp 144 based structure level 2 unaligned dcl 4-18 cu_$cl 000120 constant entry external dcl 2605 ref 523 d_array 000100 constant fixed bin(17,0) initial array dcl 883 ref 900 data_length 4 based fixed bin(21,0) level 2 dcl 414 set ref 428* data_ptr 2 based pointer level 2 dcl 414 set ref 428* date 20 based char(6) level 2 packed packed unaligned dcl 862 set ref 892* date_time 000110 automatic fixed bin(71,0) dcl 883 set ref 887* 891* 896* date_time_ 000152 constant entry external dcl 2622 ref 891 day_temp 000112 automatic char(8) packed unaligned dcl 883 set ref 891* 892 892 892 dec_ref_count 1(05) based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2451* decode_clock_value_ 000154 constant entry external dcl 2622 ref 896 descrip 1 based fixed bin(35,0) level 3 in structure "gk_info" dcl 8-41 in procedure "cobol_rts_" set ref 2324* descrip 1 based fixed bin(35,0) level 3 in structure "ak_info" dcl 8-6 in procedure "cobol_rts_" set ref 2497* descriptor 6 based fixed bin(35,0) level 2 in structure "rs_info" dcl 7-6 in procedure "cobol_rts_" set ref 2279 2455* descriptor 346 based fixed bin(35,0) level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 2279* 2324 dom 4 based fixed bin(17,0) level 2 dcl 862 set ref 896* 900 dow 12 based fixed bin(17,0) level 2 dcl 862 set ref 896* doy 16 based fixed bin(17,0) level 2 dcl 862 set ref 900* 902* 902 dummy_buffer 000223 automatic char(1) packed unaligned dcl 1469 set ref 2532 2532 enable_comm_stack based structure level 1 unaligned dcl 1367 end_indicator 7 based char(1) level 2 packed packed unaligned dcl 1341 set ref 1354* error_block based structure level 1 unaligned dcl 652 error_ptr 26 based pointer level 2 dcl 308 set ref 328* 333* error_stack based structure level 1 unaligned dcl 308 error_table_$bad_file 000110 external static fixed bin(35,0) dcl 2596 ref 678 704 error_table_$end_of_info 000064 external static fixed bin(35,0) dcl 2576 ref 456 822 956 1009 1041 2239 2295 2347 2548 error_table_$file_busy 000104 external static fixed bin(35,0) dcl 2592 ref 700 error_table_$incompatible_attach 000100 external static fixed bin(35,0) dcl 2588 ref 702 error_table_$key_duplication 000066 external static fixed bin(35,0) dcl 2578 ref 1659 1755 error_table_$key_order 000076 external static fixed bin(35,0) dcl 2586 ref 772 798 1630 error_table_$long_record 000070 external static fixed bin(35,0) dcl 2580 ref 853 853 1048 2380 2420 error_table_$no_operation 000106 external static fixed bin(35,0) dcl 2594 ref 676 698 786 970 1024 error_table_$no_record 000074 external static fixed bin(35,0) dcl 2584 ref 623 778 792 831 940 964 996 1691 2073 2089 2161 2241 error_table_$noentry 000102 external static fixed bin(35,0) dcl 2590 ref 706 error_table_$short_record 000072 external static fixed bin(35,0) dcl 2582 ref 989 exit_ptr 2 based pointer level 2 dcl 372 set ref 390 391 396* 399* exits based structure level 1 unaligned dcl 382 file_desc_1 based structure level 1 unaligned dcl 6-7 file_desc_1_ptr 001116 automatic pointer dcl 6-5 set ref 1509* 1625 1644 1653 1700 1734 1742 1768 1798 1799 1857* 1859* 1861* 1959 2039 2118 2118 2149 2149 2260 2260 2312 2506 2506 2506 2506 file_desc_ptr 136 based pointer level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1508* 1509 1857 1859 1861 file_desc_ptr 10 based pointer level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 1508 file_n 1 000010 internal static fixed bin(17,0) level 2 dcl 1096 set ref 1133* 1152 1165 1168 1181 1209 1215 1217 1219 file_n_rts 11 based fixed bin(17,0) level 2 dcl 1081 ref 1133 file_rec_buf_ptr 6 based pointer level 2 dcl 1421 ref 1623 1733 1950 2029 file_record_buffer based char(1000000) packed unaligned dcl 1466 ref 1810 2118 2149 find_iocb_ptr based pointer dcl 725 set ref 729* find_iocb_stack based structure level 1 unaligned dcl 718 flags based structure level 3 in structure "gk_info" dcl 8-41 in procedure "cobol_rts_" flags based structure level 3 in structure "ak_info" dcl 8-6 in procedure "cobol_rts_" flags 1 based structure level 2 in structure "rs_info" dcl 7-6 in procedure "cobol_rts_" fsb based structure level 1 unaligned dcl 4-18 fsb_ptr 001114 automatic pointer dcl 4-16 in procedure "cobol_rts_" set ref 1506* 1508 1509 1510 1511 1512 1514 1517 1517 1520 1520 1520 1520 1520 1520 1530 1548 1550 1550 1567 1568 1585 1602 1604 1604 1604 1604 1627 1627 1627 1627 1638 1651 1665 1665 1665 1666 1666 1685 1685 1827 1856* 1857 1857 1859 1861 1872 1889 1952 1952 1952 1952 1970 1988 1988 1988 1995 2051 2116 2118 2118 2132 2135 2149 2149 2230 2230 2230 2230 2230 2230 2230 2236 2239 2241 2250 2260 2265 2272 2279 2293 2299 2301 2302 2305 2306 2309 2312 2312 2324 2331 2506 2506 2506 2506 2524 2532 2548 fsb_ptr 16 based pointer level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 1506 1513 1856 2104 2169 fsb_ptr based pointer level 2 in structure "attach_iocb_stack" dcl 743 in procedure "cobol_rts_" ref 755 fsb_ptr based pointer level 2 in structure "find_iocb_stack" dcl 718 in procedure "cobol_rts_" ref 729 fsb_skel based structure level 2 dcl 4-18 fsbskel based structure level 1 dcl 5-16 get_pdir_ 000164 constant entry external dcl 2631 ref 1144 gk_header based structure level 1 unaligned dcl 8-46 gk_info based structure level 1 unaligned dcl 8-41 gk_info_ptr 001124 automatic pointer dcl 8-63 set ref 1738 2324 2325 2326 2329 2329 2331* 2463* 2466 2467 2469 2471 2472 2473 2474 2476 2477 gk_info_version_0 constant fixed bin(17,0) initial dcl 8-66 ref 2473 hcs_$make_seg 000166 constant entry external dcl 2632 ref 1148 hcs_$terminate_name 000162 constant entry external dcl 2630 ref 1140 hcs_$truncate_seg 000170 constant entry external dcl 2633 ref 1150 head_size 0(09) based fixed bin(9,0) level 5 packed packed unsigned unaligned dcl 8-41 set ref 2329* header based structure level 2 in structure "gk_info" unaligned dcl 8-41 in procedure "cobol_rts_" header based structure level 2 in structure "ak_info" unaligned dcl 8-6 in procedure "cobol_rts_" i 000114 automatic fixed bin(17,0) dcl 1123 in procedure "cobol_rts_" set ref 1152* 1153 1153* 1168* 1169* 1169* 1185* 1186 1187 1187 1189 1190* 1191* 2373* 2414 2431* 2431 i parameter fixed bin(17,0) dcl 1207 in procedure "merge_call_compare" ref 1201 1209 1210 1212 1215 1217 1221 1221 icode 1 based fixed bin(17,0) level 2 dcl 652 set ref 627* 774* 780* 962* 966* 1007* 1011* 1044* 2077* in_or_out 7 based fixed bin(17,0) level 2 dcl 1367 ref 1381 1393 inc_ref_count 1(04) based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2450* index builtin function dcl 2665 ref 1145 indicators 132 based structure level 3 dcl 4-18 info_ptr 000576 automatic pointer dcl 1785 set ref 1827* 2469* 2493* input_desc 0(01) based bit(1) level 4 packed packed unaligned dcl 8-41 set ref 2472* input_key based bit(1) level 4 in structure "gk_info" packed packed unaligned dcl 8-41 in procedure "cobol_rts_" set ref 2471* input_key based bit(1) level 4 in structure "ak_info" packed packed unaligned dcl 8-6 in procedure "cobol_rts_" set ref 2496* input_record 6 based entry variable level 2 dcl 382 set ref 390* inspect_stack based structure level 1 unaligned dcl 916 io_stack_hdr based structure level 1 unaligned dcl 640 iocb_ptr 2 based pointer level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 2208 iocb_ptr based pointer level 2 in structure "iox_control_stack" dcl 605 in procedure "cobol_rts_" ref 619 2066 2068 iocb_ptr based pointer level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1530* 1651* 1827* 1872* 1995* 2236* 2331* 2524* 2532* iox_$attach_ptr 000126 constant entry external dcl 2609 ref 755 iox_$control 000130 constant entry external dcl 2610 ref 619 1530 1827 1872 2066 2331 2524 iox_$find_iocb 000132 constant entry external dcl 2611 ref 729 iox_$get_line 000134 constant entry external dcl 2612 ref 849 855 iox_$read_key 000136 constant entry external dcl 2613 ref 1995 2068 2236 iox_$read_record 000140 constant entry external dcl 2614 ref 2104 2532 iox_$rewrite_record 000142 constant entry external dcl 2615 ref 2169 iox_$seek_key 000144 constant entry external dcl 2616 ref 1651 iox_$user_input 000050 external static pointer dcl 2564 set ref 849* 855* iox_control_stack based structure level 1 unaligned dcl 605 j 000115 automatic fixed bin(17,0) dcl 1123 in procedure "cobol_rts_" set ref 1187* 1189* 1190* 2414* j parameter fixed bin(17,0) dcl 1207 in procedure "merge_call_compare" ref 1201 1210 1212 1215 1219 1221 1223 k 000116 automatic fixed bin(17,0) dcl 1123 set ref 1181* 1183 1185 1186 key 2 based char level 2 in structure "struc" packed packed unaligned dcl 609 in procedure "cobol_rts_" ref 2087 key 7 based char(256) level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1627 1665* 1665 1952 key based char(256) packed unaligned dcl 1840 in procedure "form_alt_key" set ref 1848* key 3 based char level 2 in structure "ak_info" packed packed unaligned dcl 8-6 in procedure "cobol_rts_" set ref 2491 key 1 000603 automatic char(256) level 2 in structure "vfile_key" packed packed unaligned dcl 1790 in procedure "cobol_rts_" set ref 1642 1651 1651 key 3 based char level 2 in structure "gk_info" packed packed unaligned dcl 8-41 in procedure "cobol_rts_" set ref 2326* 2467 key_comp 000704 automatic bit(1) packed unaligned dcl 1805 set ref 1749 1813* 1816* key_len 2 based fixed bin(17,0) level 3 in structure "ak_info" dcl 8-6 in procedure "cobol_rts_" set ref 2490 2491 key_len 001236 automatic fixed bin(17,0) dcl 2289 in procedure "restore_NRP" set ref 2301* 2305* 2325 2326 2339 2340 key_len based fixed bin(17,0) dcl 1839 in procedure "form_alt_key" set ref 1844* 1848 1848 key_len 2 based fixed bin(17,0) level 3 in structure "gk_info" dcl 8-41 in procedure "cobol_rts_" set ref 2325* 2326 2329 2466 2467 key_len_ptr 000572 automatic pointer dcl 1785 set ref 1641* 1844 1848 1848 2466* 2490* key_loc parameter pointer dcl 2540 ref 2536 2545 key_num 000227 automatic fixed bin(35,0) dcl 1475 set ref 1644* 1653* 1700* 1742* 1768* 1774* 1798 1799 1814 1845 1959* 2039* 2045* 2265* 2269 key_of_ref 143 based fixed bin(35,0) level 2 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1513* 1568* 1604* 2265 2299 2309 2312 2312 2506 2506 2548 key_of_ref 15 based fixed bin(35,0) level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 1908 1911 key_op 000600 automatic char(10) packed unaligned dcl 1787 set ref 1827* 2468* 2492* key_ptr 001240 automatic pointer dcl 2289 in procedure "restore_NRP" set ref 2302* 2306* 2326 2340 key_ptr 000574 automatic pointer dcl 1785 in procedure "cobol_rts_" set ref 1642* 1848 2467* 2491* key_status 000023 internal static bit(1) array packed unaligned dcl 1498 set ref 1739* 1774 1814* 2045 key_str based varying char(256) dcl 2541 ref 2545 key_string based varying char(512) dcl 2291 ref 2326 2340 keylen 1 based fixed bin(17,0) level 2 dcl 609 ref 2087 keylen_sw 6 based fixed bin(35,0) level 3 dcl 4-18 set ref 1627 1665 1666* 1666 1952 last_cobol_op 141 based fixed bin(35,0) level 3 dcl 4-18 set ref 1512* 1548* 1567* 1585* 1602* 1685 1889* 1970* 1988 1988 1988 2051* 2135 2230 2230 2230 2230 last_key_read 347 based varying char(256) level 2 dcl 4-18 set ref 1517* 1550* 2118* 2149 length builtin function dcl 2665 ref 2301 2305 line_control 10 based bit(36) level 2 packed packed unaligned dcl 1341 set ref 1354* line_no1 24 based fixed bin(17,0) level 2 dcl 308 set ref 328* 333* line_no2 25 based fixed bin(17,0) level 2 dcl 308 set ref 328* 333* loc parameter pointer dcl 1823 set ref 1820 1826* locate_pos_sw 1(06) based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2452* locate_sw 1(03) based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2449* lock_sw 1 based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2446* main_prog_sw 62 based fixed bin(17,0) level 2 dcl 2-6 ref 544 max_meslen 6 based char(4) level 2 in structure "send_comm_stack" packed packed unaligned dcl 1341 in procedure "cobol_rts_" set ref 1354* max_meslen 7 based fixed bin(17,0) level 2 in structure "receive_comm_stack" dcl 1251 in procedure "cobol_rts_" set ref 1268* 1278* mbz 0(02) based bit(34) level 4 packed packed unaligned dcl 8-6 set ref 2498* mbz1 1(07) based bit(29) level 3 packed packed unaligned dcl 7-6 set ref 2453* mbz2 15 based fixed bin(17,0) level 2 dcl 7-6 set ref 2454* mcode based fixed bin(35,0) level 2 dcl 652 set ref 619* 621 623 676 678 698 700 702 704 706 729* 755* 772 778 786 792 796* 798 822 829* 831 849* 853 853 855* 940 945* 956 964 970 989 992* 996 1009 1024 1041 1048 2066* 2068 2068* 2071 2073 2089* mcode_ptr 4 based pointer level 2 in structure "io_stack_hdr" dcl 640 in procedure "cobol_rts_" ref 619 619 619 621 623 625 626 627 630 631 672 676 676 678 678 680 694 698 698 700 700 702 702 704 704 706 706 708 729 729 729 755 755 755 768 772 774 775 776 778 780 781 782 785 786 786 788 792 794 795 796 798 800 801 806 807 822 826 827 829 831 833 834 849 853 853 855 940 943 944 945 956 960 961 962 964 966 967 968 970 972 973 976 977 989 992 993 994 996 998 1000 1001 1004 1005 1007 1009 1011 1012 1014 1015 1018 1019 1023 1024 1024 1027 1028 1041 1044 1045 1046 1048 1050 1051 1054 1055 1689 1690 2066 2066 2066 2068 2068 2068 2071 2073 2075 2076 2077 2080 2081 2087 2089 2090 2091 2138 2139 2157 2158 mcode_ptr 4 based pointer level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 1530 1630 1651 1653 1659 1668 1681 1691 1711 1729 1753 1755 1827 1872 1993 1998 2032 2236 2239 2241 2248 2257 2295 2331 2333 2345 2347 2358 2380 2380 2382 2388 2410 2420 2420 2422 2524 2532 2548 2550 mcs_icdp 2 based pointer level 2 in structure "receive_comm_stack" dcl 1251 in procedure "cobol_rts_" set ref 1268* 1278* mcs_icdp 2 based pointer level 2 in structure "accept_comm_stack" dcl 1294 in procedure "cobol_rts_" set ref 1302* mcs_icdp 2 based pointer level 2 in structure "enable_comm_stack" dcl 1367 in procedure "cobol_rts_" set ref 1383* 1386* 1389* 1396* 1399* 1402* mcs_icdp 2 based pointer level 2 in structure "purge_comm_stack" dcl 1318 in procedure "cobol_rts_" set ref 1326* mcs_ocdp 2 based pointer level 2 dcl 1341 set ref 1354* merge_comm_stack based structure level 1 unaligned dcl 1081 merge_comm_static 000010 internal static structure level 1 unaligned dcl 1096 merge_compare based entry variable level 2 dcl 1107 ref 1215 merge_controlp 20 based pointer level 2 dcl 1081 ref 1138 merge_record based structure level 1 unaligned dcl 1112 merge_record_ptr 2 000010 internal static pointer level 2 dcl 1096 set ref 1135* 1215 1215 merge_record_ptr_rts 12 based pointer level 2 dcl 1081 ref 1135 merge_seg_ptr 10 000010 internal static pointer level 2 dcl 1096 set ref 1148* 1150* merge_tree based structure level 1 unaligned dcl 1117 mesp 4 based pointer level 2 in structure "send_comm_stack" dcl 1341 in procedure "cobol_rts_" set ref 1354* mesp 4 based pointer level 2 in structure "receive_comm_stack" dcl 1251 in procedure "cobol_rts_" set ref 1268* 1278* mod builtin function dcl 2665 ref 902 1187 mod1 134(02) based bit(1) level 4 packed packed unaligned dcl 4-18 ref 1517 1550 1857 2116 2149 mode 000222 automatic fixed bin(17,0) dcl 1444 in procedure "cobol_rts_" set ref 1902* 1909* 2055* mode parameter fixed bin(17,0) dcl 2195 in procedure "make_key" ref 2192 2210 month 2 based fixed bin(17,0) level 2 dcl 862 set ref 896* 900 902 multics_code 22 based fixed bin(35,0) level 2 dcl 308 set ref 328* 333* n 1 000120 automatic fixed bin(17,0) level 2 in structure "seek_info" dcl 1439 in procedure "cobol_rts_" set ref 1526* 2339* n 1 based fixed bin(17,0) level 2 in structure "SEEK_KEY" dcl 2199 in procedure "make_key" set ref 2212 2212 2213* 2213 n based fixed bin(17,0) level 2 in structure "SK" dcl 2204 in procedure "make_key" set ref 2216 2216 2217* 2217 name_length 4 based fixed bin(17,0) level 2 dcl 580 ref 589 589 name_ptr 2 based pointer level 2 dcl 580 ref 589 589 new_key 000706 automatic varying char(256) dcl 2064 set ref 2068* 2087 no_data 11 based fixed bin(17,0) level 2 dcl 1251 set ref 1273* 1275* null builtin function dcl 2665 ref 396 396 399 399 544 544 548 548 548 548 755 755 1859 off 000570 automatic fixed bin(17,0) dcl 1784 set ref 1798* 1810 1810 1848 2272 offset 4 based fixed bin(17,0) array level 3 in structure "file_desc_1" dcl 6-7 in procedure "cobol_rts_" set ref 1798 2506 offset 2 based fixed bin(17,0) level 3 in structure "file_desc_1" dcl 6-7 in procedure "cobol_rts_" ref 2118 2149 2260 2506 offset_ptr 10 based pointer level 2 dcl 652 ref 619 619 729 729 755 755 2066 2066 2068 2087 op parameter char packed unaligned dcl 2484 ref 2481 2492 order_name 000104 automatic char(9) initial packed unaligned dcl 614 set ref 614* 619* 2066* output_length 4 based fixed bin(17,0) level 2 dcl 916 set ref 926* output_record 12 based entry variable level 2 dcl 382 set ref 391* p 001220 automatic pointer dcl 2195 set ref 2208* 2212 2212 2212 2212 2213 2213 2216 2216 2216 2216 2217 2217 pad 0(19) based bit(8) level 4 packed packed unaligned dcl 8-41 set ref 2477* password based char(30) packed unaligned dcl 1379 ref 1383 1383 1386 1386 1389 1389 1396 1396 1399 1399 1402 1402 password_length 6 based fixed bin(17,0) level 2 dcl 1367 ref 1383 1383 1386 1386 1389 1389 1396 1396 1399 1399 1402 1402 password_ptr 4 based pointer level 2 dcl 1367 ref 1383 1383 1386 1386 1389 1389 1396 1396 1399 1399 1402 1402 position_specification 0(05) based structure level 4 packed packed unaligned dcl 8-41 pr4_save_ptr 2 based pointer level 2 dcl 346 set ref 355* prime_key 144 based varying char(256) level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1514* 1627 1952* 2239* 2241* 2250* 2260* 2293 2301 2302 2506 prime_key 2 based structure level 2 in structure "file_desc_1" unaligned dcl 6-7 in procedure "cobol_rts_" progname based char(65) packed unaligned dcl 323 ref 328 328 333 333 progname_length 32 based fixed bin(17,0) level 2 dcl 308 ref 328 328 333 333 progname_ptr 30 based pointer level 2 dcl 308 ref 328 328 333 333 purge_comm_stack based structure level 1 unaligned dcl 1318 read_key_based based structure level 1 unaligned dcl 649 read_key_eof 1 based fixed bin(17,0) level 2 dcl 649 set ref 828* read_key_key 001010 automatic varying char(256) dcl 2224 set ref 2236* 2246 2246 rec_len 000225 automatic fixed bin(21,0) dcl 1472 set ref 1651* 2236* 2532* rec_ptr parameter pointer dcl 1835 ref 1831 1848 receive_comm_stack based structure level 1 unaligned dcl 1251 record based char(1000000) packed unaligned dcl 1841 in procedure "form_alt_key" ref 1848 record based pointer array level 2 in structure "merge_record" dcl 1112 in procedure "cobol_rts_" set ref 1215* 1215* record_length 4 based fixed bin(21,0) level 2 dcl 442 set ref 453* 458* record_ptr 4 based pointer level 2 dcl 7-6 set ref 1706* 1774* 1810 2260 2272 2506 2506 rel_type 0(06) based fixed bin(2,0) level 5 packed packed unaligned dcl 8-41 set ref 2474* relation_type 000120 automatic fixed bin(17,0) level 2 dcl 1439 set ref 1525* 2338* res 001007 automatic bit(1) packed unaligned dcl 2190 set ref 2312* 2316* 2319 2351 2369 2404 2506* 2516* reset_pos 0(18) based bit(1) level 4 packed packed unaligned dcl 8-41 set ref 1738* 2476* rk_header based structure level 1 unaligned dcl 8-26 rlen 000705 automatic fixed bin(21,0) dcl 2062 set ref 2068* rs_info based structure level 1 dcl 7-6 rs_info_ptr 001120 automatic pointer dcl 7-5 set ref 1624* 1706 1774 1810 1872* 1986* 2260 2272 2279 2443* 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2506 2506 rs_info_version_2 constant fixed bin(17,0) initial dcl 7-44 ref 2445 rs_record_buffer based char(1000000) packed unaligned dcl 1467 ref 1810 2260 2272 2506 2506 rts_code based fixed bin(17,0) level 2 in structure "rts_stack" dcl 292 in procedure "cobol_rts_" ref 300 rts_code based fixed bin(17,0) level 2 in structure "time_stack" dcl 862 in procedure "cobol_rts_" ref 889 897 rts_code based fixed bin(17,0) level 2 in structure "inspect_stack" dcl 916 in procedure "cobol_rts_" ref 924 rts_ptr parameter pointer dcl 297 ref 289 299 rts_stack based structure level 1 unaligned dcl 292 rts_stack_ptr 000102 automatic pointer dcl 296 set ref 299* 300 328 328 328 328 328 328 328 328 328 328 332 333 333 333 333 333 333 333 333 333 355 390 391 392 396 396 399 399 428 428 428 453 453 453 454 456 458 459 484 505 540 555 589 589 589 589 589 619 619 619 621 623 625 626 627 630 631 672 676 676 678 678 680 694 698 698 700 700 702 702 704 704 706 706 708 729 729 729 755 755 755 768 772 774 775 776 778 780 781 782 785 786 786 788 792 794 795 796 798 800 801 806 807 822 826 827 828 829 831 833 834 849 849 849 849 853 853 855 855 855 857 889 892 896 896 896 896 896 896 897 900 900 900 902 902 902 902 924 924 926 926 940 943 944 945 956 960 961 962 964 966 967 968 970 972 973 976 977 989 992 993 994 996 998 1000 1001 1004 1005 1007 1009 1011 1012 1014 1015 1018 1019 1023 1024 1024 1027 1028 1041 1044 1045 1046 1048 1050 1051 1054 1055 1133 1135 1136 1137 1138 1265 1267 1267 1268 1268 1268 1268 1268 1270 1272 1273 1275 1278 1278 1278 1278 1278 1302 1302 1326 1326 1354 1354 1354 1354 1354 1354 1381 1383 1383 1383 1383 1383 1383 1383 1386 1386 1386 1386 1386 1386 1389 1389 1389 1389 1389 1389 1393 1396 1396 1396 1396 1396 1396 1396 1399 1399 1399 1399 1399 1399 1402 1402 1402 1402 1402 1402 1506 1508 1510 1511 1513 1530 1623 1630 1651 1653 1659 1668 1681 1689 1690 1691 1711 1729 1733 1753 1755 1827 1856 1872 1908 1911 1950 1993 1998 2029 2032 2066 2066 2066 2068 2068 2068 2071 2073 2075 2076 2077 2080 2081 2087 2089 2090 2091 2101 2104 2104 2104 2104 2116 2138 2139 2146 2157 2158 2161 2169 2169 2169 2208 2236 2239 2241 2248 2257 2295 2331 2333 2345 2347 2358 2380 2380 2382 2388 2410 2420 2420 2422 2524 2532 2548 2550 save_sw 000226 automatic bit(1) packed unaligned dcl 1473 set ref 1634* 1656 2237* search_key 2 000120 automatic char(256) level 2 packed packed unaligned dcl 1439 set ref 1528* 2340* seek_info 000120 automatic structure level 1 unaligned dcl 1439 set ref 1530 1530 2524 2524 seek_key 1 based char(256) level 2 in structure "SK" packed packed unaligned dcl 2204 in procedure "make_key" set ref 2216* 2216 seek_key 2 based char(256) level 2 in structure "SEEK_KEY" packed packed unaligned dcl 2199 in procedure "make_key" set ref 2212* 2212 send_comm_stack based structure level 1 unaligned dcl 1341 signal_ 000124 constant entry external dcl 2607 ref 544 548 size 000603 automatic fixed bin(17,0) level 2 in structure "vfile_key" dcl 1790 in procedure "cobol_rts_" set ref 1641 1651 1651 size 3 based fixed bin(17,0) level 3 in structure "file_desc_1" dcl 6-7 in procedure "cobol_rts_" ref 2118 2149 2260 2506 size 5 based fixed bin(17,0) array level 3 in structure "file_desc_1" dcl 6-7 in procedure "cobol_rts_" set ref 1653 1799 2312 2506 sort_$commence 000116 constant entry external dcl 2603 ref 505 sort_$initiate 000060 constant entry external dcl 2572 ref 396 399 sort_$noexit 000062 constant entry external dcl 2573 ref 390 391 sort_$release 000044 constant entry external dcl 424 ref 428 sort_$return 000112 constant entry external dcl 2599 ref 453 sort_$terminate 000114 constant entry external dcl 2601 ref 484 sort_commence_stack based structure level 1 unaligned dcl 495 sort_dir 65 based char(168) level 2 dcl 2-6 set ref 399 399 1144* 1145 1148 1148 sort_dir_len 64 based fixed bin(17,0) level 2 dcl 2-6 set ref 396 399 399 1142 1145* 1148 1148 sort_file_size 63 based float bin(27) level 2 dcl 2-6 set ref 394 394* 396* 399* sort_initiate_stack based structure level 1 unaligned dcl 372 sort_release_stack based structure level 1 unaligned dcl 414 sort_return_stack based structure level 1 unaligned dcl 442 sort_terminate_stack based structure level 1 unaligned dcl 472 stack_buff_ptr 12 based pointer level 2 dcl 640 set ref 828 855* stat based structure level 1 dcl 3-23 stat_ptr 001112 automatic pointer dcl 3-22 set ref 540* 541* 541 542 544* 547* 555* 557* 557 559 status12 2 based char(2) level 2 dcl 652 set ref 625* 630* 672* 694* 775* 781* 785* 794* 800* 806* 826* 833* 943* 960* 967* 972* 976* 993* 1000* 1004* 1014* 1018* 1023* 1027* 1045* 1050* 1054* 1689* 2075* 2080* 2090* 2138* 2157* status3 3 based char(4) level 2 dcl 652 set ref 626* 631* 676* 678* 680* 698* 700* 702* 704* 706* 708* 776* 782* 786* 788* 795* 801* 807* 827* 834* 944* 961* 968* 973* 977* 994* 1001* 1005* 1015* 1019* 1024* 1028* 1046* 1051* 1055* 1690* 2076* 2081* 2091* 2139* 2158* status_code 10 based fixed bin(35,0) level 2 in structure "sort_release_stack" dcl 414 in procedure "cobol_rts_" set ref 428* status_code 2 based fixed bin(35,0) level 2 in structure "sort_terminate_stack" dcl 472 in procedure "cobol_rts_" set ref 484* status_code 10 based fixed bin(35,0) level 2 in structure "sort_initiate_stack" dcl 372 in procedure "cobol_rts_" set ref 396* 399* status_code 10 based fixed bin(35,0) level 2 in structure "sort_commence_stack" dcl 495 in procedure "cobol_rts_" set ref 505* status_code 10 based fixed bin(35,0) level 2 in structure "sort_return_stack" dcl 442 in procedure "cobol_rts_" set ref 453* 454 456 459* status_info 000340 automatic structure level 1 unaligned dcl 1483 set ref 1624 1986 2443 string builtin function dcl 2665 set ref 1739* struc based structure level 1 unaligned dcl 609 substr builtin function dcl 2665 set ref 328 328 333 333 399 399 589 589 892 892 892 1148 1148 1383 1383 1386 1386 1389 1389 1396 1396 1399 1399 1402 1402 1627 1651 1651 1665 1810 1810 1845 1848* 1848 1908 1952 2087 2087 2118 2149 2212* 2212 2216* 2216 2260 2272 2309 2326 2340 2506 2506 2545* 2545 switchlen 2 based fixed bin(17,0) level 2 dcl 718 ref 729 729 switchname 4 based char level 2 packed packed unaligned dcl 718 set ref 729* sz 000567 automatic fixed bin(17,0) dcl 1784 set ref 1749 1799* 1802 sz_abs 000566 automatic fixed bin(17,0) dcl 1784 set ref 1802* 1810 1810 1844 2272 temp_flag 16 based fixed bin(17,0) level 2 dcl 652 ref 768 998 1012 temp_mcode 000100 automatic fixed bin(35,0) dcl 295 set ref 1140* 1148* 1150* temp_ptr based pointer dcl 537 set ref 540 555 2101 2104* 2146 2169* terminal_flag 10 based fixed bin(17,0) level 2 dcl 1367 ref 1383 1396 time_stack based structure level 1 unaligned dcl 862 tod 10 based fixed bin(71,0) level 2 dcl 862 set ref 896* tree based fixed bin(17,0) array level 2 dcl 1117 set ref 1153* 1185 1210 1210* 1210 1212 1212* 1212 1215 1215 1217* 1217 1219* 1219 1221 1221 1221* 1221 1223* 1223 tree_ptr 4 000010 internal static pointer level 2 dcl 1096 set ref 1136* 1153 1185 1210 1210 1210 1212 1212 1212 1215 1215 1215 1217 1217 1217 1219 1219 1219 1221 1221 1221 1221 1223 1223 tree_ptr_rts 14 based pointer level 2 dcl 1081 ref 1136 type 6 based fixed bin(17,0) level 2 dcl 1251 set ref 1265 1267* 1267 1268* 1278* unlock_sw 1(01) based bit(1) level 3 packed packed unaligned dcl 7-6 set ref 2447* unspec builtin function dcl 2665 set ref 1527* 1622* 1845* 1845 1859 1908* 1908 1929* 2309* 2309 2545 2545 use_code 1 based fixed bin(17,0) level 2 dcl 308 set ref 328 332* version based fixed bin(17,0) level 2 in structure "rs_info" dcl 7-6 in procedure "cobol_rts_" set ref 2445* version 0(27) based fixed bin(8,0) level 4 in structure "gk_info" packed packed unaligned dcl 8-41 in procedure "cobol_rts_" set ref 2473* vfile_key 000603 automatic structure level 1 unaligned dcl 1790 vfile_open_mode 135 based fixed bin(35,0) level 3 in structure "fsb" dcl 4-18 in procedure "cobol_rts_" set ref 1510* 1638 vfile_open_mode 14 based fixed bin(35,0) level 2 in structure "alt_stack_hdr" dcl 1421 in procedure "cobol_rts_" ref 1510 w 000117 automatic fixed bin(17,0) dcl 1123 set ref 1191 1209* 1210 1212 1217 1219 1221 1223 work_ptr 2 based pointer level 2 dcl 916 set ref 924* 926* year 6 based fixed bin(17,0) level 2 dcl 862 set ref 896* 902 zone 13 based char(3) level 2 dcl 862 set ref 896* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. ak_key_len automatic fixed bin(17,0) dcl 8-19 file_desc_1_type internal static fixed bin(17,0) initial dcl 6-4 first_link_offset internal static fixed bin(17,0) initial dcl 3-52 fixed_static_length internal static fixed bin(17,0) initial dcl 3-51 gk_key_len automatic fixed bin(17,0) dcl 8-64 rk_info based structure level 1 unaligned dcl 8-22 rk_info_ptr automatic pointer dcl 8-37 rk_key_len automatic fixed bin(17,0) dcl 8-38 rs_desc based structure level 1 packed packed unaligned dcl 7-32 rs_info_version_1 internal static fixed bin(17,0) initial dcl 7-43 seq_desc based structure level 1 packed packed unaligned dcl 7-37 stack_frame based structure level 1 dcl 1-7 stack_frame_ptr automatic pointer dcl 1-6 NAMES DECLARED BY EXPLICIT CONTEXT. check_close_error 001050 constant label dcl 672 check_open_error 001071 constant label dcl 694 check_seek_error 001212 constant label dcl 768 cobol_rts_ 000243 constant entry external dcl 289 eof_test 005411 constant entry internal dcl 2536 ref 2000 2246 form_alt_key 004315 constant entry internal dcl 1831 ref 1650 1826 init_ak_info 005233 constant entry internal dcl 2481 ref 1697 1765 1956 2036 init_gk_info 005200 constant entry internal dcl 2459 ref 1737 2322 init_rs_info 005150 constant entry internal dcl 2440 ref 1871 iox_rr 005363 constant entry internal dcl 2528 ref 2378 2417 iox_sh 005325 constant entry internal dcl 2520 ref 2343 2408 key_compare 005266 constant entry internal dcl 2502 ref 2366 2401 keys_unequal 004233 constant entry internal dcl 1806 ref 1746 make_key 004430 constant entry internal dcl 2192 ref 1909 1934 merge_call_compare 004066 constant entry internal dcl 1201 ref 1169 1190 process_key 004257 constant entry internal dcl 1820 ref 1706 1752 1774 1965 2045 read_key_error 001300 constant label dcl 822 rec_status 004374 constant entry internal dcl 1867 ref 1678 1726 2030 2256 2355 2386 restore_NRP 004653 constant entry internal dcl 2286 ref 1656 1988 rts 000000 constant label array(64) dcl 308 ref 300 rts54 003367 constant label dcl 1905 ref 2058 rts9 000624 constant label dcl 544 ref 564 save_NRP 004511 constant entry internal dcl 2226 ref 1636 1931 set_off_sz 004214 constant entry internal dcl 1794 ref 1647 1703 1745 1771 1962 2042 2266 set_up 004350 constant entry internal dcl 1852 ref 1544 1563 1581 1598 1618 1675 1723 1885 1905 1925 1946 1982 2026 2096 2127 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 6334 6556 5533 6344 Length 7264 5533 222 472 601 34 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_rts_ 1016 external procedure is an external procedure. merge_call_compare internal procedure shares stack frame of external procedure cobol_rts_. set_off_sz internal procedure shares stack frame of external procedure cobol_rts_. keys_unequal internal procedure shares stack frame of external procedure cobol_rts_. process_key internal procedure shares stack frame of external procedure cobol_rts_. form_alt_key internal procedure shares stack frame of external procedure cobol_rts_. set_up internal procedure shares stack frame of external procedure cobol_rts_. rec_status internal procedure shares stack frame of external procedure cobol_rts_. make_key internal procedure shares stack frame of external procedure cobol_rts_. save_NRP internal procedure shares stack frame of external procedure cobol_rts_. restore_NRP internal procedure shares stack frame of external procedure cobol_rts_. init_rs_info internal procedure shares stack frame of external procedure cobol_rts_. init_gk_info internal procedure shares stack frame of external procedure cobol_rts_. init_ak_info internal procedure shares stack frame of external procedure cobol_rts_. key_compare internal procedure shares stack frame of external procedure cobol_rts_. iox_sh internal procedure shares stack frame of external procedure cobol_rts_. iox_rr internal procedure shares stack frame of external procedure cobol_rts_. eof_test internal procedure shares stack frame of external procedure cobol_rts_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 merge_comm_static cobol_rts_ 000022 KEY_OF_REF cobol_rts_ 000023 key_status cobol_rts_ 000042 controlp cobol_rts_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_rts_ 000100 temp_mcode cobol_rts_ 000102 rts_stack_ptr cobol_rts_ 000104 order_name cobol_rts_ 000110 date_time cobol_rts_ 000112 day_temp cobol_rts_ 000114 i cobol_rts_ 000115 j cobol_rts_ 000116 k cobol_rts_ 000117 w cobol_rts_ 000120 seek_info cobol_rts_ 000222 mode cobol_rts_ 000223 dummy_buffer cobol_rts_ 000224 char1 cobol_rts_ 000225 rec_len cobol_rts_ 000226 save_sw cobol_rts_ 000227 key_num cobol_rts_ 000230 buff_ptr cobol_rts_ 000232 alt_key_desc_ptr cobol_rts_ 000234 CODE cobol_rts_ 000235 KEY_NUM cobol_rts_ 000236 REC_LEN cobol_rts_ 000237 READ_KEY cobol_rts_ 000340 status_info cobol_rts_ 000356 GK_INFO cobol_rts_ 000461 AK_INFO cobol_rts_ 000564 BUFF_PTR cobol_rts_ 000566 sz_abs cobol_rts_ 000567 sz cobol_rts_ 000570 off cobol_rts_ 000572 key_len_ptr cobol_rts_ 000574 key_ptr cobol_rts_ 000576 info_ptr cobol_rts_ 000600 key_op cobol_rts_ 000603 vfile_key cobol_rts_ 000704 key_comp cobol_rts_ 000705 rlen cobol_rts_ 000706 new_key cobol_rts_ 001007 res cobol_rts_ 001010 read_key_key cobol_rts_ 001112 stat_ptr cobol_rts_ 001114 fsb_ptr cobol_rts_ 001116 file_desc_1_ptr cobol_rts_ 001120 rs_info_ptr cobol_rts_ 001122 ak_info_ptr cobol_rts_ 001124 gk_info_ptr cobol_rts_ 001174 alt_key_num form_alt_key 001220 p make_key 001236 key_len restore_NRP 001240 key_ptr restore_NRP THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp call_ent_var call_ext_out_desc call_ext_out return_mac mdfx1 shorten_stack ext_entry trunc_fx2 divide_fx1 THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. clock_ cobol_control_$cancel cobol_control_$cobol_rts_control_ cobol_error_ cobol_error_$use cobol_mcs_$accept cobol_mcs_$disable_input_queue cobol_mcs_$disable_input_terminal cobol_mcs_$disable_output cobol_mcs_$enable_input_queue cobol_mcs_$enable_input_terminal cobol_mcs_$enable_output cobol_mcs_$purge cobol_mcs_$receive cobol_mcs_$receive_wait cobol_mcs_$send cobol_mcs_$stop_run cobol_stop_run_ cobol_su_$replace cobol_su_$tally cu_$cl date_time_ decode_clock_value_ get_pdir_ hcs_$make_seg hcs_$terminate_name hcs_$truncate_seg iox_$attach_ptr iox_$control iox_$find_iocb iox_$get_line iox_$read_key iox_$read_record iox_$rewrite_record iox_$seek_key signal_ sort_$commence sort_$initiate sort_$noexit sort_$release sort_$return sort_$terminate THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. cmcs_error_table_$no_message error_table_$bad_file error_table_$end_of_info error_table_$file_busy error_table_$incompatible_attach error_table_$key_duplication error_table_$key_order error_table_$long_record error_table_$no_operation error_table_$no_record error_table_$noentry error_table_$short_record iox_$user_input LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 289 000240 614 000250 299 000255 300 000261 328 000263 331 000330 332 000331 333 000332 335 000374 336 000375 355 000376 356 000404 390 000405 391 000412 392 000414 394 000416 396 000422 399 000464 401 000531 428 000533 430 000545 453 000546 454 000560 456 000563 458 000566 459 000567 461 000570 484 000571 486 000577 505 000600 506 000606 523 000607 525 000613 540 000614 541 000620 542 000622 544 000624 547 000653 548 000673 549 000722 555 000723 557 000727 559 000731 562 000733 564 000737 589 000740 590 000774 619 000776 621 001024 623 001027 625 001032 626 001035 627 001037 628 001041 630 001042 631 001045 634 001047 672 001050 676 001053 678 001061 680 001066 681 001070 694 001071 698 001074 700 001102 702 001107 704 001114 706 001121 708 001126 709 001130 729 001131 731 001156 755 001157 757 001211 768 001212 772 001216 774 001221 775 001223 776 001225 777 001227 778 001230 780 001232 781 001234 782 001236 783 001240 785 001241 786 001243 788 001250 790 001252 792 001253 794 001256 795 001260 796 001262 797 001263 798 001264 800 001266 801 001270 802 001272 806 001273 807 001275 812 001277 822 001300 826 001303 827 001306 828 001310 829 001312 830 001313 831 001314 833 001316 834 001321 836 001323 849 001324 853 001342 855 001355 857 001375 858 001377 859 001400 887 001401 889 001407 891 001412 892 001427 893 001447 896 001450 897 001474 900 001477 902 001504 906 001514 924 001515 926 001527 927 001537 940 001540 943 001543 944 001546 945 001550 947 001551 956 001552 960 001555 961 001560 962 001562 963 001564 964 001565 966 001567 967 001572 968 001574 969 001576 970 001577 972 001601 973 001604 974 001606 976 001607 977 001612 979 001614 989 001615 992 001620 993 001621 994 001624 995 001626 996 001627 998 001631 1000 001635 1001 001637 1002 001641 1004 001642 1005 001644 1007 001646 1008 001650 1009 001651 1011 001653 1012 001656 1014 001660 1015 001662 1016 001664 1018 001665 1019 001667 1021 001671 1023 001672 1024 001675 1027 001702 1028 001704 1031 001706 1041 001707 1044 001712 1045 001715 1046 001717 1047 001721 1048 001722 1050 001724 1051 001727 1052 001731 1054 001732 1055 001735 1057 001737 1133 001740 1135 001742 1136 001744 1137 001746 1138 001750 1140 001752 1142 001774 1144 002000 1145 002013 1148 002023 1150 002103 1152 002120 1153 002131 1154 002134 1156 002136 1165 002137 1168 002142 1169 002153 1170 002157 1171 002162 1181 002163 1183 002167 1185 002171 1186 002174 1187 002177 1189 002206 1190 002211 1191 002213 1192 002215 1193 002216 1265 002217 1267 002222 1268 002224 1270 002242 1272 002247 1273 002250 1274 002252 1275 002253 1276 002254 1278 002255 1281 002273 1302 002274 1303 002304 1326 002305 1327 002315 1354 002316 1356 002336 1381 002337 1383 002341 1386 002375 1388 002426 1389 002430 1391 002460 1393 002462 1396 002464 1399 002520 1401 002551 1402 002553 1404 002603 1506 002605 1508 002607 1509 002611 1510 002612 1511 002614 1512 002616 1513 002620 1514 002623 1517 002624 1520 002630 1525 002645 1526 002646 1527 002650 1528 002652 1530 002655 1532 002707 1544 002710 1548 002711 1550 002714 1552 002720 1563 002721 1567 002722 1568 002725 1569 002730 1581 002731 1585 002732 1586 002735 1598 002736 1602 002737 1604 002742 1607 002754 1618 002755 1622 002756 1623 002760 1624 002763 1625 002765 1627 002770 1630 003014 1631 003021 1634 003022 1636 003023 1638 003024 1641 003030 1642 003032 1644 003034 1647 003045 1650 003046 1651 003050 1653 003076 1656 003107 1659 003112 1660 003116 1663 003117 1665 003124 1666 003142 1668 003147 1670 003151 1675 003152 1678 003153 1681 003154 1685 003157 1689 003166 1690 003171 1691 003173 1692 003176 1697 003177 1700 003206 1703 003217 1706 003220 1709 003227 1711 003234 1713 003236 1723 003237 1726 003240 1729 003241 1733 003244 1734 003246 1737 003251 1738 003252 1739 003254 1742 003260 1745 003271 1746 003272 1749 003273 1752 003277 1753 003301 1755 003304 1757 003307 1762 003310 1765 003315 1768 003324 1771 003335 1774 003336 1778 003353 1781 003360 1885 003361 1889 003362 1891 003365 1902 003366 1905 003367 1908 003370 1909 003374 1911 003376 1912 003402 1925 003403 1929 003404 1931 003406 1934 003407 1936 003413 1946 003414 1950 003415 1952 003420 1956 003434 1959 003441 1962 003451 1965 003452 1968 003454 1970 003461 1971 003464 1982 003465 1986 003466 1988 003470 1993 003501 1995 003504 1998 003521 2000 003526 2003 003532 2026 003533 2029 003534 2030 003537 2032 003540 2036 003543 2039 003550 2042 003561 2045 003562 2049 003572 2051 003577 2053 003602 2055 003603 2058 003605 2066 003606 2068 003634 2071 003656 2073 003661 2075 003664 2076 003667 2077 003671 2078 003673 2080 003674 2081 003677 2083 003701 2087 003702 2089 003714 2090 003717 2091 003721 2094 003723 2096 003724 2101 003725 2104 003731 2116 003751 2118 003760 2125 003776 2127 003777 2132 004000 2135 004004 2138 004007 2139 004013 2142 004015 2146 004016 2149 004022 2157 004035 2158 004041 2161 004043 2164 004046 2169 004047 2179 004065 1201 004066 1209 004070 1210 004105 1212 004117 1215 004126 1217 004151 1219 004167 1221 004177 1223 004210 1225 004213 1794 004214 1798 004215 1799 004224 1802 004226 1804 004232 1806 004233 1810 004234 1813 004245 1814 004247 1815 004254 1816 004255 1818 004256 1820 004257 1826 004261 1827 004267 1829 004314 1831 004315 1844 004317 1845 004322 1848 004325 1850 004346 1852 004350 1856 004351 1857 004354 1859 004362 1861 004371 1865 004373 1867 004374 1871 004375 1872 004376 1874 004427 2192 004430 2208 004432 2210 004435 2212 004437 2213 004461 2214 004463 2216 004464 2217 004506 2220 004510 2226 004511 2230 004512 2236 004533 2237 004551 2239 004553 2241 004563 2246 004570 2248 004574 2250 004577 2252 004601 2256 004602 2257 004603 2260 004607 2265 004624 2266 004626 2269 004627 2272 004632 2279 004646 2284 004652 2286 004653 2293 004654 2295 004662 2296 004666 2299 004667 2301 004672 2302 004675 2303 004677 2305 004700 2306 004703 2309 004705 2312 004710 2316 004723 2319 004724 2322 004726 2324 004727 2325 004733 2326 004736 2329 004755 2331 004761 2333 005010 2338 005014 2339 005016 2340 005021 2343 005037 2345 005041 2347 005044 2348 005047 2351 005050 2355 005053 2358 005054 2366 005060 2369 005061 2373 005064 2378 005066 2380 005067 2382 005076 2386 005101 2388 005102 2401 005106 2404 005107 2408 005111 2410 005112 2414 005116 2417 005127 2420 005130 2422 005137 2425 005142 2427 005144 2431 005145 2433 005146 2435 005147 2440 005150 2443 005151 2445 005153 2446 005155 2447 005157 2448 005161 2449 005163 2450 005165 2451 005167 2452 005171 2453 005173 2454 005175 2455 005176 2457 005177 2459 005200 2463 005201 2466 005203 2467 005205 2468 005207 2469 005212 2471 005213 2472 005215 2473 005217 2474 005222 2476 005226 2477 005230 2479 005232 2481 005233 2487 005244 2490 005246 2491 005250 2492 005252 2493 005257 2496 005260 2497 005262 2498 005263 2500 005265 2502 005266 2506 005267 2516 005323 2518 005324 2520 005325 2524 005326 2526 005362 2528 005363 2532 005364 2534 005410 2536 005411 2544 005413 2545 005414 2548 005421 2550 005432 2552 005434 ----------------------------------------------------------- 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