COMPILATION LISTING OF SEGMENT cobol_move_gen Compiled by: Multics PL/I Compiler, Release 31b, of April 24, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 05/24/89 0943.8 mst Wed 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,MCR8060), 17* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 18* MCR8060 cobol_move_gen.pl1 Added Trace statements. 19* 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8085), 20* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 21* MCR8085 cobol_move_gen.pl1 Stop code generator from aborting in move 22* statement. 23* END HISTORY COMMENTS */ 24 25 26 /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ 27 /* Modified on 08/13/83 by FCH, [5.2 ...], trace added */ 28 /* Modified on 11/03/81 by FCH, sending tokens sometimes clobbered, [5.1-1], phx11872(BUG518) */ 29 /* Modified on 06/11/81 by FCH, [4.4-2], type 13 token allowed as move operand, BUG468 */ 30 /* Modified on 04/08/81 by FCH, [4.4-1], move zzzpp to xxxxx gives 0 fill not space, BUG476 */ 31 /* Modified on 09/20/80 by FCH, [4.3-2], MOVE constant to indexed comp-6 generates bad code (TR7611, BUG443) */ 32 /* Modified on 08/29/80 by FCH, [4.3-1], MOVE subscripted comp-6 to comp-7 generated bad code (TR5709, BUG432) */ 33 /* Modified on 04/25/80 by FCH, [4.2-2], use MVC for pic s999 lead sep to pic xxxx */ 34 /* Modified on 03/25/80 by FCH, indent used, [4.2-1], set ix to comp-7 fails, BUG432(TR5709) */ 35 /* Modified on 09/01/79 by FCH, [4.0-2], variable length receiving fields fixed */ 36 /* Modified on 05/09/79 by FCH, [4.0-1], move all literal fixed */ 37 /* Modified on 10/19/78 by FCH, [3.0-2], decimal to binary conversion fixed */ 38 /* Modified on 04/10/78 by FCH, [3.0-1], double-word alignment not reqd for params */ 39 /* Modified since Version 3.0 */ 40 41 42 43 44 45 46 /* format: style3 */ 47 cobol_move_gen: 48 proc (in_token_ptr); 49 50 dcl MVE bit (10) static init ("0000100001"b); 51 /* 020(1) */ 52 dcl MVNE bit (10) static init ("0000101001"b); 53 /* 024(1) */ 54 dcl MLR bit (10) static init ("0010000001"b); 55 /* 100(1) */ 56 dcl MRL bit (10) static init ("0010000011"b); 57 /* 101(1) */ 58 dcl MVN bit (10) static init ("0110000001"b); 59 /* 300(1) */ 60 dcl CMPN bit (10) static init ("0110000111"b); 61 /* 303(1) */ 62 dcl LDA bit (10) int static init ("0100111010"b); 63 /* 235(0) */ 64 dcl LDQ bit (10) int static init ("0100111100"b); 65 /* 236(0) */ 66 dcl ALS bit (10) int static init ("1110111010"b); 67 /* 735(0) */ 68 dcl QLS bit (10) int static init ("1110111100"b); 69 /* 736(0) */ 70 dcl ARS bit (10) int static init ("1110110010"b); 71 /* 731(0) */ 72 dcl QRS bit (10) int static init ("1110110100"b); 73 /* 732(0) */ 74 dcl STA bit (10) int static init ("1111011010"b); 75 /* 755(0) */ 76 dcl STQ bit (10) int static init ("1111011100"b); 77 /* 756(0) */ 78 dcl ANA bit (10) int static init ("0111111010"b); 79 /* 375(0) */ 80 dcl ANQ bit (10) int static init ("0111111100"b); 81 /* 376(0) */ 82 dcl STBA bit (10) int static init ("1011010010"b); 83 /* 551(0) */ 84 dcl STBQ bit (10) int static init ("1011010100"b); 85 /* 552(0) */ 86 dcl ARL bit (10) int static init ("1111110010"b); 87 /* 771(0) */ 88 dcl ORSA bit (10) int static init ("0101011010"b); 89 /* 255(0) */ 90 dcl ORSQ bit (10) int static init ("0101011100"b); 91 /* 256(0) */ 92 dcl BTD bit (10) int static init ("0110000011"b); 93 /* 301(1) */ 94 dcl DTB bit (10) int static init ("0110001011"b); 95 /* 305(1) */ 96 dcl QRL bit (10) int static init ("1111110100"b); 97 /* 772(0) */ 98 dcl LDAQ bit (10) int static init ("0100111110"b); 99 /* 237(0) */ 100 dcl ANAQ bit (10) int static init ("0111111110"b); 101 /* 377(0) */ 102 dcl STZ bit (10) int static init ("1001010000"b); 103 /* 450(0) */ 104 dcl instr bit (10); 105 106 dcl ses00 bit (9) static init ("000110000"b); 107 dcl ses01 bit (9) static init ("000110100"b); 108 dcl ses10 bit (9) static init ("000111000"b); 109 dcl ses11 bit (9) static init ("000111100"b); 110 dcl lte_1 bit (9) static init ("100000001"b); 111 dcl lte_3 bit (9) static init ("100000011"b); 112 dcl lte_5 bit (9) static init ("100000101"b); 113 dcl enf00 bit (9) static init ("000100000"b); 114 dcl enf01 bit (9) static init ("000100100"b); 115 dcl enf10 bit (9) static init ("000101000"b); 116 dcl enf11 bit (9) static init ("000101100"b); 117 dcl ign bit (9) static init ("011000000"b); 118 dcl mvc bit (9) static init ("011010000"b); 119 dcl insn_0 bit (9) static init ("010100000"b); 120 dcl insn_4 bit (9) static init ("010100100"b); 121 dcl insm bit (9) static init ("000010000"b); 122 dcl insa bit (9) static init ("010010000"b); 123 dcl insb bit (9) static init ("010000000"b); 124 dcl insp bit (9) static init ("010110000"b); 125 dcl mvza bit (9) static init ("001010000"b); 126 dcl mvzb bit (9) static init ("001000000"b); 127 dcl mflc bit (9) static init ("001110000"b); 128 dcl mfls bit (9) static init ("001100000"b); 129 130 dcl loval char (1) static init (""); /* = */ 131 dcl space char (1) static init (" "); 132 dcl quote char (1) static init (""""); 133 dcl slash char (1) static init ("/"); 134 dcl hival char (1) static init (""); /* = \177 */ 135 dcl zero char (1) static init ("0"); 136 dcl DS char (1) static init ("f"); /* P7 dig select char */ 137 138 dcl fc_zero fixed bin static init (180); 139 dcl fc_space fixed bin static init (192); 140 dcl fc_hival fixed bin static init (221); 141 dcl fc_loval fixed bin static init (229); 142 dcl fc_quote fixed bin static init (235); 143 144 dcl msg_1 char (24) static init ("illegal sending field "); 145 dcl msg_2 char (24) static init ("illegal receiving field "); 146 147 dcl (save_sf_ptr, save_rf_ptr, const_ptr) 148 ptr; 149 dcl (m, n, n_rf, pl, pr, size, delta) 150 fixed bin; 151 dcl (lin, col) fixed bin; 152 dcl (spl, spr, rpl, rpr) 153 fixed bin; 154 dcl (fx, fl) fixed bin; 155 dcl (move_num, nc_move_num, ival_num, control_no) 156 fixed bin static init (0); 157 dcl (sf_ptr, rf_ptr) ptr; 158 dcl stk_offset fixed bin; 159 dcl cs_offset fixed bin (24); 160 dcl lit_str char (256); 161 dcl (lit_ln, idx) fixed bin; 162 dcl req_ln fixed bin; 163 dcl (sf_stack_sw, sf_category_sw) 164 fixed bin; 165 dcl snd_tkn char (500) based; 166 dcl rec_tkn char (500) based; 167 dcl ecm (256) char (1); 168 dcl ecm_str char (256) based (ecm_ptr); 169 dcl ecm_ptr ptr; 170 dcl ecm_lnth fixed bin; 171 dcl n_ecm fixed bin; 172 dcl mop (256) bit (9); 173 dcl mop_str char (256) based (mop_ptr); 174 dcl mop_ptr ptr; 175 dcl n_mop fixed bin; 176 dcl (bwz, awz, asterisk, sign) 177 fixed bin; 178 dcl tag fixed bin; 179 dcl obj_dec_pt_char char (1); 180 dcl currency_char char (1); 181 dcl (start_supp, max_supp, end_supp) 182 fixed bin; 183 dcl supp_char char (1); 184 dcl (es_status, bz_status) 185 fixed bin; 186 dcl insert_table_status char (8); 187 dcl (no_chars, no_char2, no_char1, count, insert_char_no) 188 fixed bin; 189 dcl (micro_op, insrt_op) 190 bit (9); 191 dcl (end_fix, rf_st) fixed bin; 192 dcl (right_adjust, left_adjust, overlap) 193 fixed bin; 194 dcl (sf_places, rf_places, rf_length, rf_temp_sw) 195 fixed bin; 196 dcl (opnd_ln, ecm_limit) 197 fixed bin; 198 199 dcl 1 set_ptr_struc aligned, 200 2 what_pointer fixed bin, 201 2 pointer_no bit (3), 202 2 lock fixed bin, 203 2 switch fixed bin, 204 2 segno fixed bin, 205 2 offset fixed bin (24), 206 2 reset fixed bin; 207 208 dcl 1 microp_bits aligned, 209 2 mop bit (5) unaligned, 210 2 if bit (4) unaligned; 211 212 /* inst buff */ 213 dcl eis_ (4) bit (36); 214 215 /* input buff */ 216 dcl ips (18) bit (36); 217 218 /* reloc buff */ 219 dcl 1 reloc_info (4) aligned, 220 2 left_ri bit (5) aligned, 221 2 right_ri bit (5) aligned; 222 223 224 /* type-9 token copies */ 225 226 dcl new_sf_ptr ptr; 227 dcl new_sf_tkn char (500); 228 229 dcl ms_ptr ptr; 230 dcl ms_tkn char (200); 231 232 dcl sf_cpy_ptr ptr; 233 dcl sf_tkn_cpy char (500); 234 235 dcl rf_cpy_ptr ptr; 236 dcl rf_tkn_cpy char (500); 237 238 dcl temp_tkn_ptr ptr; 239 dcl temp_tkn char (200); 240 241 /* Declaration for special fixed binary MOVE ZERO TO $. 242* statement generated by ddalloc as part of "size routines". */ 243 dcl stz_inst (2) bit (18) unaligned static init ("000000000000000000"b, "100101000001000000"b); 244 /* stz pr0|0 */ 245 246 dcl dn_ptr ptr; 247 dcl numeric_source_proc (1:5) entry (ptr, ptr) int init (dec_source, dec_source, sb_source, lb_source, opch_source); 248 249 dcl return_code fixed bin; 250 dcl work_sf_ptr ptr; 251 dcl ret_offset fixed bin; 252 dcl only_an bit (1); 253 dcl (move_special_bit, ne_bit) 254 bit (1) static init ("0"b); 255 dcl temp fixed bin; 256 dcl numeric_lit_flag fixed bin; 257 dcl in_op fixed bin; 258 259 /* 260* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ 261* */ 262 dcl ioa_$rsnnl entry options (variable), 263 cobol_addr entry (ptr, ptr, ptr), 264 cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin), 265 cobol_define_tag entry (fixed bin), 266 cobol_emit entry (ptr, ptr, fixed bin), 267 cobol_make_tagref entry (fixed bin, fixed bin, ptr), 268 cobol_make_type9$alphanumeric 269 entry (ptr, fixed bin, fixed bin (24), fixed bin), 270 cobol_make_type9$decimal_9bit 271 entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin), 272 cobol_make_type9$type2_3 273 entry (ptr, ptr), 274 cobol_pool$search_op 275 entry (char (*), fixed bin, fixed bin (24), fixed bin), 276 cobol_pool entry (char (*), fixed bin, fixed bin (24)), 277 cobol_set_pr entry (ptr, ptr), 278 cobol_get_num_code ext entry (ptr, fixed bin), 279 cobol_register$load ext entry (ptr), 280 cobol_make_type9$long_bin 281 ext entry (ptr, fixed bin, fixed bin), 282 cobol_make_type9$short_bin 283 ext entry (ptr, fixed bin, fixed bin), 284 cobol_make_type9$copy 285 ext entry (ptr, ptr), 286 cobol_make_type9$copy_sub 287 ext entry (ptr, ptr), 288 cobol_io_util$move_lit 289 entry (bit (3) aligned, fixed bin, fixed bin, char (*)), 290 signal_ entry (char (*), ptr, ptr); 291 292 dcl cobol_opch_op_call ext entry (ptr, ptr); 293 294 dcl cobol_make_bin_const 295 entry (ptr, ptr, fixed bin); 296 dcl cobol_register$release 297 ext entry (ptr); 298 299 /* 300* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ 301* */ 302 303 dcl addr builtin, 304 addrel builtin, 305 (fixed, binary) builtin, 306 index builtin, 307 null builtin, 308 substr builtin, 309 unspec builtin, 310 verify builtin; 311 312 /* |*| |*| |*| |*| |*| |*| |*| */ 313 314 /* capture ordinal # and location (in the source program) 315* of the move statement being generated */ 316 317 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ 318 319 call move_init; 320 321 /*[5.1-1]*/ 322 go to begin; /* Set hival according to collating sequence */ 323 324 /* |*| |*| |*| |*| |*| |*| 325* main move loop 326* 327* increment rf idx (m=m+1) 328* check for more (ie multiple) receiving fields 329* if not, return 330* if yes, set rf_ptr to in_token.token_ptr(m) 331* and restore sending field. 332* |*| |*| |*| |*| |*| |*| */ 333 334 do while ("1"b); 335 336 m = m + 1; /* wrap up */ 337 /* set rf_ptr to next token pointer in stack */ 338 339 if sf_category_sw = 1 /* Category was changed from numeric to alphanumeric */ 340 then do; 341 342 sf_ptr -> data_name.numeric = "1"b; 343 sf_ptr -> data_name.alphanum = "0"b; 344 end; 345 346 if sf_category_sw = 2 /* Category was changed from alphanumeric to numeric */ 347 then do; 348 349 sf_ptr -> data_name.alphanum = "1"b; 350 sf_ptr -> data_name.numeric = "0"b; 351 end; 352 353 /*[5.1-1]*/ 354 if m > n_rf 355 then go to move_done; 356 357 /* 358* If sending (sf) and receiving (rf) fields overlap or sf is sub- 359* scripted, and there are more than one receiving field, 360* the contents of the sending filed are copied into the 361* stack and this temporary is used as the sending field. This is 362* done to insure that the original value if sf (as it existed at 363* the beginning of the MOVE operation) is moved to each rf. If 364* sf is numeric with leading separate sign (sign_type - "100"b), 365* the temporary is defined as numeric with trailing separate sign 366* (sign_type = "011"b). (Depending upon the rf, a change in sf 367* from leading to trailing sign may be required for implementa- 368* tion purposes. The change is made here to eliminate the pos- 369* sibility of moving from one temp to another.) In all other 370* cases, an alphanumeric (MLR) move is employed. 371* */ 372 begin: /*[5.1-1]*/ 373 rf_ptr = in_token.token_ptr (m + 2); /*[5.1-1]*/ 374 sf_ptr = save_sf_ptr; 375 376 /*[4.4-2]*/ 377 if sf_ptr -> data_name.type = 13 378 then call type_13_to_9 (sf_ptr, addr (SF_dn)); 379 380 /* sending field is type 13 token */ 381 382 /*[4.4-2]*/ 383 if rf_ptr -> data_name.type = 13 384 then call type_13_to_9 (rf_ptr, addr (RF_dn)); 385 386 /* receiving field is type 13 token */ 387 388 389 if sf_stack_sw ^= 1 390 then call move_stack; 391 392 /* |*| |*| |*| |*| |*| |*| 393* check data type of sending field 394* 395* ck sf = type-9 data name 396* if yes, goto move_4 397* if not, 398* ck sf = type-3 alphanumeric literal 399* if yes, 400* - pool literal and create type-9 token 401* for it (via cobol_make_type9$type2_3) 402* - set created token as sending field token 403* - ck literal preceeded by word "ALL" 404* if yes, goto move_fig_con_al 405* if not, goto move_4 406* if not, 407* ck sf = type-2 numeric literal 408* if yes, goto move_3 409* if not, 410* ck sf = type-1 figurative constant 411* if yes, goto fig_con_rw 412* 413* if not, call error (illegal sending field) 414* 415* |*| |*| |*| |*| |*| |*| */ 416 417 if (sf_ptr -> data_name.type = 9) 418 then call move_type9; 419 420 else if (sf_ptr -> data_name.type = 3) 421 then call move_type3; 422 423 else if sf_ptr -> data_name.type = 2 424 then call move_type2; 425 else if sf_ptr -> data_name.type = 1 426 then call move_fig_con_rw; 427 else do; 428 call error (msg_1); 429 go to move_done; 430 end; 431 432 end; 433 434 move_done:/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 435 return; 436 437 move_init: 438 proc; 439 440 if (control_no ^= cobol_$compile_count) 441 then do; 442 443 move_num = 0; 444 control_no = cobol_$compile_count; 445 end; 446 447 move_num = move_num + 1; 448 449 if (in_token.token_ptr (1) ^= null) 450 then do; 451 452 rw_ptr = in_token.token_ptr (1); 453 lin = reserved_word.line; 454 col = reserved_word.column; 455 456 if ((lin = 0) & (col = 0)) 457 then ival_num = ival_num + 1; 458 end; 459 else do; 460 461 sf_ptr = in_token.token_ptr (2); 462 lin = sf_ptr -> data_name.line; 463 col = sf_ptr -> data_name.column; 464 move_num = move_num - 1; 465 nc_move_num = nc_move_num + 1; 466 end; 467 468 /* |*| |*| |*| |*| |*| |*| |*| */ 469 470 /* |*| |*| |*| |*| |*| |*| 471* set sf_ptr = in_token.token_ptr(2) 472* set eos_ptr = in_token.token_ptr(n) 473* get # receiving fields from end_stmt.e 474* set receiving field idx (m) =0 475* set overlap switch = 0 476* set error_sw = 0; 477* create pointers to based data 478* |*| |*| |*| |*| |*| |*| */ 479 480 sf_ptr, save_sf_ptr = in_token.token_ptr (2); 481 eos_ptr = in_token.token_ptr (in_token.n); 482 483 if end_stmt.e > 9999 484 then do; 485 486 end_stmt.e = end_stmt.e - 10000; 487 only_an = "1"b; 488 end; 489 else only_an = "0"b; 490 491 n_rf = end_stmt.e; /*[5.1-1]*/ 492 m = 1; 493 input_ptr = addr (ips); 494 inst_ptr = addr (eis_); 495 reloc_ptr = addr (reloc_info); 496 new_sf_ptr = addr (new_sf_tkn); 497 ms_ptr = addr (ms_tkn); 498 sf_cpy_ptr = addr (sf_tkn_cpy); 499 rf_cpy_ptr = addr (rf_tkn_cpy); 500 temp_tkn_ptr = addr (temp_tkn); 501 sf_category_sw = 0; 502 numeric_lit_flag = 0; 503 sf_stack_sw = 0; 504 505 if fixed_common.obj_dec_comma = "0"b 506 then obj_dec_pt_char = "."; 507 else obj_dec_pt_char = ","; 508 509 currency_char = fixed_common.object_sign; 510 511 end; 512 513 514 move_stack: 515 proc; 516 517 if (rf_ptr -> data_name.overlap & sf_ptr -> data_name.type = 9) 518 | (sf_ptr -> data_name.type = 9 & sf_ptr -> data_name.subscripted = "1"b & n_rf > 1) 519 then do; 520 521 /* Allocate space on stack and create token for temp */ 522 sf_stack_sw = 1; 523 size = sf_ptr -> data_name.item_length; 524 525 call cobol_alloc$stack (size, 0, stk_offset); 526 527 substr (new_sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = 528 substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size); 529 530 new_sf_ptr -> data_name.linkage_section = "0"b; 531 new_sf_ptr -> data_name.subscripted = "0"b; 532 new_sf_ptr -> data_name.seg_num = 1000; 533 new_sf_ptr -> data_name.offset = stk_offset; 534 535 if sf_ptr -> data_name.numeric 536 then do; 537 538 if sf_ptr -> data_name.sign_type = "100"b 539 then new_sf_ptr -> data_name.sign_type = "011"b; 540 541 call num_to_num (sf_ptr, new_sf_ptr); 542 543 end; 544 else call gen_move_alpha (MLR, "000100000"b, sf_ptr, new_sf_ptr, "0"b); 545 546 sf_ptr, save_sf_ptr = new_sf_ptr; 547 end; 548 549 end; 550 551 552 move_type3: 553 proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE3");/**/ 554 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 555 alit_ptr = sf_ptr; 556 557 if (alphanum_lit.all_lit) 558 then do; 559 560 /* sf token is type3, alphanumeric literal, with all_lit bit 561* set to 1. Input was ALL literal, where literal is NOT one 562* of the other figurative constants. Copy literal into 563* lit_str and set lit_ln to length of literal. */ 564 565 lit_ln = alphanum_lit.lit_size; 566 substr (lit_str, 1, lit_ln) = substr (alphanum_lit.string, 1, lit_ln); 567 568 call move_fig_con; 569 570 end; 571 572 else if ^(rf_ptr -> data_name.alphanum_edited) & ^(rf_ptr -> data_name.numeric_edited) 573 & ^(rf_ptr -> data_name.numeric) & ^(rf_ptr -> data_name.alphabetic_edited) 574 & ^(rf_ptr -> data_name.variable_length) & ^(rf_ptr -> data_name.just_right) 575 & ^(rf_ptr -> data_name.subscripted) 576 then do; 577 578 lit_ln = alphanum_lit.lit_size; 579 580 call gen_move_lit (alphanum_lit.string, lit_ln, rf_ptr); 581 582 end; 583 else do; 584 585 call cobol_make_type9$type2_3 (new_sf_ptr, sf_ptr); 586 587 sf_ptr, save_sf_ptr = new_sf_ptr; 588 589 call move_type9; 590 591 end; 592 593 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 594 595 end; 596 597 598 /* |*| |*| |*| |*| |*| |*| 599* sending field = type-2 numeric literal 600* check receiving field = binary data 601* - if not, goto alloc_nl 602* - if yes, ck literal for fractional component 603* if yes, goto alloc_nl 604* if not, ck magnitude of literal value for pooling 605* if (lit val > (2**18)-1), then: 606* create binary equivalent of literal value 607* allocate this value as literal (alloc_nl) 608* if (lit val < or = (2**18)-1) then: 609* get (and LOCK) A (or Q) Register 610* generate LDA or LDQ - DIRECT (upper or lower) 611* 612* - alloc_nl: 613* - allocate numeric literal 614* - create type-9 token for allocated literal 615* (via make_t9_from_t2) 616* - continue processing at move_4 617* |*| |*| |*| |*| |*| |*| */ 618 619 move_type2: 620 proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE2");/**/ 621 /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 622 nlit_ptr = sf_ptr; 623 624 /* allocate literal and create type-9 token 625* continue processing at move_4 */ 626 627 sf_ptr, save_sf_ptr = addr (new_sf_tkn); 628 substr (new_sf_tkn, 1, 250) = (250)""; 629 substr (new_sf_tkn, 251, 250) = (250)""; 630 631 if rf_ptr -> data_name.bin_18 632 then call cobol_make_bin_const (nlit_ptr, sf_ptr, 3); 633 634 else if rf_ptr -> data_name.bin_36 635 then call cobol_make_bin_const (nlit_ptr, sf_ptr, 4); 636 637 else do; 638 639 sf_ptr -> data_name.size = 112; 640 sf_ptr -> data_name.line = numeric_lit.line; 641 sf_ptr -> data_name.type = 9; 642 sf_ptr -> data_name.elementary = "1"b; 643 sf_ptr -> data_name.numeric = "1"b; 644 sf_ptr -> data_name.display = "1"b; 645 646 numeric_lit_flag = 1; 647 648 if (numeric_lit.integral) 649 then sf_ptr -> data_name.pic_integer = "1"b; 650 651 sf_ptr -> data_name.places_left = numeric_lit.places_left; 652 sf_ptr -> data_name.places_right = numeric_lit.places_right; 653 654 lit_ln, sf_ptr -> data_name.item_length = numeric_lit.places; 655 substr (lit_str, 1, lit_ln) = substr (numeric_lit.literal, 1, lit_ln); 656 657 if (numeric_lit.sign ^= space) 658 then do; 659 660 sf_ptr -> data_name.sign_separate = "1"b; 661 sf_ptr -> data_name.sign_type = "011"b; 662 sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1; 663 substr (lit_str, lit_ln + 1, 1) = substr (numeric_lit.sign, 1, 1); 664 end; 665 else do; 666 667 sf_ptr -> data_name.sign_type = "000"b; 668 substr (lit_str, lit_ln + 1, 1) = " "; 669 end; 670 671 call cobol_pool$search_op (substr (lit_str, 1, sf_ptr -> data_name.item_length), 0, cs_offset, in_op); 672 673 if in_op = 1 674 then sf_ptr -> data_name.seg_num = 3; 675 else sf_ptr -> data_name.seg_num = 3000; 676 677 sf_ptr -> data_name.offset = cs_offset; 678 679 end; 680 681 call move_type9; 682 683 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 684 685 end; 686 687 /* |*| |*| |*| |*| |*| |*| 688* sending field = type-9 data name 689* check receiving field parameters 690* 691* check rf = type-9 data name 692* 693* - if not, call error (illegal receiving field) 694* 695* check group-move (either sf or rf = non-elementary) 696* - if yes, goto move_alpha (group-move = alpha data move) 697* 698* check sf = numeric data type 699* 700* - if not, then sf={a}|{an}; (where {an}:={an}|{ae}|{ane}|{n}|{ne}) 701* ck rf = alphabetic or alphanumeric 702* if yes, {a or an -> a or an} goto move_alpha 703* if not, ck rf = alpha-ed or alphanum-ed 704* if yes, sf={a}|{an} -> rf={ae}|{ane} goto move_alpha_edit 705* if not, then, sf = {an} and rf = {n} or {ne} 706* copy sf token 707* set token_copy to numeric 708* set sf_ptr to token_copy 709* continue at sf = {n} 710* - if yes, then sf = {n} 711* ck rf = numeric 712* if yes, {n -> n} goto move_num 713* if not, ck rf = numeric_edited 714* if yes, {n} -> {ne} goto move_num_ed 715* if not, then sf = {n} and rf = {an} 716* continue at ck_n_an 717* |*| |*| |*| |*| |*| |*| */ 718 719 move_type9: 720 proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE9");/**/ 721 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 722 723 /*[4.4-1]*/ 724 ne_bit = sf_ptr -> data_name.numeric; 725 726 if (rf_ptr -> data_name.type ^= 9) 727 then call error (msg_2); 728 729 else if (rf_ptr -> data_name.non_elementary) 730 then do; 731 732 if sf_ptr -> data_name.non_elementary = "0"b 733 then do; 734 735 if sf_ptr -> data_name.numeric 736 then do; 737 738 if sf_ptr -> data_name.variable_length 739 then do; 740 741 move_special_bit = "1"b; 742 call move_special; 743 744 end; 745 746 else do; 747 748 sf_category_sw = 1; 749 sf_ptr -> data_name.numeric = "0"b; 750 sf_ptr -> data_name.alphanum = "1"b; 751 752 call move_alpha; 753 754 end; 755 end; 756 757 else call move_alpha; 758 759 end; 760 761 else call move_alpha; 762 763 end; 764 765 else if sf_ptr -> data_name.non_elementary 766 then do; /* Source is non-elementary. */ 767 768 if rf_ptr -> data_name.non_elementary = "0"b 769 then if rf_ptr -> data_name.numeric 770 then do; /* Target is numeric. */ 771 /* Change target token so that it looks like an alphanumeric. */ 772 rf_ptr -> data_name.numeric = "0"b; 773 rf_ptr -> data_name.alphanum = "1"b; 774 775 end; /* Target is numeric. */ 776 777 call move_alpha; 778 779 end; /* Source is non-elementary. */ 780 781 else if (sf_ptr -> data_name.numeric) 782 then call ck_n_ne; 783 784 785 786 else do; 787 788 if sf_ptr -> data_name.numeric_edited 789 then do; 790 791 /* The only legal receiving items for ne sending items 792* are an and ane. In moves involving such data as 793* receiving items, the sending items must be described 794* as alphanumeric. Make one time change in sending 795* item. */ 796 sf_ptr -> data_name.numeric_edited = "0"b; 797 sf_ptr -> data_name.alphanum = "1"b; 798 sf_ptr -> data_name.places_left = sf_ptr -> data_name.item_length; 799 800 end; 801 802 /* sf = {a}|{an}|{ae}|{ane} ck rf = {a}|{an}|{ae}|{ane}) */ 803 804 if rf_ptr -> data_name.alphanum | rf_ptr -> data_name.alphabetic 805 then call move_alpha; 806 807 else if rf_ptr -> data_name.alphanum_edited | rf_ptr -> data_name.alphabetic_edited 808 then call move_alpha_edit; 809 810 else call move_special; 811 812 end; 813 814 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 815 816 end; 817 818 move_special: 819 proc;/***..... dcl LOCAL_NAME char (12) int static init ("MOVE_SPECIAL");/**/ 820 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 821 822 if (sf_ptr -> data_name.seg_num <= 5008 & sf_ptr -> data_name.seg_num >= 5000) 823 | (sf_ptr -> data_name.seg_num <= 12287 & sf_ptr -> data_name.seg_num >= 8192) | move_special_bit = "1"b 824 then do; 825 826 /* Length of the source is in a register, not in the data name token. */ 827 /* NOTE: Segment number 5000 thru 5008 and 8192 thru 12287 occur 828* only when the STRING/UNSTRING generator is attempting to STRING/UNSTRING 829* an alphanumeric into a numeric. This is a VERY SPECIAL CASE 830* and is handled here, only for convenience of STRING/UNSTRING. */ 831 832 /* Must move the source (an alphanumeric), into a temporary, 833* right justified, with leading decimal zeroes. */ 834 835 call cobol_alloc$stack (32, 0, ret_offset); 836 837 /* Make an alphanumeric token for the temporary. */ 838 work_sf_ptr = null (); 839 840 call cobol_make_type9$alphanumeric (work_sf_ptr, 1000, fixed (ret_offset, 24), 32); 841 842 843 /* Move the source into the temporary. */ 844 845 if move_special_bit 846 then do; 847 848 move_special_bit = "0"b; 849 850 call gen_move_alpha (MLR, "000110000"b, sf_ptr, work_sf_ptr, "0"b); 851 852 end; 853 854 else call gen_move_alpha (MRL, "000110000"b /* decimal zero */, sf_ptr, work_sf_ptr, "0"b); 855 856 sf_ptr = work_sf_ptr; 857 858 end; /* Length of the source is in a register, not in the data name token. */ 859 860 /* sf = {an}; rf = {n} or {ne} 861* set numeric bit in token to "1"b 862* continue at ck_n_ne */ 863 864 sf_category_sw = 2; 865 sf_ptr -> data_name.numeric = "1"b; 866 sf_ptr -> data_name.alphanum = "0"b; 867 sf_ptr -> data_name.places_left = sf_ptr -> data_name.item_length; 868 sf_ptr -> data_name.display = "1"b; 869 870 call ck_n_ne; 871 872 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 873 874 end; 875 876 ck_n_ne: 877 proc;/***..... dcl LOCAL_NAME char (7) int static init ("CK_N_NE");/**/ 878 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 879 880 if rf_ptr -> data_name.numeric 881 then call num_to_num (sf_ptr, rf_ptr); 882 883 else if rf_ptr -> data_name.numeric_edited 884 then call move_numer_ed; 885 886 /* |*| |*| |*| |*| |*| |*| 887* sf = {n}; rf = {an} or {ane} 888* Operational separate signs are not moved from n to an 889* or ane receiving fields, therefore - 890* - copy sf, set item_length to item_length-1, and sign 891* type to "000"b 892* - if sign type of sf is trailing separate, set sf_ptr 893* to point to new token 894* - if sign type is leading sign, generate MVN instruc- 895* tion to move sf to a stack temporary defined by new 896* token; then set sf_ptr to point to new token 897* */ 898 899 else do; 900 901 substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = 902 substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size); 903 904 /*[4.2-2]*/ 905 if sf_ptr -> data_name.display & sf_ptr -> data_name.sign_type = "100"b 906 /*[4.2-2]*/ 907 then do; 908 sf_ptr -> data_name.offset = sf_ptr -> data_name.offset + 1; 909 /* lead sep sign */ 910 /*[4.2-2]*/ 911 sf_cpy_ptr = sf_ptr; /*[4.2-2]*/ 912 end; 913 914 /*[4.2-2]*/ 915 else if ^sf_ptr -> data_name.display /*[4.2-2]*/ 916 | 917 /*[4.2-2]*/ (sf_ptr -> data_name.display /*[4.2-2]*/ 918 & /*[4.2-2]*/ sf_ptr -> data_name.item_signed /*[4.2-2]*/ 919 & /*[4.2-2]*/ ^sf_ptr -> data_name.sign_separate /*[4.2-2]*/) 920 then do; 921 922 923 /* Source variable is leading separate sign, overpunch, or not display (i.e. is packed dec or bin) */ 924 /* Generate code to convert source to unpacked decimal trailing sign */ 925 926 call num_to_udts (sf_ptr, sf_cpy_ptr, return_code); 927 928 if return_code ^= 0 929 then go to ckx; 930 931 end; 932 933 /* Source variable is leading separate sign, or not display (i.e. is packed dec or bin */ 934 935 if sf_cpy_ptr -> data_name.sign_separate 936 then sf_cpy_ptr -> data_name.item_length = sf_cpy_ptr -> data_name.item_length - 1; 937 938 sf_ptr = sf_cpy_ptr; 939 sf_ptr -> data_name.alphanum = "1"b; 940 sf_ptr -> data_name.numeric = "0"b; 941 942 943 if (rf_ptr -> data_name.alphanum) 944 then call move_alpha; 945 else call move_alpha_edit; 946 947 end; 948 949 ckx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 950 end; 951 952 /* ALPHA MOVE (alphabetic and/or alphanumeric) */ 953 954 /* |*| |*| |*| |*| |*| |*| 955* sf and rf described by input (or created) type-9 tokens 956* ck rf = JUSTIFIED 957* if yes, instr = MRL 958* if not, instr = MLR 959* set FILL = SPACE 960* generate proper EIS alpha move instruction (via cobol_addr) 961* build DESCRIPTORS (for sf and rf) 962* emit instruction (via cobol_emit) 963* on completion, goto move_0 964* |*| |*| |*| |*| |*| |*| */ 965 966 967 move_alpha: 968 proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_ALPHA");/**/ 969 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 970 971 if (rf_ptr -> data_name.just_right) 972 then instr = MRL; 973 else instr = MLR; 974 975 /* [4.0-2] */ 976 /* if (rf_ptr -> data_name.non_elementary & rf_ptr -> data_name.variable_length) then rf_ptr -> 977* data_name.variable_length = "0"b; */ 978 /* [4.0-2] */ 979 980 call gen_move_alpha (instr, "000100000"b, sf_ptr, rf_ptr, "0"b); 981 982 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 983 984 end; 985 986 /* NUMERIC MOVE */ 987 988 /* |*| |*| |*| |*| |*| |*| 989* sf and rf described by input (or created) type-9 tokens 990* ck sf = decimal 991* if yes, {sf = dec} 992* ck rf = decimal 993* if yes, {sf=dec; rf=dec} go to ck_sign 994* if not, {sf=dec; rf=bin} 995* ck sf = numeric integer (ni) 996* if yes, {sf=dec(ni); -> rf=bin} 997* - generate eis DTB instruction 998* - return 999* if not, {sf=dec(nni) -> rf=bin} 1000* - allocate space on stack (= integer portion of sf) 1001* - create type-9 token for temp_rf (on stack) 1002* - set rounded bit if actual rf = rounded 1003* - generate MVN {dec->dec} to move integer portion of 1004* actual sf to temp_rf (on stack) 1005* - establish temp_rf (on stack) as actual sf 1006* - goto generate DTB (above) to move (and convert) 1007* temp_rf (= integer portion of actual sf) 1008* to actual rf 1009* -return 1010* if not, {sf = binary} 1011* ck rf = decimal 1012* if not, {sf=bin; rf=bin} 1013* - get and LOCK A (or Q) register 1014* - generate LDA (or LDQ) using instr_basic and input_basic 1015* num_1: - generate STA (or STQ) using instr_basic and input_basic 1016* - UNLOCK A (or Q) register 1017* - return 1018* if yes, {sf=bin; rf=dec} 1019* ck rf = integer 1020* if yes, {sf=bin -> dec(ni)} 1021* - reset non_int_sw (=0) 1022* - goto generate BTD (below) 1023* if not, {sf=bin -> dec(nni)} 1024* - set non_int_sw (=1) 1025* - allocate space on stack(= integer portion of rf) 1026* - create type-9 token for temp_rf (on stack) 1027* - generate BTD move to move actual sf to temp_rf (on stack) 1028* - establish temp_rf (on stack) as actual_sf 1029* - ck non_integer_switch (=0?) 1030* if yes, {complete 2nd part of non-integer bin->dec move} 1031* - generate MVN to move temp_rf (= converted 1032* integer portion of bin sf (on stack) to actual_rf 1033* - return 1034* if not, {bin integer sf moved & converted to dec rf} 1035* - return 1036* |*| |*| |*| |*| |*| |*| */ 1037 1038 /* FIGURATIVE CONSTANT MOVE */ 1039 1040 /* |*| |*| |*| |*| |*| |*| 1041* figurative constant moves come in two flavors: 1042* |*| |*| |*| |*| |*| |*| |*| */ 1043 1044 move_fig_con_rw: 1045 proc; /* sf token is type1, reserved word. Input was figurative 1046* constant including ALL literal where literal IS one of the 1047* other figurative constants. (ALL ZEROS, for example has 1048* been replaced by its equivalent, ZERO, by PD Syntax. */ 1049 /* Identify figurative constant from key, place corresponding 1050* character in lit_str, and set lit_ln to 1. */ 1051 1052 /***..... dcl LOCAL_NAME char (15) int static init ("MOVE_FIG_CON_RW");/**/ 1053 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 1054 1055 rw_ptr = sf_ptr; 1056 lit_ln = 1; 1057 1058 if reserved_word.key = fc_zero 1059 then do; 1060 1061 /* Special code included to process MOVE ZERO TO $. 1062* statement generated by ddalloc as part of size 1063* routine for OCCOUS ---- DEPENDING clauses. */ 1064 1065 if rf_ptr -> data_name.temporary 1066 & substr (rf_ptr -> data_name.name, 1, rf_ptr -> data_name.name_size) = "$" 1067 then do; 1068 1069 input_struc_basic.type = 1; 1070 input_struc_basic.operand_no = 0; 1071 input_struc_basic.lock = 0; 1072 input_struc_basic.segno = rf_ptr -> data_name.seg_num; 1073 input_struc_basic.char_offset = rf_ptr -> data_name.offset; 1074 input_struc_basic.send_receive = 1; 1075 1076 call cobol_addr (input_ptr, addr (stz_inst), null); 1077 1078 call cobol_emit (addr (stz_inst), null, 1); 1079 1080 end; 1081 1082 else do; 1083 1084 substr (lit_str, 1, 1) = zero; 1085 call move_fig_con; 1086 1087 end; 1088 end; 1089 1090 else if reserved_word.key = fc_space 1091 then do; 1092 1093 substr (lit_str, 1, 1) = space; 1094 1095 call move_fig_con; 1096 1097 end; 1098 1099 else if reserved_word.key = fc_hival 1100 then do; 1101 1102 if cobol_$main_pcs_ptr ^= null () 1103 then substr (lit_str, 1, 1) = cobol_$main_pcs_ptr -> alphabet_name.hival_char; 1104 else substr (lit_str, 1, 1) = hival; 1105 1106 call move_fig_con; 1107 1108 end; 1109 1110 else if reserved_word.key = fc_loval 1111 then do; 1112 1113 if cobol_$main_pcs_ptr ^= null () 1114 then substr (lit_str, 1, 1) = cobol_$main_pcs_ptr -> alphabet_name.loval_char; 1115 else substr (lit_str, 1, 1) = loval; 1116 1117 call move_fig_con; 1118 1119 end; 1120 1121 else do; 1122 1123 if reserved_word.key = fc_quote 1124 then substr (lit_str, 1, 1) = quote; 1125 1126 call move_fig_con; 1127 1128 end; 1129 1130 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 1131 1132 end; 1133 1134 move_fig_con: 1135 proc; /* Proceed on basis of rf data category */ 1136 /***..... dcl LOCAL_NAME char (12) int static init ("MOVE_FIG_COM");/**/ 1137 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 1138 1139 if rf_ptr -> data_name.alphanum | rf_ptr -> data_name.alphabetic = "1"b 1140 | rf_ptr -> data_name.non_elementary = "1"b 1141 then do; 1142 1143 if lit_ln = 1 1144 then do; 1145 1146 call replicate; 1147 1148 go to mfcx; 1149 end; 1150 else do; 1151 1152 pl = rf_ptr -> data_name.item_length; 1153 /* Compute minimum length string that must be created 1154* and pooled. */ 1155 /*[4.0-1]*/ 1156 if pl > 128 & pl > lit_ln 1157 then do; 1158 1159 /*[4.0-1]*/ 1160 req_ln = ((lit_ln + 127) / lit_ln) * lit_ln; 1161 if req_ln >= pl 1162 then req_ln = pl; 1163 end; 1164 else req_ln = pl; 1165 1166 call build_litstr; 1167 1168 if (req_ln = pl) & (rf_ptr -> data_name.subscripted = "0"b) 1169 then do; 1170 1171 call gen_move_lit (lit_str, req_ln, rf_ptr); 1172 1173 end; 1174 else do; 1175 1176 call cobol_pool$search_op (substr (lit_str, 1, req_ln), 0, cs_offset, in_op); 1177 1178 set_ptr_struc.what_pointer = 10; 1179 set_ptr_struc.lock = 0; 1180 set_ptr_struc.switch = 0; 1181 1182 call cobol_set_pr (addr (set_ptr_struc), rf_ptr); 1183 1184 if in_op = 1 1185 then eis_ (1) = "000100000001000000001000000101000000"b; 1186 else eis_ (1) = "000100000001000000001000000100000100"b; 1187 1188 i = -(cs_offset / 4 + cobol_$text_wd_off); 1189 substr (inst_struc.desc.desc_od (1), 1, 18) = substr (unspec (i), 19, 18); 1190 substr (inst_struc.desc.desc_od (1), 19, 6) = "000000"b; 1191 substr (inst_struc.desc.desc_od (1), 25, 12) = substr (unspec (req_ln), 25, 12); 1192 substr (inst_struc.desc.desc_od (2), 1, 3) = set_ptr_struc.pointer_no; 1193 substr (inst_struc.desc.desc_od (2), 4, 15) = (15)"0"b; 1194 substr (inst_struc.desc.desc_od (2), 19, 18) = 1195 substr (inst_struc.desc.desc_od (1), 19, 18); 1196 1197 call cobol_emit (inst_ptr, null, 3); 1198 1199 eis_ (1) = "000100000001000000001000000101000000"b; 1200 inst_struc.desc.desc_od (1) = inst_struc.desc.desc_od (2); 1201 1202 substr (inst_struc.desc.desc_od (2), 4, 17) = substr (unspec (req_ln), 20, 17); 1203 1204 i = pl - req_ln; 1205 1206 substr (inst_struc.desc.desc_od (2), 25, 12) = substr (unspec (i), 25, 12); 1207 1208 call cobol_emit (inst_ptr, null, 3); 1209 1210 end; 1211 end; 1212 go to mfcx; 1213 end; 1214 1215 if rf_ptr -> data_name.alphanum_edited | rf_ptr -> data_name.alphabetic_edited = "1"b 1216 then do; 1217 1218 req_ln = rf_ptr -> data_name.places_left; 1219 1220 call build_litstr; 1221 1222 call cobol_pool$search_op (substr (lit_str, 1, req_ln), 0, cs_offset, in_op); 1223 1224 if in_op = 0 1225 then temp = 3000; 1226 else temp = 3; 1227 1228 call cobol_make_type9$alphanumeric (new_sf_ptr, temp, cs_offset, req_ln); 1229 1230 sf_ptr = new_sf_ptr; 1231 call move_alpha_edit; 1232 1233 go to mfcx; 1234 end; 1235 1236 pl = rf_ptr -> data_name.places_left; 1237 pr = rf_ptr -> data_name.places_right; 1238 1239 if rf_ptr -> data_name.numeric 1240 then do; 1241 1242 if pl > 0 1243 then do; 1244 1245 if pr > 0 1246 then do; 1247 1248 req_ln = pl; 1249 pr = 0; 1250 end; 1251 else req_ln = pl + pr; 1252 1253 call build_litstr_right_just; 1254 1255 end; 1256 else do; 1257 1258 substr (lit_str, 1, 1) = zero; 1259 pl = 1 - pr; 1260 end; 1261 end; 1262 else do; 1263 1264 if pl > 0 1265 then do; 1266 1267 if pr > 0 1268 then req_ln = pl; 1269 else req_ln = pl + pr; 1270 1271 call build_litstr_right_just; 1272 1273 end; 1274 else req_ln = 0; 1275 if pr > 0 1276 then substr (lit_str, req_ln + 1, pl + pr - req_ln) = (30)"0"; 1277 end; 1278 1279 call cobol_pool$search_op (substr (lit_str, 1, pl + pr), 0, cs_offset, in_op); 1280 1281 if in_op = 0 1282 then temp = 3000; 1283 else temp = 3; 1284 1285 call cobol_make_type9$decimal_9bit (new_sf_ptr, temp, cs_offset, pl, pr); 1286 1287 sf_ptr = new_sf_ptr; 1288 sf_ptr -> data_name.sign_type = "000"b; 1289 sf_ptr -> data_name.item_signed = "0"b; 1290 sf_ptr -> data_name.sign_separate = "0"b; 1291 sf_ptr -> data_name.item_length = pl + pr; 1292 1293 if rf_ptr -> data_name.numeric 1294 then call num_to_num (sf_ptr, rf_ptr); 1295 else call move_numer_ed; 1296 1297 mfcx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 1298 end; 1299 1300 move_alpha_edit: 1301 proc;/***..... dcl LOCAL_NAME char (15) int static init ("MOVE_ALPHA_EDIT");/**/ 1302 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 1303 1304 ecm_ptr = addr (ecm); 1305 mop_ptr = addr (mop); 1306 delta = fixed (substr (unspec (rf_ptr -> data_name.edit_ptr), 1, 34), 36); 1307 edit_ptr = addrel (rf_ptr, delta); 1308 ecm_lnth = editor.ecm_size; 1309 substr (ecm_str, 1, ecm_lnth) = substr (editor.ecm, 1, ecm_lnth); 1310 1311 sf_places = sf_ptr -> data_name.item_length; 1312 rf_places = rf_ptr -> data_name.places_left; 1313 rf_length = rf_ptr -> data_name.item_length; 1314 1315 if rf_length > 63 1316 then if rf_ptr -> data_name.subscripted 1317 then do; 1318 1319 rf_temp_sw = 1; 1320 1321 call cobol_alloc$stack (rf_length, 0, stk_offset); 1322 1323 substr (rf_cpy_ptr -> rec_tkn, 1, rf_ptr -> data_name.size) = 1324 substr (rf_ptr -> snd_tkn, 1, rf_ptr -> data_name.size); 1325 1326 save_rf_ptr = rf_ptr; 1327 rf_ptr = rf_cpy_ptr; 1328 rf_ptr -> data_name.linkage_section = "0"b; 1329 rf_ptr -> data_name.subscripted = "0"b; 1330 rf_ptr -> data_name.seg_num = 1000; 1331 rf_ptr -> data_name.offset = stk_offset; 1332 end; 1333 1334 if sf_places > 63 1335 then if sf_ptr = save_sf_ptr 1336 then do; 1337 1338 substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = 1339 substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size); 1340 1341 sf_ptr = sf_cpy_ptr; 1342 end; 1343 1344 if rf_places > sf_places 1345 then do; 1346 1347 count = 0; 1348 no_chars = rf_places - sf_places; /* Fix the move for scaled item. */ 1349 if sf_ptr -> data_name.places_right < 0 1350 then no_char1 = -sf_ptr -> data_name.places_right; 1351 else no_char1 = 0; 1352 1353 if rf_ptr -> data_name.just_right = "0"b 1354 then do n = ecm_lnth to 1 by -1 while (count < no_chars); 1355 if ecm (n) = DS 1356 then do; 1357 1358 if count >= (no_chars - no_char1) 1359 then ecm (n) = "0"; 1360 else ecm (n) = " "; 1361 count = count + 1; 1362 end; 1363 end; 1364 1365 else do; 1366 1367 no_chars = no_chars - no_char1; 1368 1369 if no_chars > 0 1370 then do n = 1 to ecm_lnth by 1 while (count < no_chars); 1371 if ecm (n) = DS 1372 then do; 1373 1374 ecm (n) = " "; 1375 count = count + 1; 1376 end; 1377 end; 1378 1379 if no_char1 > 0 1380 then do; 1381 1382 count = 0; 1383 do n = ecm_lnth to 1 by -1 while (count < no_char1); 1384 if ecm (n) = DS 1385 then do; 1386 1387 ecm (n) = "0"; 1388 count = count + 1; 1389 end; 1390 end; 1391 end; 1392 end; 1393 left_adjust = 0; 1394 right_adjust = 0; 1395 end; 1396 1397 else do; 1398 1399 if rf_ptr -> data_name.just_right = "0"b 1400 then do; 1401 1402 left_adjust = 0; 1403 right_adjust = sf_places - rf_places; 1404 end; 1405 1406 else do; 1407 1408 left_adjust = sf_places - rf_places; 1409 right_adjust = 0; 1410 end; 1411 1412 if sf_places > 63 1413 then do; 1414 1415 if left_adjust ^= 0 1416 then call calc_char_offset (left_adjust, sf_ptr); 1417 1418 sf_ptr -> data_name.item_length = rf_places; 1419 sf_ptr -> data_name.places_left = rf_places; 1420 left_adjust = 0; 1421 right_adjust = 0; 1422 end; 1423 end; 1424 1425 /* For the move alphanumeric edited instruction, the maximum 1426* allowable length of the sending operand, the micro opera- 1427* tion, and the receiving operand is 63 characters. */ 1428 1429 opnd_ln = 0; 1430 n_mop = 1; 1431 rf_temp_sw = 0; 1432 1433 do while (rf_length > 0); 1434 insert_table_status = " *+-$,.0"; 1435 n_ecm = opnd_ln + 1; 1436 1437 if rf_length > 63 1438 then opnd_ln = 63; 1439 else opnd_ln = rf_length; 1440 1441 if left_adjust ^= 0 1442 then do; 1443 1444 no_chars = left_adjust; 1445 micro_op = ign; 1446 1447 call move_mult_micro_op; 1448 1449 end; 1450 1451 ecm_limit = n_ecm + opnd_ln - 1; 1452 do n = n_ecm to ecm_limit by 1; 1453 1454 count = verify (substr (ecm_str, n, ecm_limit - n + 1), ecm (n)); 1455 1456 if count = 0 1457 then count = ecm_limit - n + 1; 1458 else count = count - 1; 1459 no_chars = count; 1460 1461 if ecm (n) = DS 1462 then do; 1463 1464 left_adjust = left_adjust + count; 1465 micro_op = mvc; 1466 1467 call move_mult_micro_op; 1468 1469 end; 1470 1471 else do; 1472 1473 insrt_op = insp; 1474 1475 call move_insert_chars; 1476 1477 end; 1478 1479 n = n + count - 1; 1480 end; 1481 1482 rf_length = rf_length - opnd_ln; 1483 1484 rf_ptr -> data_name.item_length = opnd_ln; 1485 rf_ptr -> data_name.places_left = opnd_ln; 1486 if sf_places > 63 1487 then do; 1488 1489 sf_ptr -> data_name.item_length = left_adjust; 1490 sf_ptr -> data_name.places_left = left_adjust; 1491 end; 1492 1493 else right_adjust = sf_places - left_adjust; 1494 1495 if right_adjust ^= 0 1496 then do; 1497 1498 no_chars = right_adjust; 1499 micro_op = ign; 1500 1501 call move_mult_micro_op; 1502 1503 end; 1504 1505 if n_mop > 64 1506 then do; 1507 1508 call error ("MOP string exceeds 63 char"); 1509 1510 go to max; 1511 1512 end; 1513 1514 call cobol_pool (substr (mop_str, 1, n_mop - 1), 0, cs_offset); 1515 1516 temp = 3000; 1517 1518 call cobol_make_type9$alphanumeric (ms_ptr, temp, cs_offset, n_mop - 1); 1519 1520 n_mop = 1; 1521 1522 call gen_move_edit (MVE, sf_ptr, rf_ptr, ms_ptr); 1523 1524 if rf_length ^= 0 1525 then do; 1526 1527 call calc_char_offset (opnd_ln, rf_ptr); 1528 1529 if sf_places > 63 1530 then do; 1531 1532 call calc_char_offset (left_adjust, sf_ptr); 1533 1534 sf_places = sf_places - left_adjust; 1535 left_adjust = 0; 1536 end; 1537 end; 1538 1539 end; 1540 1541 if rf_temp_sw = 1 1542 then do; 1543 1544 rf_ptr -> data_name.item_length = ecm_lnth; 1545 rf_ptr -> data_name.places_left = ecm_lnth; 1546 rf_ptr -> data_name.seg_num = 1000; 1547 rf_ptr -> data_name.offset = stk_offset; 1548 1549 call gen_move_alpha (MLR, "000100000"b, rf_ptr, save_rf_ptr, "0"b); 1550 1551 end; 1552 1553 max: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 1554 end; 1555 1556 move_numer_ed: 1557 proc;/***..... dcl LOCAL_NAME char (13) int static init ("MOVE_NUMER_ED");/**/ 1558 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 1559 1560 if (sf_ptr -> data_name.display = "0"b) 1561 | (sf_ptr -> data_name.display = "1"b & sf_ptr -> data_name.item_signed = "1"b 1562 & sf_ptr -> data_name.sign_separate = "0"b) /* Must be overpunch sign */ 1563 then do; /* Sending field is not display, must convert it to display data. */ 1564 1565 new_sf_ptr = null (); /* Utility provides space for the new token. */ 1566 1567 call num_to_udts (sf_ptr, new_sf_ptr, return_code); 1568 1569 sf_ptr = new_sf_ptr; 1570 end; /* Sending field is not display, must convert it to display data. */ 1571 1572 spl = sf_ptr -> data_name.places_left; 1573 spr = sf_ptr -> data_name.places_right; 1574 rpl = rf_ptr -> data_name.places_left; 1575 rpr = rf_ptr -> data_name.places_right; 1576 1577 ecm_ptr = addr (ecm); 1578 mop_ptr = addr (mop); 1579 1580 if rf_ptr -> data_name.edit_ptr ^= 0 1581 then do; 1582 1583 delta = fixed (substr (unspec (rf_ptr -> data_name.edit_ptr), 1, 34), 36); 1584 edit_ptr = addrel (rf_ptr, delta); 1585 fx = editor.fixed_insert; 1586 fl = editor.float_insert; 1587 start_supp = editor.start_suppress; 1588 max_supp = editor.max_suppress; 1589 ecm_lnth = editor.ecm_size; 1590 substr (ecm_str, 1, ecm_lnth) = substr (editor.ecm, 1, ecm_lnth); 1591 end; 1592 1593 else do; 1594 1595 ecm_lnth = rpl + rpr; 1596 rf_st = fixed (rf_ptr -> data_name.sign_type, 36); 1597 1598 if rf_st = 4 /* Leading separate sign */ 1599 then do; 1600 1601 fx = 4; 1602 ecm (1) = "-"; 1603 substr (ecm_str, 2, ecm_lnth) = (30)"f"; 1604 ecm_lnth = ecm_lnth + 1; 1605 end; 1606 1607 else do; 1608 1609 substr (ecm_str, 1, ecm_lnth) = (30)"f"; 1610 1611 if rf_st = 3 /* Trailing separate sign */ 1612 then do; 1613 1614 fx = 2; 1615 ecm_lnth = ecm_lnth + 1; 1616 ecm (ecm_lnth) = "-"; 1617 end; 1618 else fx = 0; 1619 end; 1620 1621 fl = 0; 1622 start_supp = 0; 1623 max_supp = 0; 1624 end; 1625 1626 end_supp = start_supp + max_supp - 1; 1627 1628 left_adjust = spl - rpl; 1629 right_adjust = spr - rpr; 1630 if left_adjust >= 0 1631 then do; 1632 1633 if right_adjust >= 0 1634 then overlap = rpl + rpr; 1635 else do; 1636 1637 overlap = rpl + spr; 1638 1639 if overlap < 0 1640 then do; 1641 1642 overlap = 0; 1643 left_adjust = spl + spr; 1644 right_adjust = -(rpl + rpr); 1645 end; 1646 end; 1647 1648 end; 1649 1650 else do; 1651 1652 if right_adjust < 0 1653 then overlap = spl + spr; 1654 else do; 1655 1656 overlap = spl + rpr; 1657 1658 if overlap < 0 1659 then do; 1660 1661 overlap = 0; 1662 left_adjust = -(rpl + rpr); 1663 right_adjust = spl + spr; 1664 end; 1665 end; 1666 end; 1667 1668 do n = 1 to ecm_lnth by 1 while (left_adjust < 0); 1669 1670 if ecm (n) = DS 1671 then do; 1672 1673 ecm (n) = "0"; 1674 left_adjust = left_adjust + 1; 1675 end; 1676 1677 end; 1678 1679 do n = ecm_lnth to 1 by -1 while (right_adjust < 0); 1680 if ecm (n) = DS 1681 then do; 1682 1683 ecm (n) = "0"; 1684 right_adjust = right_adjust + 1; 1685 end; 1686 end; 1687 1688 bwz = fixed (rf_ptr -> data_name.bwz, 36); 1689 awz = fixed (rf_ptr -> data_name.ast_when_zero, 36); 1690 asterisk = fixed (rf_ptr -> data_name.pic_has_ast, 36); 1691 sign = fixed (rf_ptr -> data_name.item_signed, 36); 1692 1693 /* Treat awz = 1 as special case */ 1694 1695 if awz = 1 1696 then do; 1697 1698 if overlap ^= 0 1699 then call cmpn0_tnz; 1700 1701 n = index (ecm_str, obj_dec_pt_char); 1702 1703 if n = 0 1704 then do; 1705 1706 substr (lit_str, 1, 1) = "*"; 1707 1708 call replicate; 1709 1710 end; 1711 else do; 1712 1713 substr (lit_str, 1, 256) = (254)"*" || "**"; 1714 substr (lit_str, n, 1) = obj_dec_pt_char; 1715 1716 call cobol_pool (substr (lit_str, 1, n), 0, cs_offset); 1717 1718 req_ln = n; 1719 1720 call cobol_make_type9$alphanumeric (temp_tkn_ptr, 3000, cs_offset, req_ln); 1721 call gen_move_alpha (MLR, "000101010"b, temp_tkn_ptr, rf_ptr, "0"b); 1722 1723 end; 1724 1725 if overlap = 0 1726 then go to mnx; 1727 else do; 1728 1729 eis_ (1) = "000000000000000000111001000000000100"b /* tra 0,ic */; 1730 1731 call cobol_emit (inst_ptr, null (), 1); 1732 call cobol_define_tag (tag); 1733 1734 tag = cobol_$next_tag; 1735 cobol_$next_tag = cobol_$next_tag + 1; 1736 1737 call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); 1738 1739 end; 1740 end; 1741 1742 /* Special cases of no overlap of sf and rf */ 1743 1744 if overlap = 0 1745 then do; 1746 1747 if bwz = 1 1748 then do; 1749 1750 substr (lit_str, 1, 1) = " "; 1751 1752 call replicate; 1753 1754 go to mnx; 1755 end; 1756 1757 if sign = 0 /* No fixed or floating sign insertion */ 1758 then do; 1759 1760 if asterisk = 1 1761 then supp_char = "*"; 1762 else supp_char = " "; 1763 1764 if start_supp ^= 0 1765 then do n = start_supp to end_supp by 1; 1766 1767 ecm (n) = supp_char; 1768 1769 end; 1770 1771 if fl = 1 /* Float currency suppression */ 1772 then ecm (end_supp) = currency_char; 1773 1774 /* Use ecm_str as sf */ 1775 1776 call cobol_pool$search_op (substr (ecm_str, 1, ecm_lnth), 0, cs_offset, in_op); 1777 1778 if in_op = 0 1779 then temp = 3000; 1780 else temp = 3; 1781 1782 req_ln = ecm_lnth; 1783 1784 call cobol_make_type9$alphanumeric (temp_tkn_ptr, temp, cs_offset, req_ln); 1785 call gen_move_alpha (MLR, "000100000"b, temp_tkn_ptr, rf_ptr, "0"b); 1786 1787 go to mnx; 1788 end; 1789 end; 1790 1791 /* End special cases */ 1792 1793 es_status = 0; /* es off */ 1794 bz_status = 0; /* bz off */ 1795 insert_table_status = " *+-$,.0"; 1796 n_ecm = 1; 1797 n_mop = 1; 1798 1799 /* Take care of leading fixed sign insertion */ 1800 1801 if fx = 3 1802 then do; 1803 1804 mop (1) = insn_4; 1805 n_mop = 2; 1806 n_ecm = 2; 1807 end; 1808 1809 if fx = 4 1810 then do; 1811 1812 if bwz = 1 1813 then do; 1814 1815 mop (1) = enf01; 1816 bz_status = 1; 1817 end; 1818 else mop (1) = enf00; 1819 1820 es_status = 1; 1821 n_mop = 2; 1822 n_ecm = 2; 1823 end; 1824 1825 if start_supp ^= 0 1826 then do; /* Floating insertion or zero suppression specified */ 1827 1828 if n_ecm ^= start_supp 1829 then do; /* Fixed insertion before float or zero suppress */ 1830 1831 /* Set es on if not on and, if bwz = 1, set 1832* bz on if not on. */ 1833 1834 call es_on_ck_bz; 1835 1836 do n = n_ecm to start_supp - 1 by 1; 1837 1838 count = verify (substr (ecm_str, n, start_supp - n), ecm (n)); 1839 1840 if count = 0 1841 then count = start_supp - n; 1842 else count = count - 1; 1843 1844 no_chars = count; 1845 insrt_op = insb; 1846 1847 call move_insert_chars; 1848 1849 n = n + count - 1; 1850 end; 1851 1852 n_ecm = start_supp; 1853 end; 1854 1855 /* Ignore excess sf characters on left */ 1856 1857 if left_adjust ^= 0 1858 then do; 1859 1860 no_chars = left_adjust; 1861 micro_op = ign; 1862 1863 call move_mult_micro_op; 1864 1865 end; /* Set es off if on; bz on if not on and bwz = 1 */ 1866 1867 if bz_status = 0 /* off */ 1868 then if bwz = 1 1869 then do; 1870 1871 mop (n_mop) = ses01; 1872 n_mop = n_mop + 1; 1873 bz_status = 1; 1874 es_status = 0; 1875 end; 1876 1877 if es_status = 1 /* on */ 1878 then do; 1879 1880 mop (n_mop) = ses00; 1881 n_mop = n_mop + 1; 1882 es_status = 0; 1883 end; 1884 1885 /* If insert table entry 1 is not /b, load with /b */ 1886 1887 if substr (insert_table_status, 1, 1) ^= " " 1888 then do; 1889 1890 mop (n_mop) = lte_1; 1891 substr (mop_str, n_mop + 1, 1) = " "; 1892 substr (insert_table_status, 1, 1) = " "; 1893 n_mop = n_mop + 2; 1894 end; 1895 1896 /* Treat zero suppression */ 1897 1898 if fl = 0 1899 then do; 1900 1901 if asterisk = 1 1902 then do; 1903 1904 micro_op = mvza; 1905 insrt_op = insa; 1906 end; 1907 1908 else do; 1909 1910 micro_op = mvzb; 1911 insrt_op = insb; 1912 end; 1913 1914 call suppress; 1915 call es_on_ck_bz; 1916 end; 1917 else do; 1918 1919 n_ecm = n_ecm + 1; 1920 1921 if fl = 1 1922 then do; 1923 1924 if currency_char ^= "$" 1925 then do; 1926 1927 mop (n_mop) = lte_5; 1928 substr (mop_str, n_mop + 1, 1) = currency_char; 1929 substr (insert_table_status, 5, 1) = currency_char; 1930 n_mop = n_mop + 2; 1931 end; 1932 micro_op = mflc; 1933 end; 1934 1935 else do; 1936 1937 if fl = 3 1938 then do; 1939 1940 mop (n_mop) = lte_3; 1941 substr (mop_str, n_mop + 1, 1) = " "; 1942 substr (insert_table_status, 3, 1) = " "; 1943 n_mop = n_mop + 2; 1944 end; 1945 micro_op = mfls; 1946 end; 1947 1948 insrt_op = insb; 1949 1950 call suppress; 1951 1952 if bz_status = 0 /* off */ 1953 then if bwz = 1 1954 then do; 1955 1956 if fl = 1 1957 then mop (n_mop) = enf11; 1958 else mop (n_mop) = enf01; 1959 1960 n_mop = n_mop + 1; 1961 bz_status = 1; 1962 es_status = 1; 1963 end; 1964 1965 if es_status = 0 1966 then do; 1967 1968 if fl = 1 1969 then mop (n_mop) = enf10; 1970 else mop (n_mop) = enf00; 1971 1972 n_mop = n_mop + 1; 1973 es_status = 1; 1974 end; 1975 end; 1976 1977 n_ecm = end_supp + 1; 1978 1979 /* Remainder of ecm string, if any, is processed as fixed 1980* supression */ 1981 1982 end; 1983 1984 else do; /* No float insertion or zero suppression */ 1985 1986 /* Set es on if off; bz on if off and bwz = 1 */ 1987 1988 call es_on_ck_bz; 1989 1990 /* Ignore excess sf characters on left */ 1991 1992 if left_adjust ^= 0 1993 then do; 1994 1995 no_chars = left_adjust; 1996 micro_op = ign; 1997 1998 call move_mult_micro_op; 1999 2000 end; 2001 end; 2002 2003 /* Set end of fixed insertion */ 2004 2005 if fx = 5 2006 then end_fix = ecm_lnth - 2; 2007 else if fx = 1 | fx = 2 2008 then end_fix = ecm_lnth - 1; 2009 else end_fix = ecm_lnth; 2010 2011 do n = n_ecm to end_fix by 1; 2012 2013 count = verify (substr (ecm_str, n, end_fix - n + 1), ecm (n)); 2014 if count = 0 2015 then count = end_fix - n + 1; 2016 else count = count - 1; 2017 2018 no_chars = count; 2019 2020 if ecm (n) = DS 2021 then do; 2022 2023 if bwz = 1 2024 then do; 2025 2026 idx = index (substr (ecm_str, n + count, end_fix - (n + count - 1)), DS); 2027 2028 if idx = 0 2029 then if substr (insert_table_status, 1, 1) ^= " " 2030 then do; 2031 2032 mop (n_mop) = lte_1; 2033 substr (mop_str, n_mop + 1, 1) = " "; 2034 substr (insert_table_status, 1, 1) = " "; 2035 n_mop = n_mop + 2; 2036 end; 2037 end; 2038 2039 micro_op = mvc; 2040 2041 call move_mult_micro_op; 2042 end; 2043 else do; 2044 2045 insrt_op = insb; 2046 2047 call move_insert_chars; 2048 end; 2049 2050 n = n + count - 1; 2051 end; 2052 2053 /* If bwz = 1, insure that insert table 1 is a /b */ 2054 2055 if bwz = 1 2056 then if substr (insert_table_status, 1, 1) ^= " " 2057 then do; 2058 2059 mop (n_mop) = lte_1; 2060 substr (mop_str, n_mop + 1, 1) = " "; 2061 substr (insert_table_status, 1, 1) = " "; 2062 n_mop = n_mop + 2; 2063 2064 if right_adjust = 0 2065 then do; 2066 2067 sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1; 2068 sf_ptr -> data_name.places_right = sf_ptr -> data_name.places_right + 1; 2069 right_adjust = 1; 2070 end; 2071 end; 2072 2073 /* Take care of trailing sign insertion */ 2074 2075 if fx = 5 2076 then do; 2077 2078 mop (n_mop) = lte_1; 2079 substr (insert_table_status, 1, 1) = " "; 2080 substr (mop_str, n_mop + 1, 1) = " "; 2081 n_mop = n_mop + 2; 2082 2083 do n = ecm_lnth - 1 to ecm_lnth by 1; 2084 mop (n_mop) = insn_0; 2085 substr (mop_str, n_mop + 1, 1) = ecm (n); 2086 n_mop = n_mop + 2; 2087 end; 2088 end; 2089 2090 if fx = 1 2091 then do; 2092 2093 mop (n_mop) = insn_4; 2094 n_mop = n_mop + 1; 2095 end; 2096 2097 if fx = 2 2098 then do; 2099 2100 if es_status = 1 2101 then do; 2102 2103 mop (n_mop) = ses00; 2104 n_mop = n_mop + 1; 2105 end; 2106 2107 mop (n_mop) = enf00; 2108 n_mop = n_mop + 1; 2109 end; 2110 2111 /* Ignore excess trailing sf characters */ 2112 2113 if right_adjust ^= 0 2114 then do; 2115 2116 no_chars = right_adjust; 2117 micro_op = ign; 2118 2119 call move_mult_micro_op; 2120 end; 2121 2122 /* Move */ 2123 2124 if n_mop > 64 2125 then call error ("MOP string exceeds 63 char"); 2126 2127 call cobol_pool (substr (mop_str, 1, n_mop - 1), 0, cs_offset); 2128 call cobol_make_type9$alphanumeric (ms_ptr, 3000, cs_offset, n_mop - 1); 2129 call gen_move_edit (MVNE, sf_ptr, rf_ptr, ms_ptr); 2130 2131 if awz = 1 2132 then call cobol_define_tag (tag); 2133 2134 mnx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2135 end; 2136 2137 gen_move_edit: 2138 proc (instr, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr); 2139 /***..... dcl LOCAL_NAME char (13) int static init ("GEN_MOVE_EDIT");/**/ 2140 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2141 2142 dcl instr bit (10); 2143 dcl (sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr) 2144 ptr; 2145 2146 eis_ (1) = (36)"0"b; 2147 inst_struc.inst.fill1_op = instr; 2148 2149 call set_ips_type5_6 (6, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr); 2150 2151 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 2152 2153 call cobol_emit (inst_ptr, reloc_ptr, 4); 2154 2155 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2156 2157 end gen_move_edit; 2158 2159 dec_zero: 2160 proc (temp_tkn_ptr); 2161 /***..... dcl LOCAL_NAME char (8) int static init ("DEC_ZERO");/**/ 2162 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2163 2164 /* This procedure causes an unsigned decimal"0"to be pooled 2165* in the constant section and creates a token for it in 2166* a buffer pointed to by temp_tkn_ptr. */ 2167 dcl temp_tkn_ptr ptr; 2168 dcl cs_offset fixed bin (24); 2169 dcl temp_tkn char (200) based (temp_tkn_ptr); 2170 2171 call cobol_pool$search_op ("0", 0, cs_offset, in_op); 2172 2173 if in_op = 0 2174 then temp = 3000; 2175 else temp = 3; 2176 substr (temp_tkn, 1, 200) = (200)""; 2177 temp_tkn_ptr -> data_name.type = 9; 2178 temp_tkn_ptr -> data_name.numeric = "1"b; 2179 temp_tkn_ptr -> data_name.display = "1"b; 2180 temp_tkn_ptr -> data_name.seg_num = temp; 2181 temp_tkn_ptr -> data_name.offset = cs_offset; 2182 temp_tkn_ptr -> data_name.places_left = 1; 2183 temp_tkn_ptr -> data_name.places_right = 0; 2184 temp_tkn_ptr -> data_name.item_length = 1; 2185 temp_tkn_ptr -> data_name.sign_type = "000"b; 2186 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2187 2188 end dec_zero; 2189 2190 cmpn0_tnz: 2191 proc;/***..... dcl LOCAL_NAME char (9) int static init ("CMPN0_TNZ");/**/ 2192 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2193 2194 /* This procedure generates instructions to compare a numeric 2195* sending field to decimal "0" and transfer if sending field 2196* is not zero. It also reserves a tag for the transfer instruction, 2197* makes a reference for it, and updates cobol_$next_tag. */ 2198 2199 call dec_zero (temp_tkn_ptr); 2200 2201 eis_ (1) = (36)"0"b; 2202 inst_struc.inst.fill1_op = CMPN; 2203 2204 call set_ips_type5_6 (5, sf_ptr, temp_tkn_ptr, null); 2205 2206 call cobol_addr (input_ptr, inst_ptr, null); 2207 2208 tag = cobol_$next_tag; 2209 cobol_$next_tag = cobol_$next_tag + 1; 2210 inst_struc.desc.desc_od (3) = "000000000000000000110000001000000100"b; 2211 2212 call cobol_emit (inst_ptr, null, 4); 2213 2214 call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null); 2215 2216 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2217 2218 end cmpn0_tnz; 2219 2220 move_mult_micro_op: 2221 proc;/***..... dcl LOCAL_NAME char (19) int static init ("MOVE_MULTI_MICRO_OP");/**/ 2222 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2223 2224 /* This procedure generates in "mop_str" (or "mop"), starting 2225* at character number "n_mop", a sufficient number of "micro_op" 2226* micro operations to move "no_chars" characters. */ 2227 2228 do while (no_chars > 0); 2229 2230 if no_chars >= 16 2231 then substr (micro_op, 6, 4) = "0000"b; 2232 else substr (micro_op, 6, 4) = substr (unspec (no_chars), 33, 4); 2233 2234 no_chars = no_chars - 16; 2235 mop (n_mop) = micro_op; 2236 n_mop = n_mop + 1; 2237 2238 end; 2239 2240 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2241 2242 end move_mult_micro_op; 2243 2244 move_insert_chars: 2245 proc;/***..... dcl LOCAL_NAME char (17) int static init ("MOVE_INSERT_CHARS");/**/ 2246 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2247 2248 /* This procedure generates in "mop_str" (or "mop"), starting 2249* at character number "n_mop", a sufficient number of micro 2250* operations to move "no_chars" insertion characters defined 2251* by "ecm(n)" without suppression. "insm" is used if "no_chars" 2252* > 3 and the micro op contained in "insrt_op" if "no_chars" <= 3. 2253* */ 2254 2255 if no_chars > 3 2256 then do; 2257 2258 if substr (insert_table_status, 1, 1) ^= ecm (n) 2259 then do; 2260 2261 mop (n_mop) = lte_1; 2262 substr (mop_str, n_mop + 1, 1) = ecm (n); 2263 substr (insert_table_status, 1, 1) = ecm (n); 2264 n_mop = n_mop + 2; 2265 2266 end; 2267 2268 micro_op = insm; 2269 2270 call move_mult_micro_op; 2271 2272 end; 2273 2274 else do; 2275 2276 insert_char_no = index (insert_table_status, ecm (n)); 2277 2278 if insert_char_no = 0 2279 then if ecm (n) = " " 2280 then do; 2281 2282 mop (n_mop) = lte_1; 2283 substr (mop_str, n_mop + 1, 1) = " "; 2284 substr (insert_table_status, 1, 1) = " "; 2285 insert_char_no = 1; 2286 n_mop = n_mop + 2; 2287 2288 end; 2289 2290 do idx = 1 to no_chars by 1; 2291 2292 substr (insrt_op, 6, 4) = substr (unspec (insert_char_no), 33, 4); 2293 mop (n_mop) = insrt_op; 2294 n_mop = n_mop + 1; 2295 2296 if insert_char_no = 0 2297 then do; 2298 2299 substr (mop_str, n_mop, 1) = ecm (n); 2300 n_mop = n_mop + 1; 2301 2302 end; 2303 end; 2304 end; 2305 2306 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2307 2308 end move_insert_chars; 2309 2310 es_on_ck_bz: 2311 proc;/***..... dcl LOCAL_NAME char (11) int static init ("ES_ON_CK_BZ");/**/ 2312 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2313 2314 /* This procedure generates a "ses" micro op in "mop_str" (or 2315* "mop"), at character number "n_mop", to set the es flag on 2316* if it is not already on and bwz = 0 or bwz = 1 and the bz 2317* flag is already on or to set both the es and bz flags on if 2318* bwz = 1 and bz is not already on. */ 2319 2320 if bz_status = 0 /* off */ 2321 then if bwz = 1 2322 then do; 2323 2324 mop (n_mop) = ses11; 2325 n_mop = n_mop + 1; 2326 bz_status = 1; 2327 es_status = 1; 2328 2329 end; 2330 2331 if es_status = 0 /* off */ 2332 then do; 2333 2334 mop (n_mop) = ses10; 2335 n_mop = n_mop + 1; 2336 es_status = 1; 2337 2338 end; 2339 2340 2341 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2342 2343 end es_on_ck_bz; 2344 2345 suppress: 2346 proc;/***..... dcl LOCAL_NAME char (8) int static init ("SUPPRESS");/**/ 2347 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2348 2349 /* This procedure generates the micro operations in "mop_str" 2350* (or "mpo"), starting at character number "n_mop" for the 2351* supression portion of an edit numeric move. Processing of 2352* "ecm_str" (or "ecm") commences at character number "n_ecm" 2353* and ends with character number "end_supp". The micro oper- 2354* ation contained in "micro_op" is used to move digit charact- 2355* ers and that in "insrt_op" to move insertion characters. */ 2356 2357 do n = n_ecm to end_supp by 1; 2358 2359 count = verify (substr (ecm_str, n, end_supp - n + 1), ecm (n)); 2360 2361 if count = 0 2362 then count = end_supp - n + 1; 2363 else count = count - 1; 2364 2365 no_chars = count; 2366 2367 if ecm (n) = DS 2368 then call move_mult_micro_op; 2369 2370 else do; 2371 2372 insert_char_no = index (insert_table_status, ecm (n)); 2373 2374 do idx = 1 to no_chars by 1; 2375 2376 substr (insrt_op, 6, 4) = substr (unspec (insert_char_no), 33, 4); 2377 mop (n_mop) = insrt_op; 2378 n_mop = n_mop + 1; 2379 2380 if insert_char_no = 0 2381 then do; 2382 2383 substr (mop_str, n_mop, 1) = ecm (n); 2384 n_mop = n_mop + 1; 2385 2386 end; 2387 end; 2388 end; 2389 2390 n = n + count - 1; 2391 end; 2392 2393 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2394 2395 end suppress; 2396 2397 error: 2398 proc (err_msg); 2399 2400 dcl 1 error_info aligned, 2401 2 module_name char (32), 2402 2 err_msg_lnth fixed bin, 2403 2 error_msg char (168); 2404 2405 dcl err_msg char (*); 2406 dcl ioa_str char (44) init ("move # ^d {on line(^d) col(^d)} contains ^a"); 2407 2408 /* utilize cobol_ system error handling */ 2409 2410 module_name = "cobol_move_gen"; 2411 2412 call ioa_$rsnnl (ioa_str, error_msg, err_msg_lnth, move_num, lin, col, err_msg); 2413 2414 call signal_ ("command_abort_", null, addr (error_info)); 2415 2416 end error; 2417 2418 gen_move_alpha: 2419 proc (op_code, fill, sf_tkn_ptr, rf_tkn_ptr, no_emit); 2420 2421 /***..... dcl LOCAL_NAME char (14) int static init ("GEN_MOVE_ALPHA");/**/ 2422 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2423 2424 /* This procedure "generates" an eis {an} move instruction 2425* (the contents of `op_code' determines whether an MLR 2426* or an MRL eis instruction is generated. The contents 2427* of `fill' is used to set the FILL character of the instr 2428* 2429* This procedure calls on `set_ips_type5_6' to set up a 2430* type-5 instruction in input_strucure (input to cobol_addr) 2431* using the type-9 tokens pointed to by sf_tkn_ptr and 2432* rf_tkn_ptr as sending and receiving field tokens. 2433* After setting the FILL character, it calls `cobol_emit' 2434* to emit the instruction (and operand descriptors) built */ 2435 2436 dcl op_code bit (10); 2437 dcl len fixed bin; 2438 dcl fill bit (9); 2439 dcl (sf_tkn_ptr, rf_tkn_ptr) 2440 ptr; 2441 dcl no_emit bit (1); 2442 dcl cobol_io_util$move entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin); 2443 2444 eis_ (1) = (36)"0"b; 2445 inst_struc.inst.fill1_op = op_code; 2446 2447 call set_ips_type5_6 (5, sf_tkn_ptr, rf_tkn_ptr, null); 2448 2449 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 2450 2451 if op_code = MLR & fill = "000100000"b & ^no_emit 2452 then do; /* try to optimize */ 2453 /* -05/15/76- */ 2454 2455 if (sf_tkn_ptr -> data_name.pic_has_p = "0"b) & (sf_tkn_ptr -> data_name.places_left >= 0) 2456 & (sf_tkn_ptr -> data_name.places_right >= 0) 2457 then /* 6/14/76 */ 2458 if inst_struc.mf1.pr_spec & ^inst_struc.mf1.reg_or_length & inst_struc.mf1.reg_mod = ""b 2459 & inst_struc.mf2.pr_spec & ^inst_struc.mf2.reg_or_length & inst_struc.mf2.reg_mod = ""b 2460 then if ^sf_tkn_ptr -> data_name.linkage_section /* [3.0-1] */ 2461 & /* [3.0-1] */ ^rf_tkn_ptr -> data_name.linkage_section 2462 /* [3.0-1] */ 2463 then do; 2464 2465 2466 call cobol_io_util$move (substr (inst_struc.desc_od (2), 1, 3), 2467 fixed (substr (inst_struc.desc_od (2), 4, 17)), 2468 fixed (substr (inst_struc.desc_od (2), 25, 12)), 2469 substr (inst_struc.desc_od (1), 1, 3), 2470 fixed (substr (inst_struc.desc_od (1), 4, 17)), 2471 fixed (substr (inst_struc.desc_od (1), 25, 12))); 2472 2473 go to gmx; 2474 2475 end; 2476 2477 end; /* try to optimize */ 2478 /* -05/15/76- */ 2479 2480 substr (eis_ (1), 1, 9) = fill; 2481 2482 if (sf_tkn_ptr -> data_name.pic_has_p) & (fill ^= "000110000"b) 2483 & (sf_tkn_ptr -> data_name.places_left < 0 | sf_tkn_ptr -> data_name.places_right < 0) 2484 then do; 2485 2486 /*[4.4-1]*/ 2487 if ne_bit 2488 then substr (eis_ (1), 1, 9) = "000110000"b; 2489 /* "0" */ 2490 2491 call cobol_emit (inst_ptr, reloc_ptr, 3); 2492 2493 if sf_tkn_ptr -> data_name.places_left < 0 2494 then len = sf_tkn_ptr -> data_name.item_length - sf_tkn_ptr -> data_name.places_left; 2495 else len = sf_tkn_ptr -> data_name.item_length - sf_tkn_ptr -> data_name.places_right; 2496 2497 if rf_tkn_ptr -> data_name.variable_length = "0"b 2498 then if len >= rf_tkn_ptr -> data_name.item_length 2499 then return; 2500 2501 inst_struc.inst.mf1 = inst_struc.mf2; 2502 inst_struc.inst.mf1.reg_or_length = "0"b; 2503 inst_struc.desc.desc_od (1) = inst_struc.desc.desc_od (2); 2504 substr (inst_struc.desc.desc_od (1), 25, 12) = substr (unspec (len), 25, 12); 2505 substr (eis_ (1), 1, 9) = fill; 2506 2507 end; 2508 2509 if ^no_emit 2510 then call cobol_emit (inst_ptr, reloc_ptr, 3); /* 6/3/76 */ 2511 2512 gmx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2513 end gen_move_alpha; 2514 2515 gen_move_lit: 2516 proc (lit_str, lit_ln, rf_ptr); 2517 /***..... dcl LOCAL_NAME char (12) int static init ("GEN_MOVE_LIT");/**/ 2518 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2519 2520 /* This procedure is used to interface with the entry cobol_io_util$move_lit. 2521* The input to this procedure are: 2522* lit_str: The sending alphanum literal string. 2523* lit_ln: The length of the sending alphanum literal string. 2524* rf_ptr: The pointer to the receiving field. 2525**/ 2526 2527 dcl lit_str char (*), 2528 lit_ln fixed bin, 2529 rf_ptr ptr; 2530 2531 eis_ (1) = (36)"0"b; 2532 2533 call set_ips_type5_6 (5, null, rf_ptr, null); 2534 2535 call cobol_addr (input_ptr, inst_ptr, null); 2536 2537 call cobol_io_util$move_lit (substr (inst_struc.desc_od (2), 1, 3), 2538 fixed (substr (inst_struc.desc_od (2), 4, 17)), fixed (substr (inst_struc.desc_od (2), 25, 12)), 2539 substr (lit_str, 1, lit_ln)); 2540 2541 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2542 2543 end gen_move_lit; 2544 2545 gen_move_dec_numer: 2546 proc (sf_tkn_ptr, rf_tkn_ptr); 2547 /***..... dcl LOCAL_NAME char (19) int static init ("GEN_MOVE_DEC_NUMBER");/**/ 2548 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2549 2550 /* This procedure "generates" an eis {n} move instruction 2551* It uses the type-9 tokens pointed to by sf_tkn_ptr and 2552* rf_tkn_ptr as the sending and receiving fields of the MVN 2553* If the sending field is unsigned and the receiving 2554* field is signed, the `P-BIT' is set "ON" (thereby forcing 2555* a + sign in the signed receiving field. 2556* If the receiving field is stipulated as having the ROUNDED 2557* option applied, the `RD' bit is set "ON" (meaning that 2558* rounding will take place as a result of this move. */ 2559 2560 dcl (sf_tkn_ptr, rf_tkn_ptr) 2561 ptr; 2562 2563 eis_ (1) = (36)"0"b; 2564 inst_struc.inst.fill1_op = MVN; 2565 2566 call set_ips_type5_6 (5, sf_tkn_ptr, rf_tkn_ptr, null); 2567 2568 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 2569 2570 if (rf_tkn_ptr -> data_name.rounded) 2571 then substr (eis_ (1), 11, 1) = "1"b; 2572 2573 if ((sf_tkn_ptr -> data_name.sign_type = "000"b) & (rf_tkn_ptr -> data_name.sign_type ^= "000"b)) 2574 then substr (eis_ (1), 1, 1) = "1"b; 2575 2576 if rf_tkn_ptr -> data_name.item_signed 2577 then substr (eis_ (1), 1, 1) = "1"b; 2578 2579 if (only_an = "1"b) 2580 then do; 2581 2582 substr (eis_ (1), 19, 10) = "0010000001"b; 2583 substr (eis_ (1), 1, 11) = "11000000000"b; 2584 substr (eis_ (2), 23, 8) = "00000000"b; 2585 substr (eis_ (3), 23, 8) = "00000000"b; 2586 end; 2587 2588 call cobol_emit (inst_ptr, reloc_ptr, 3); 2589 2590 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2591 2592 end gen_move_dec_numer; 2593 2594 set_ips_type5_6: 2595 proc (ips_typ, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr); 2596 /***..... dcl LOCAL_NAME char (15) int static init ("SET_IPS_TYPE5_6");/**/ 2597 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2598 2599 /* This procedure sets up the input structure (ips_) used by 2600* cobol_addr to create addressability to the data fields in the 2601* eis MOVE instruction. 2602* - type-5 (ips_typ=5) eis instr w/ 2 operand descriptors 2603* op-descr(1) = sending field = token <- sf_tkn_ptr 2604* op-descr(2) = receiving fld = token <- rf_tkn_ptr 2605* - type-6 (ips_typ=6) eis instr w/ 3 operand descriptors 2606* op-descr(1) = sending field = token <- sf_tkn_ptr 2607* op-descr(2) = microp string = token <- ms_tkn_ptr 2608* op-descr(3) = receiving fld = token <- rf_tkn_ptr */ 2609 dcl (sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr) 2610 ptr; 2611 dcl ips_typ fixed bin; 2612 2613 if (ips_typ = 5) 2614 then do; 2615 2616 input_struc.type = 5; 2617 input_struc.operand_no = 2; 2618 input_struc.lock = 0; 2619 2620 input_struc.token_ptr (1) = sf_tkn_ptr; 2621 input_struc.send_receive (1) = 0; 2622 input_struc.ic_mod (1) = 0; 2623 input_struc.size_sw (1) = 0; 2624 2625 input_struc.token_ptr (2) = rf_tkn_ptr; 2626 input_struc.send_receive (2) = 1; 2627 input_struc.ic_mod (2) = 0; 2628 input_struc.size_sw (2) = 0; 2629 2630 go to setx; 2631 end; 2632 2633 if (ips_typ = 6) 2634 then do; 2635 2636 input_struc.type = 6; 2637 input_struc.operand_no = 3; 2638 input_struc.lock = 0; 2639 2640 input_struc.token_ptr (1) = sf_tkn_ptr; 2641 input_struc.send_receive (1) = 0; 2642 input_struc.ic_mod (1) = 0; 2643 input_struc.size_sw = 0; 2644 2645 input_struc.token_ptr (2) = ms_tkn_ptr; 2646 input_struc.send_receive (2) = 0; 2647 input_struc.ic_mod (2) = 0; 2648 input_struc.size_sw (2) = 0; 2649 2650 input_struc.token_ptr (3) = rf_tkn_ptr; 2651 input_struc.send_receive (3) = 1; 2652 input_struc.ic_mod (3) = 0; 2653 input_struc.size_sw (3) = 0; 2654 2655 end; 2656 2657 setx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2658 end set_ips_type5_6; 2659 2660 calc_char_offset: 2661 proc (delta, dn_ptr); 2662 /***..... dcl LOCAL_NAME char (16) int static init ("CALC_CHAR_OFFSET");/**/ 2663 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2664 2665 /* This procedure calculates a new character offset for 2666* a data field whenever any adjustments have to be made. 2667* Normally, the new offset = old offset + delta. There is 2668* a distinct problem, however, with data fields in the 2669* COBOL constant section. Since the constants are stored 2670* in a backwards manner (ie from the END of the constant 2671* portion of the text section) any character adjustments 2672* must use a special algorithm to calculate the new offset. 2673* 2674* The byte numbering of the data in the constant section 2675* is shown in the following diagram: 2676* 2677* --------------------- 2678* | 16 | 17 |....|....| 2679* --------------------- 2680* | 12 | 13 | 14 | 15 | 2681* --------------------- 2682* | 8 | 9 | 10 | 11 | 2683* --------------------- 2684* | 4 | 5 | 6 | 7 | 2685* --------------------- 2686* */ 2687 2688 dcl (curr_char_off, new_char_off, nword, nchar, delta) 2689 fixed bin; 2690 dcl dn_ptr ptr; 2691 dcl tlength fixed bin; 2692 2693 /* If data item is packed decimal, calculate the byte delta from the half-byte delta supplied. */ 2694 2695 if dn_ptr -> data_name.ascii_packed_dec_h 2696 then do; 2697 2698 if mod (delta, 2) = 0 2699 then delta = divide (delta, 2, 35, 0); 2700 else if dn_ptr -> data_name.bit_offset = "0000"b 2701 then do; 2702 2703 delta = divide (delta, 2, 35, 0); 2704 dn_ptr -> data_name.bit_offset = "0101"b; 2705 end; 2706 else do; 2707 2708 delta = divide (delta, 2, 35, 0) + 1; 2709 dn_ptr -> data_name.bit_offset = "0000"b; 2710 end; 2711 end; 2712 2713 else if dn_ptr -> data_name.ascii_packed_dec 2714 then do; 2715 2716 /* Calculate the meaningful number of halfbytes in the data item. */ 2717 2718 tlength = dn_ptr -> data_name.places_left + dn_ptr -> data_name.places_right; 2719 2720 if dn_ptr -> data_name.item_signed 2721 then tlength = tlength + 1; 2722 2723 /* If the number of half bytes is odd, then the leftmost halfbyte is fill. 2724* We must bump past the fill halfbyte, so add 1 to delta. */ 2725 2726 if mod (tlength, 2) ^= 0 2727 then delta = delta + 1; 2728 2729 delta = divide (delta, 2, 35); 2730 2731 end; 2732 2733 /* ck for COBOL constant data */ 2734 2735 if (dn_ptr -> data_name.seg_num = 3000) 2736 then do; 2737 2738 nword = divide (dn_ptr -> data_name.offset, 4, 35) 2739 - divide (mod (dn_ptr -> data_name.offset, 4) + delta, 4, 35); 2740 2741 curr_char_off = mod (dn_ptr -> data_name.offset + delta, 4); 2742 dn_ptr -> data_name.offset = nword * 4 + curr_char_off; 2743 2744 end; 2745 2746 else dn_ptr -> data_name.offset = dn_ptr -> data_name.offset + delta; 2747 2748 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2749 2750 end calc_char_offset; 2751 2752 build_litstr: 2753 proc;/***..... dcl LOCAL_NAME char (12) int static init ("BUILD_LITSTR");/**/ 2754 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2755 2756 /* This procedure builds a left_justified string of "req_ln" 2757* characters in the string "lit_str" utilizing the left- 2758* most "lit_ln" characters in "lit_str". The "lit_str" 2759* characters are replicated or truncated as necessary to 2760* achieve the required string length. */ 2761 2762 if lit_ln < req_ln 2763 then do; 2764 2765 do idx = lit_ln by lit_ln while (req_ln - idx >= lit_ln); 2766 2767 substr (lit_str, idx + 1, lit_ln) = substr (lit_str, 1, lit_ln); 2768 2769 end; 2770 2771 if req_ln - idx < lit_ln 2772 then substr (lit_str, idx + 1, req_ln - idx) = substr (lit_str, 1, req_ln - idx); 2773 end; 2774 2775 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2776 2777 end build_litstr; 2778 2779 replicate: 2780 proc;/***..... dcl LOCAL_NAME char (9) int static init ("REPLICATE");/**/ 2781 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2782 2783 /* This procedure replicates a one-character pattern by causing 2784* the generation of a simple move from a zero-length string 2785* with the desired character as the fill character to the 2786* receiving field. The character to be replicated is assumed 2787* to be the first character of lit_str. */ 2788 2789 eis_ (1) = (36)"0"b; 2790 2791 call set_ips_type5_6 (5, null, rf_ptr, null); 2792 2793 call cobol_addr (input_ptr, inst_ptr, null); 2794 2795 inst_struc.inst.fill1_op = MLR; 2796 substr (eis_ (1), 1, 9) = substr (unspec (lit_str), 1, 9); 2797 substr (eis_ (1), 30, 7) = "0000100"b; 2798 inst_struc.desc.desc_od (1) = "111111111111111111000000000000000000"b; 2799 2800 call cobol_emit (inst_ptr, null, 3); 2801 2802 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2803 2804 end replicate; 2805 2806 build_litstr_right_just: 2807 proc;/***..... dcl LOCAL_NAME char (23) int static init ("BUILD_LISTR_RIGHT_JUST");/**/ 2808 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2809 2810 /* 2811* This procedure builds a literal , right justified in the leftmost 2812* character positions of a work string. The literal is built for 2813* an "all" literal. 2814* The input to this procedure is contained in the following 2815* variables that are global to this procedure: 2816* lit_str this character string contains the "all" literal 2817* lit_ln this is the length of the "all" literal. 2818* req_ln this is the required length of the string to be 2819* built by this procedure. 2820* The literal string built by this procedure is returned right justified, in 2821* the leftmost "lit_ln" characters of lit_str. 2822**/ 2823 2824 /* Declarations of internal variables. */ 2825 2826 dcl work_string char (40); 2827 dcl whole_string_count fixed bin; 2828 dcl remainder_count fixed bin; 2829 dcl curr_char fixed bin; 2830 dcl ix fixed bin; 2831 2832 /* calculate the number of whole literal strings to be inserted into the works string. */ 2833 2834 whole_string_count = req_ln / lit_ln; 2835 2836 /* calculate the number of characters in a partial move of the literal string to the work string. */ 2837 2838 remainder_count = mod (req_ln, lit_ln); 2839 2840 curr_char = 1; 2841 2842 if remainder_count ^= 0 2843 then do; /* Move partial string into the work string */ 2844 2845 substr (work_string, curr_char, remainder_count) = 2846 substr (lit_str, curr_char + lit_ln - remainder_count, remainder_count); 2847 curr_char = curr_char + remainder_count; 2848 2849 end; /* Move partial string into the work string */ 2850 2851 if whole_string_count ^= 0 2852 then do; /* Move the whole input string into the work string (one or more times) */ 2853 2854 do ix = 1 to whole_string_count; 2855 2856 substr (work_string, curr_char, lit_ln) = substr (lit_str, 1, lit_ln); 2857 curr_char = curr_char + lit_ln; 2858 2859 end; 2860 2861 end; /* Move the whole input string into the work string (one or more times) */ 2862 2863 /* Move the work string into the input string. */ 2864 2865 substr (lit_str, 1, req_ln) = substr (work_string, 1, req_ln); 2866 2867 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2868 2869 end build_litstr_right_just; 2870 2871 /* { */ 2872 num_to_num: 2873 proc (sf_ptr, rf_ptr); 2874 /***..... dcl LOCAL_NAME char (10) int static init ("NUM_TO_NUM");/**/ 2875 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2876 2877 /* 2878* This procedure is called to generate code to move any numeric 2879* variable to any other numeric variable. The move is accomplished 2880* in the Cobol MOVE verb sense, i.e., point alignment and 2881* truncation on the right and left are done, and overflow is avoided. 2882**/ 2883 2884 /* Declarations of the Parameters */ 2885 2886 dcl sf_ptr ptr; 2887 dcl rf_ptr ptr; 2888 2889 /* } */ 2890 2891 dcl sf_code fixed bin; 2892 2893 /* Get the numeric type code of the source variable */ 2894 2895 call cobol_get_num_code (sf_ptr, sf_code); 2896 2897 /* Call a move code generation procedure based on the type of the source variable. */ 2898 2899 call numeric_source_proc (sf_code) (sf_ptr, rf_ptr); 2900 2901 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2902 2903 end num_to_num; 2904 2905 /* { */ 2906 dec_source: 2907 proc (sf_ptr, rf_ptr); 2908 /***..... dcl LOCAL_NAME char (10) int static init ("DEC_SOURCE");/**/ 2909 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2910 2911 /* 2912* This internal procedure generates code to convert any decimal 2913* source variable to any other type of numeric variable. 2914**/ 2915 2916 /* Declaration of the Parameters */ 2917 2918 dcl sf_ptr ptr; 2919 dcl rf_ptr ptr; 2920 2921 /* } */ 2922 2923 /* Declaration of Internal Variables */ 2924 2925 dcl work_sf_ptr ptr; 2926 dcl work_rf_ptr ptr; 2927 dcl rf_code fixed bin; 2928 2929 work_sf_ptr = sf_ptr; 2930 work_rf_ptr = rf_ptr; 2931 2932 call cobol_get_num_code (rf_ptr, rf_code); 2933 2934 goto target_1 (rf_code); 2935 2936 target_1 (1): /* TARGET IS UNPACKED DECIMAL */ 2937 call dec_dec (work_sf_ptr, work_rf_ptr); 2938 2939 go to tgx; 2940 target_1 (2): /* TARGET IS PACKED DECIMAL */ 2941 call dec_dec (work_sf_ptr, work_rf_ptr); 2942 2943 go to tgx; 2944 2945 target_1 (3): /* TARGET IS SHORT FIXED BINARY */ 2946 call dec_sb (work_sf_ptr, work_rf_ptr); 2947 2948 go to tgx; 2949 2950 target_1 (4): /* TARGET IS LONG FIXED BINARY */ 2951 call dec_lb (work_sf_ptr, work_rf_ptr); 2952 2953 go to tgx; 2954 2955 target_1 (5): /* TARGET IS OVERPUNCH SIGN DATA */ 2956 call non_opch_to_opch (work_sf_ptr, work_rf_ptr); 2957 2958 tgx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 2959 end dec_source; 2960 2961 /* { */ 2962 sb_source: 2963 proc (sf_ptr, rf_ptr); 2964 /***..... dcl LOCAL_NAME char (9) int static init ("SB_SOURCE");/**/ 2965 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 2966 2967 /* 2968* This internal procedure generates code to convert a short 2969* binary source variable to any type numeric variable. */ 2970 2971 /* Declarations of the Parameters */ 2972 2973 dcl sf_ptr ptr; 2974 dcl rf_ptr ptr; 2975 2976 /* DECLARATIONS OF INTERNAL VARIABLES */ 2977 2978 dcl work_sf_ptr ptr; 2979 dcl work_rf_ptr ptr; 2980 dcl rf_code fixed bin; 2981 2982 work_sf_ptr = sf_ptr; 2983 work_rf_ptr = rf_ptr; 2984 2985 /* Get a type code for the receiving variable. */ 2986 2987 call cobol_get_num_code (rf_ptr, rf_code); 2988 2989 /* Goto a conversion routine based on the type of the receiving field. */ 2990 2991 goto target_2 (rf_code); 2992 2993 target_2 (1): /* TARGET IS UNPACKED DECIMAL */ 2994 target_2 (2): /* TARGET IS PACKED DECIMAL */ 2995 /* NOTE THAT UNPACKED AND PACKED DECIMAL ARE CONVERTED IDENTICALLY. */ 2996 call any_bin_dec (work_sf_ptr, work_rf_ptr); 2997 2998 go to tgx; 2999 3000 target_2 (3): /* TARGET IS SHORT BINARY */ 3001 call bin_same_bin (work_sf_ptr, work_rf_ptr); 3002 3003 go to tgx; 3004 3005 target_2 (4): /* TARGET IS LONG BINARY */ 3006 call sb_lb (work_sf_ptr, work_rf_ptr); 3007 3008 go to tgx; 3009 3010 target_2 (5): /* TARGET IS OVERPUNCH SIGN */ 3011 call non_opch_to_opch (work_sf_ptr, work_rf_ptr); 3012 3013 tgx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3014 end sb_source; 3015 3016 /* { */ 3017 lb_source: 3018 proc (sf_ptr, rf_ptr); 3019 /***..... dcl LOCAL_NAME char (9) int static init ("LB_SOURCE");/**/ 3020 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3021 3022 /* 3023* This internal procedure generates code to convert a long 3024* binary source variable to any numeric variable. */ 3025 3026 /* DECLARATIONS OF THE PARAMETERS */ 3027 3028 dcl sf_ptr ptr; 3029 dcl rf_ptr ptr; 3030 3031 /* DECLARATION OF INTERNAL VARIABLES */ 3032 3033 dcl work_sf_ptr ptr; 3034 dcl work_rf_ptr ptr; 3035 dcl rf_code fixed bin; 3036 3037 work_sf_ptr = sf_ptr; 3038 work_rf_ptr = rf_ptr; 3039 3040 /* Get a type code for the receiving variable. */ 3041 3042 call cobol_get_num_code (rf_ptr, rf_code); 3043 3044 /* Goto a conversion code sequence based on the type of the receiving variable. */ 3045 3046 goto target_3 (rf_code); 3047 3048 target_3 (1): /* TARGET IS UNPACKED DECIMAL */ 3049 target_3 (2): /* TARGET IS PACKED DECIMAL */ 3050 /* NOTE THAT UNPACKED AND PACKED DECIMAL RECEIVING FIELDS ARE CONVERTED IDENTICALLY. */ 3051 call any_bin_dec (work_sf_ptr, work_rf_ptr); 3052 3053 go to tgx; 3054 3055 target_3 (3): /* TARGET IS SHORT BINARY */ 3056 call lb_sb (work_sf_ptr, work_rf_ptr); 3057 3058 go to tgx; 3059 3060 target_3 (4): /* TARGET IS LONG BINARY */ 3061 call bin_same_bin (work_sf_ptr, work_rf_ptr); 3062 3063 go to tgx; 3064 3065 target_3 (5): /* TARGET IS OVERPUNCH SIGN DATA */ 3066 call non_opch_to_opch (work_sf_ptr, work_rf_ptr); 3067 3068 tgx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3069 end lb_source; 3070 3071 /* { */ 3072 opch_source: 3073 proc (sf_ptr, rf_ptr); 3074 /***..... dcl LOCAL_NAME char (11) int static init ("OPCH_SOURCE");/**/ 3075 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3076 3077 /* This internal procedure generates code to convert an overpunch 3078* sign variable to any type of numeric variable. */ 3079 3080 /* Declaration of the parameters. */ 3081 3082 dcl sf_ptr ptr; 3083 dcl rf_ptr ptr; /* } */ 3084 3085 /* Declaration of Internal Variables. */ 3086 3087 dcl work_sf_ptr ptr; 3088 dcl work_rf_ptr ptr; 3089 dcl rf_code fixed bin; 3090 3091 /* ************************************************ */ 3092 /* START OF EXECUTION */ 3093 /* internal procedure */ 3094 /* opch_source */ 3095 /* ************************************************ */ 3096 3097 work_sf_ptr = sf_ptr; 3098 work_rf_ptr = rf_ptr; 3099 3100 /* Get a numeric type code for the receiving variable. */ 3101 3102 call cobol_get_num_code (rf_ptr, rf_code); 3103 3104 /* Goto a conversiion routine, based on the type of the receiving variable. */ 3105 goto target_4 (rf_code); 3106 3107 target_4 (1): /* TARGET IS UNPACKED DECIMAL */ 3108 target_4 (2): /* TARGET IS PACKED DECIMAL */ 3109 target_4 (3): /* TARGET IS SHORT BINARY */ 3110 target_4 (4): /* TARGET IS LONG BINARY */ 3111 /* NOTE THAT ALL NON-OVERPUNCH DATA TYPES CALL THE SAME ROUTINE. */ 3112 call opch_to_non_opch (work_sf_ptr, work_rf_ptr); 3113 3114 go to opx; 3115 3116 target_4 (5): /* TARGET IS OVERPUNCH SIGN */ 3117 call opch_to_opch (work_sf_ptr, work_rf_ptr); 3118 3119 opx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3120 end opch_source; /* { */ 3121 3122 dec_dec: 3123 proc (sf_ptr, rf_ptr); 3124 /***..... dcl LOCAL_NAME char (7) int static init ("DEC_DEC");/**/ 3125 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3126 3127 /* 3128* This internal procedure generates code to move a decimal 3129* variable (packed or unpacked) to a decimal variable (packed 3130* or unpacked). 3131**/ 3132 3133 /* DECLARATION OF THE PARAMETERS */ 3134 3135 dcl sf_ptr ptr; 3136 dcl rf_ptr ptr; 3137 3138 /* DESCRIPTION OF THE PARAMETERS */ 3139 /* 3140* PARAMETER DESCRIPTION 3141* sf_ptr Pointer to a data name token (type 9) that 3142* describes the sending field. (input) 3143* rf_ptr Pointer to a data name token that 3144* describes the receiving field. (input) 3145* 3146**/ 3147 3148 start_dec_dec: 3149 spl = sf_ptr -> data_name.places_left; 3150 spr = sf_ptr -> data_name.places_right; 3151 rpl = rf_ptr -> data_name.places_left; 3152 rpr = rf_ptr -> data_name.places_right; 3153 3154 if spl < 0 3155 then do; /* No places left bytes in the sending field */ 3156 3157 if rpr > 0 3158 then call gen_move_dec_numer (sf_ptr, rf_ptr); 3159 3160 else do; /* No places right bytes in the receiving field. */ 3161 3162 call dec_zero (temp_tkn_ptr); 3163 3164 call gen_move_dec_numer (temp_tkn_ptr, rf_ptr); 3165 3166 end; /* No places right bytes in the receiving field. */ 3167 3168 end; /* No places left bytes in the sending field. */ 3169 3170 else do; /* Receiving field does have places left. */ 3171 3172 if rpl >= spl /* receiving field can hold sending field completely. */ 3173 then call gen_move_dec_numer (sf_ptr, rf_ptr); 3174 3175 else do; /* Receiving field not big enough to hold the sending field. */ 3176 3177 if rpl + spr <= 0 3178 then do; /* Move zero to the receiving field */ 3179 3180 call dec_zero (temp_tkn_ptr); 3181 3182 call gen_move_dec_numer (temp_tkn_ptr, rf_ptr); 3183 3184 end; /* Move zero to the receiving field */ 3185 3186 else do; /* Move source field to receiving field, doing point alignment 3187* and truncation if necessary. */ 3188 3189 if sf_ptr -> data_name.sign_type = "100"b 3190 then do; /* leading separate sign sending field */ 3191 /* copy the sending field to temp as trailing separate sign. */ 3192 sf_stack_sw = 1; 3193 3194 call cobol_alloc$stack (fixed (sf_ptr -> data_name.item_length, 17), 0, 3195 stk_offset); 3196 3197 substr (new_sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = 3198 substr (sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size); 3199 3200 new_sf_ptr -> data_name.linkage_section = "0"b; 3201 new_sf_ptr -> data_name.sign_type = "011"b; 3202 /* trailing sep */ 3203 new_sf_ptr -> data_name.seg_num = 1000; 3204 /* stack */ 3205 new_sf_ptr -> data_name.subscripted = "0"b; 3206 new_sf_ptr -> data_name.offset = stk_offset; 3207 3208 /* Generate code to move the leading sign variable to trailing 3209* sign variable. */ 3210 3211 call gen_move_dec_numer (sf_ptr, new_sf_ptr); 3212 3213 sf_ptr, save_sf_ptr = new_sf_ptr; 3214 3215 end; /* leading separate sign sending field */ 3216 3217 /* Make a copy of the sending data name token */ 3218 3219 substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = 3220 substr (sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size); 3221 3222 sf_ptr = sf_cpy_ptr; 3223 3224 /* Must call calc_char_offset before item_length is adjusted. */ 3225 3226 call calc_char_offset (spl - rpl, sf_ptr); 3227 3228 sf_ptr -> data_name.places_left = rpl; 3229 sf_ptr -> data_name.item_length = rpl + spr; 3230 3231 if sf_ptr -> data_name.sign_separate 3232 then sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1; 3233 3234 call gen_move_dec_numer (sf_ptr, rf_ptr); 3235 3236 end; /* Move source field to receiving field, doing point alignment 3237* and truncation if necessary. */ 3238 3239 end; /* Receiving field not big enough to hold the sending field. */ 3240 end; /* Receiving field does have places left. */ 3241 3242 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3243 3244 end dec_dec; 3245 3246 /* { */ 3247 num_to_udts: 3248 proc (sf_ptr, rf_ptr, return_code); 3249 /***..... dcl LOCAL_NAME char (11) int static init ("NUM_TO_UDTS");/**/ 3250 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3251 3252 /* 3253* This procedure is called to generate code to convert any 3254* numeric data item to an unpacked decimal, trailing separate 3255* sign value. 3256* NOTE: If the source variable is already an unpacked separate 3257* trailing sign decimal variable, then no code is generated. 3258* Instead, a copy of the input data name token is made. 3259**/ 3260 3261 /* DECLARATION OF THE PARAMETERS */ 3262 3263 dcl sf_ptr ptr; 3264 dcl rf_ptr ptr; 3265 dcl return_code fixed bin; 3266 3267 /* DESCRIPTION OF THE PARAMETERS */ 3268 3269 /* 3270* PARAMETER DESCRIPTION 3271* sf_ptr Pointer to the data name token for the 3272* variable to be converted . (input) 3273* rf_ptr Pointer to a buffer in which the data name 3274* token for the unpacked decimal trailing 3275* separate sign variable is built by this 3276* procedure. (input) 3277* return_code A code that indicates whether an error 3278* was detected by this procedure during 3279* the generation of the code. A non-zero 3280* return code value indicates an error. (output) 3281**/ 3282 3283 /* } */ 3284 3285 /* DECLARATION OF INTERNAL VARIABLES */ 3286 3287 dcl ret_offset fixed bin; 3288 dcl dum_buff char (500) based; 3289 3290 3291 return_code = 0; 3292 3293 /* if rf_ptr is null(), then create a buffer into which the token is built. */ 3294 3295 if rf_ptr = null () 3296 then call cobol_make_type9$decimal_9bit (rf_ptr, 1000, 0, 0, 0); 3297 3298 3299 /* Make a copy of the data name token of the data item to be converted. */ 3300 3301 substr (rf_ptr -> dum_buff, 1, sf_ptr -> data_name.size) = 3302 substr (sf_ptr -> dum_buff, 1, sf_ptr -> data_name.size); 3303 3304 /* Make the copy reference an unsubscripted trailing separate sign value. */ 3305 3306 rf_ptr -> data_name.subscripted = "0"b; 3307 rf_ptr -> data_name.linkage_section = "0"b; 3308 rf_ptr -> data_name.sign_separate = "1"b; 3309 rf_ptr -> data_name.display = "1"b; 3310 rf_ptr -> data_name.sign_type = "011"b; /* trailing separate sign */ 3311 3312 /* Zero bits to the usage is "COMP" bits */ 3313 3314 rf_ptr -> data_name.ascii_packed_dec = "0"b; 3315 rf_ptr -> data_name.bin_18 = "0"b; 3316 rf_ptr -> data_name.bin_36 = "0"b; 3317 3318 /* Determine the length and scale factor of the receiving item. */ 3319 3320 if sf_ptr -> data_name.bin_18 3321 then do; /* bin_18 source field */ 3322 3323 rf_ptr -> data_name.places_left = 6; 3324 rf_ptr -> data_name.places_right = 0; 3325 rf_ptr -> data_name.item_length = 7; /* 6 places left + 1 byte for sign */ 3326 end; /* bin_18 source field. */ 3327 3328 else if sf_ptr -> data_name.bin_36 3329 then do; /* bin_36 source field */ 3330 3331 rf_ptr -> data_name.places_left = 11; 3332 rf_ptr -> data_name.places_right = 0; 3333 rf_ptr -> data_name.item_length = 12; /* includes 1 byte for sign */ 3334 end; /* bin_36 source field */ 3335 3336 else /* source field is unpacked decimal, packed decimal, or overpunch sign. */ 3337 rf_ptr -> data_name.item_length = sf_ptr -> data_name.places_right + sf_ptr -> data_name.places_left + 1; 3338 /* includes 1 byte for sign */ 3339 3340 if (^sf_ptr -> data_name.display /* NOT DISPLAY */ 3341 | sf_ptr -> data_name.sign_type ^= "011"b /* or NOT trailing sign */ 3342 | sf_ptr -> data_name.subscripted /* or subscripted */) 3343 then do; /* Generate code to move the source to the unpacked trailing sign decimal */ 3344 3345 /* Allocate space on the stack */ 3346 3347 call cobol_alloc$stack (fixed (rf_ptr -> data_name.item_length, 17), 0, ret_offset); 3348 3349 rf_ptr -> data_name.offset = ret_offset; 3350 rf_ptr -> data_name.seg_num = 1000; /* stack */ 3351 3352 /* Call internal procedure to generate the code. */ 3353 3354 call num_to_num (sf_ptr, rf_ptr); 3355 3356 end; /* Generate code to move the source to the unpackde trailing sign decimal. */ 3357 3358 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3359 3360 end num_to_udts; 3361 3362 /* { */ 3363 sb_lb: 3364 proc (sf_ptr, rf_ptr); 3365 /***..... dcl LOCAL_NAME char (5) int static init ("SB_LB");/**/ 3366 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3367 3368 /* 3369* This procedure generates code that moves a short fixed binary 3370* variable (18 bits) to a long fixed binary value. */ 3371 3372 /* DECLARATION OF THE PARAMETERS */ 3373 3374 dcl sf_ptr ptr; 3375 dcl rf_ptr ptr; 3376 3377 /* DESCRIPTION OF THE PARAMETERS */ 3378 3379 /* 3380* PARAMETER DESCRIPTION 3381* sf_ptr Pointer to the data name token for the 3382* source variable. (input) 3383* rf_ptr Pointer to the data name token for the 3384* receiving variable. (input) 3385**/ 3386 3387 /* DECLARATION OF INTERNAL STATIC DATA */ 3388 3389 dcl shift_inst bit (36) int static init ("000000000000010010000000000000000000"b); 3390 /* arg 18 */ 3391 3392 /* DECLARATIONS OF INTERNAL VARIABLES */ 3393 3394 dcl source_reloc bit (36); 3395 3396 dcl ret_offset fixed bin; 3397 dcl temp_ptr ptr; 3398 3399 dcl 1 reg_load_struc, 3400 2 what_reg fixed bin, 3401 2 reg_no bit (4), 3402 2 lock fixed bin, 3403 2 already_there fixed bin, 3404 2 contains fixed bin, 3405 2 pointer ptr, 3406 2 literal bit (36); 3407 3408 /*[4.3-1]*/ 3409 if sf_ptr -> data_name.subscripted | rf_ptr -> data_name.subscripted 3410 /*[4.3-1]*/ 3411 then do; 3412 call bin_move_bin (sf_ptr, rf_ptr); /*[4.3-1]*/ 3413 go to sbx; /*[4.3-1]*/ 3414 end; 3415 3416 3417 /* Get the address of the source variable. */ 3418 3419 eis_ (1) = (36)"0"b; 3420 source_reloc = "0"b; 3421 3422 input_struc.type = 2; 3423 input_struc.operand_no = 1; 3424 input_struc.lock = 0; 3425 input_struc.operand.token_ptr (1) = sf_ptr; 3426 input_struc.operand.size_sw (1) = 0; 3427 3428 call cobol_addr (input_ptr, inst_ptr, addr (source_reloc)); 3429 3430 /* Get the A or Q register */ 3431 3432 reg_load_struc.what_reg = 4; /* A or Q */ 3433 reg_load_struc.lock = 1; 3434 reg_load_struc.contains = 0; 3435 3436 call cobol_register$load (addr (reg_load_struc)); 3437 3438 /* Build LDA or LDQ instruction to load the short binary variable */ 3439 3440 if reg_load_struc.reg_no = "0001"b 3441 then inst_struc_basic.fill1_op = LDA; 3442 else inst_struc_basic.fill1_op = LDQ; 3443 3444 call cobol_emit (inst_ptr, addr (source_reloc), 1); 3445 3446 if substr (unspec (sf_ptr -> data_name.offset), 35, 2) = "10"b 3447 then do; /* Source variable is aligned on a half-word boundary, and thus was loaded 3448* into the lower half of the A or Q. */ 3449 3450 /* Emit code to shift value to upper half of A or Q. */ 3451 3452 if reg_load_struc.reg_no = "0001"b 3453 then substr (shift_inst, 19, 10) = ALS; 3454 else substr (shift_inst, 19, 10) = QLS; 3455 3456 call cobol_emit (addr (shift_inst), null (), 1); 3457 3458 end; /* Source variable is aligned on a half word boundary. */ 3459 3460 /* Emit code to shift A or Q right 18, to extend the sign bit. */ 3461 3462 if reg_load_struc.reg_no = "0001"b 3463 then substr (shift_inst, 19, 10) = ARS; 3464 else substr (shift_inst, 19, 10) = QRS; 3465 3466 call cobol_emit (addr (shift_inst), null (), 1); 3467 3468 3469 /* Emit code to store the A or Q into the receiving long fixed binary. */ 3470 3471 input_struc.operand.token_ptr (1) = rf_ptr; 3472 3473 call cobol_addr (input_ptr, inst_ptr, addr (source_reloc)); 3474 3475 3476 if reg_load_struc.reg_no = "0001"b 3477 then inst_struc_basic.fill1_op = STA; 3478 else inst_struc_basic.fill1_op = STQ; 3479 3480 call cobol_emit (inst_ptr, addr (source_reloc), 1); 3481 3482 /* Unlock the A or Q register */ 3483 3484 call cobol_register$release (addr (reg_load_struc)); 3485 3486 sbx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3487 end sb_lb; 3488 3489 /* { */ 3490 dec_lb: 3491 proc (sf_ptr, rf_ptr); 3492 /***..... dcl LOCAL_NAME char (6) int static init ("DEC_LB");/**/ 3493 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3494 3495 /* 3496* This procedure generates code to convert a decimal variable 3497* (packed or unpacked, signed or unsigned) to long (36 bit) fixed 3498* binary. 3499**/ 3500 3501 /* DECLARATION OF THE PARAMETERS */ 3502 3503 dcl sf_ptr ptr; 3504 dcl rf_ptr ptr; 3505 3506 /* DESCRIPTION OF THE PARAMETERS */ 3507 3508 /* 3509* PARAMETER DESCRIPTION 3510* sf_ptr Pointer to the data name token of the 3511* sending decimal variable. (input) 3512* rf_ptr Pointer to the data name token of the 3513* receiving long binary variable. (input) 3514* 3515**/ 3516 3517 3518 /* DECLARATION OF INTERNAL STATIC DATA */ 3519 3520 dcl long_binary_mask bit (72) int static 3521 init 3522 /* octal = 400000000000377777777777 */ ( 3523 "100000000000000000000000000000000000011111111111111111111111111111111111"b); 3524 3525 /* DECLARATION OF INTERNAL VARIABLES */ 3526 3527 dcl bump fixed bin; 3528 dcl ret_offset fixed bin; 3529 3530 dcl 1 reg_load_struc, 3531 2 what_reg fixed bin, 3532 2 reg_no bit (4), 3533 2 lock fixed bin, 3534 2 already_there fixed bin, 3535 2 contains fixed bin, 3536 2 pointer ptr, 3537 2 literal bit (36); 3538 3539 dcl temp_inst bit (36); 3540 dcl temp_inst_ptr ptr; 3541 dcl temp_reloc (1:2) bit (5) aligned; 3542 dcl long_bin_limit fixed bin; 3543 dcl temp_reloc_ptr ptr; 3544 dcl mask_ptr ptr; 3545 dcl const_offset fixed bin (24); 3546 dcl bin_tkn_ptr ptr; 3547 dcl binary_mask_string char (8) based (mask_ptr); 3548 3549 spl = sf_ptr -> data_name.places_left; 3550 spr = sf_ptr -> data_name.places_right; 3551 3552 if spl <= 0 3553 then do; /* Sending field less than zero. Move zero to the receiving field. */ 3554 3555 call dec_zero (temp_tkn_ptr); 3556 3557 call set_ips_type5_6 (5, temp_tkn_ptr, rf_ptr, null ()); 3558 3559 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 3560 3561 inst_struc.fill1_op = DTB; 3562 3563 call cobol_emit (inst_ptr, reloc_ptr, 3); 3564 3565 end; /* Sending field less than zero. Move zero to the receiving field. */ 3566 3567 else do; /* Sending field has an integer part. */ 3568 3569 if (sf_ptr -> data_name.places_right ^= 0 3570 | (sf_ptr -> data_name.sign_type = "100"b /* leading separate */ 3571 & sf_ptr -> data_name.places_left > rf_ptr -> data_name.places_left)) 3572 then call dec_dec_fix (sf_ptr, temp_tkn_ptr); 3573 /* fix the decimal variable. */ 3574 3575 else temp_tkn_ptr = sf_ptr; /* Sending variable already an integer 3576* with no sign, or a trailing separate sign. */ 3577 3578 /* At this point, if the sending decimal value was not an integer, or if it had 3579* a leading separate sign, code has been generated to convert the decimal value to an 3580* integer value with trailing separate sign. Next code is generated to convert 3581* the decimal integer value to long fixed binary. The code sequence generated is: 3582* 3583* dtb convert fixed decimal to fixed binary 3584* desc9ts source,12,0 3585* desc9a temp1,8 3586* ldaq temp1 3587* anaq =o400000000000377777777777 3588* stq temp1 3589* orsa temp1 3590* mlr 3591* desc9a temp1,4 3592* desc9a final,4 3593* 3594**/ 3595 3596 if temp_tkn_ptr -> data_name.bin_32 3597 then long_bin_limit = 10; 3598 else long_bin_limit = 11; 3599 3600 if temp_tkn_ptr -> data_name.places_left > long_bin_limit 3601 then do; /* Modify the token so the least significant long_bin_limit digits are converted to binary. */ 3602 3603 if temp_tkn_ptr = sf_ptr 3604 then do; /* Make a copy of the token. The token copy will be modified. */ 3605 3606 3607 temp_tkn_ptr = null (); 3608 if sf_ptr -> data_name.subscripted 3609 then call cobol_make_type9$copy_sub (temp_tkn_ptr, sf_ptr); 3610 3611 else call cobol_make_type9$copy (temp_tkn_ptr, sf_ptr); 3612 3613 end; /* Make a copy of the token. */ 3614 3615 bump = temp_tkn_ptr -> data_name.places_left - long_bin_limit; 3616 3617 call calc_char_offset (bump, temp_tkn_ptr); 3618 3619 temp_tkn_ptr -> data_name.places_left = long_bin_limit; 3620 3621 if temp_tkn_ptr -> data_name.sign_type = "011"b 3622 /* trailing separate */ 3623 then temp_tkn_ptr -> data_name.item_length = long_bin_limit + 1; 3624 else temp_tkn_ptr -> data_name.item_length = long_bin_limit; 3625 3626 end; /* Modify token so least significant long_bin_limit digits are converted to binary. */ 3627 3628 if temp_tkn_ptr -> data_name.places_left > (long_bin_limit - 1) 3629 then do; /* Sending field could possibly overflow one word (36 bits). Must convert into 3630* a double word, and then truncate on the left. */ 3631 /* Allocate 8 bytes of even word aligned storage on the stack. */ 3632 3633 call cobol_alloc$stack (8, 2 /* even word boundary */, ret_offset); 3634 3635 ret_offset = ret_offset * 4; /* convert word offset to char offset */ 3636 3637 /* Make a long fixed binary data name token for the temporary. */ 3638 bin_tkn_ptr = null (); 3639 3640 call cobol_make_type9$long_bin (bin_tkn_ptr, 1000, ret_offset); 3641 3642 /* Set item length in the token to 8 bytes (make_type9 sets it to 4) */ 3643 bin_tkn_ptr -> data_name.item_length = 8; 3644 3645 end; /* Sending field could possibly overflow one word. Must convert into a bouble 3646* word. */ 3647 3648 else bin_tkn_ptr = rf_ptr; /* Can convert directly into the receiving field. */ 3649 3650 /* Generate EIS instruction and descriptors for the DTB instruction. */ 3651 3652 call set_ips_type5_6 (5, temp_tkn_ptr, bin_tkn_ptr, null ()); 3653 3654 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 3655 3656 inst_struc.fill1_op = DTB; 3657 3658 call cobol_emit (inst_ptr, reloc_ptr, 3); 3659 3660 if bin_tkn_ptr ^= rf_ptr 3661 then do; /* Sending field was not converted directly into the receiving field. */ 3662 3663 /* Pool the long binary mask */ 3664 mask_ptr = addr (long_binary_mask); 3665 /* Note that the mask must be pooled on an even word boundary, because it is going 3666* to be used in a double register instruction. */ 3667 3668 call cobol_pool$search_op (binary_mask_string, 2, const_offset, in_op); 3669 3670 /* Convert the returned word offset to character offset. */ 3671 const_offset = const_offset * 4; 3672 3673 /* Get the address of the temporary double word that contains the fixed binary value. */ 3674 temp_inst_ptr = addr (temp_inst); 3675 temp_reloc_ptr = addr (temp_reloc (1)); 3676 input_struc_basic.type = 1; 3677 input_struc_basic.operand_no = 0; 3678 input_struc_basic.segno = bin_tkn_ptr -> data_name.seg_num; 3679 input_struc_basic.char_offset = bin_tkn_ptr -> data_name.offset; 3680 input_struc_basic.send_receive = 1; 3681 /* sending */ 3682 3683 call cobol_addr (input_ptr, temp_inst_ptr, temp_reloc_ptr); 3684 3685 /* Get the A and Q registers */ 3686 reg_load_struc.what_reg = 3; /* A and Q */ 3687 reg_load_struc.lock = 0; 3688 reg_load_struc.contains = 0; 3689 3690 call cobol_register$load (addr (reg_load_struc)); 3691 3692 /* Build and emit LDAQ "temp" instruction */ 3693 substr (temp_inst, 19, 10) = LDAQ; 3694 3695 call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); 3696 3697 /* Get basic address of the long binary mask */ 3698 3699 if in_op = 1 3700 then input_struc_basic.segno = 3; 3701 else input_struc_basic.segno = 3000; 3702 3703 input_struc_basic.char_offset = const_offset; 3704 3705 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 3706 3707 /* Build and emit ANAQ "long bin mask" instruction. */ 3708 inst_struc_basic.fill1_op = ANAQ; 3709 3710 call cobol_emit (inst_ptr, reloc_ptr, 1); 3711 3712 /* Build and emit STQ "temp" instruction. */ 3713 substr (temp_inst, 19, 10) = STQ; 3714 3715 call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); 3716 3717 /* Build and emit ORSA "temp" instruction. */ 3718 substr (temp_inst, 19, 10) = ORSA; 3719 3720 call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); 3721 3722 /* Generate code to move the value in the stack temporary to the receiving field. */ 3723 3724 bin_tkn_ptr -> data_name.item_length = 4; 3725 bin_tkn_ptr -> data_name.numeric = "0"b; 3726 bin_tkn_ptr -> data_name.alphanum = "1"b; 3727 rf_ptr -> data_name.numeric = "0"b; 3728 rf_ptr -> data_name.alphanum = "1"b; 3729 3730 call set_ips_type5_6 (5, bin_tkn_ptr, rf_ptr, null ()); 3731 3732 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 3733 3734 inst_struc.fill1_op = MLR; 3735 3736 call cobol_emit (inst_ptr, reloc_ptr, 3); 3737 3738 /* Reset the receiving field token. */ 3739 3740 rf_ptr -> data_name.numeric = "1"b; 3741 rf_ptr -> data_name.alphanum = "0"b; 3742 3743 end; /* Sending field was not converted directly into the receiving field. */ 3744 3745 /* Restore the A and Q */ 3746 3747 call cobol_register$release (addr (reg_load_struc)); 3748 3749 end; /* Sending field has an integer part. */ 3750 3751 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3752 3753 end dec_lb; 3754 3755 /* { */ 3756 lb_sb: 3757 proc (sf_ptr, rf_ptr); 3758 /***..... dcl LOCAL_NAME char (5) int static init ("LB_SB");/**/ 3759 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3760 3761 /* 3762* This procedure generates code to move a long fixed binary (36 bit) 3763* variable to a short fixed binary (18 bit) variable. 3764**/ 3765 3766 /* DECLARATION OF THE PARAMETERS */ 3767 3768 dcl sf_ptr ptr; 3769 dcl rf_ptr ptr; 3770 dcl j fixed bin; 3771 3772 /* DESCRIPTION OF THE PARAMETERS */ 3773 3774 /* 3775* PARAMETER DESCRIPTION 3776* sf_ptr Pointer to the data name token for the 3777* source variable. (input) 3778* rf_ptr Pointer to the data name tokne for the 3779* receiving variable. (input) 3780**/ 3781 3782 if rf_ptr -> data_name.subscripted = "0"b 3783 then do; 3784 3785 call load_bin (sf_ptr, 3); 3786 3787 if substr (unspec (rf_ptr -> data_name.offset), 35, 2) = "10"b 3788 then j = 7; 3789 else j = 6; 3790 3791 call load_bin (rf_ptr, j); 3792 3793 end; 3794 else do; 3795 3796 call bin_move_bin (sf_ptr, rf_ptr); 3797 3798 end; 3799 3800 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3801 3802 end lb_sb; 3803 3804 /* { */ 3805 bin_same_bin: 3806 proc (sf_ptr, rf_ptr); 3807 /***..... dcl LOCAL_NAME char (12) int static init ("BIN_SAME_BIN");/**/ 3808 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3809 3810 /* 3811* This procedure generates code to move a binary variable 3812* to a binary variable of the same length, that is, 3813* 1. short binary to short binary 3814* 2. long binary to long binary 3815**/ 3816 3817 /* DECLARATION OF THE PARAMETERS */ 3818 3819 dcl sf_ptr ptr; 3820 dcl rf_ptr ptr; 3821 dcl j fixed bin; 3822 3823 /* DESCRIPTION OF THE PARAMETERS */ 3824 /* 3825* PARAMETER DESCRIPTION 3826* sf_ptr Pointer to the data name token for the 3827* source variable. (input) 3828* rf_ptr Pointer to the data name token for the 3829* receiving variable. (input) 3830* 3831**/ 3832 3833 /*[4.3-2]*/ 3834 if sf_ptr -> data_name.subscripted | rf_ptr -> data_name.subscripted 3835 /*[4.3-2]*/ 3836 then do; 3837 call bin_move_bin (sf_ptr, rf_ptr); /*[4.3-2]*/ 3838 go to binx; /*[4.3-2]*/ 3839 end; 3840 3841 if sf_ptr -> data_name.bin_36 3842 then do; 3843 3844 call load_bin (sf_ptr, 1); 3845 3846 call load_bin (rf_ptr, 4); 3847 3848 end; 3849 else do; 3850 3851 if sf_ptr -> data_name.subscripted = "0"b & rf_ptr -> data_name.subscripted = "0"b 3852 then do; 3853 3854 if substr (unspec (sf_ptr -> data_name.offset), 35, 2) = "10"b 3855 then j = 3; 3856 else j = 2; 3857 3858 call load_bin (sf_ptr, j); 3859 3860 if substr (unspec (rf_ptr -> data_name.offset), 35, 2) = "10"b 3861 then j = 7; 3862 else j = 6; 3863 3864 call load_bin (rf_ptr, j); 3865 3866 end; 3867 else do; 3868 3869 call bin_move_bin (sf_ptr, rf_ptr); 3870 3871 end; 3872 end; 3873 3874 binx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3875 end bin_same_bin; 3876 3877 load_bin: 3878 proc (temp_ptr, code); 3879 /***..... dcl LOCAL_NAME char (8) int static init ("LOAD_BIN");/**/ 3880 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3881 /* load long or short bin */ 3882 3883 dcl temp_ptr ptr; 3884 dcl code fixed bin; 3885 dcl inst_op (7) bit (10) static init ("0100111010"b, 3886 /* lda */ 3887 "0100100000"b, /* ldxn */ 3888 "1110100000"b, /* lxln */ 3889 "1111011010"b, /* sta */ 3890 "1011010010"b, /* stba */ 3891 "1111000000"b, /* stxn */ 3892 "1001000000"b); /* sxln */ 3893 3894 /* The followings are for the register structure */ 3895 /* reg_struc_ptr is a pointer to the following structure (input) */ 3896 3897 dcl 1 reg_struc static, 3898 2 what_reg fixed bin, 3899 2 reg_num bit (4), 3900 2 lock fixed bin init (1), 3901 2 already_there fixed bin, 3902 2 contains fixed bin, 3903 2 pointer ptr, 3904 2 literal bit (36); 3905 3906 start: 3907 input_struc.type = 2; 3908 input_struc.operand_no = 1; 3909 input_struc.lock = 0; 3910 input_struc.token_ptr (1) = temp_ptr; 3911 input_struc.size_sw (1) = 0; 3912 3913 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 3914 3915 if code = 1 3916 then reg_struc.what_reg = 1; 3917 else if code = 2 | code = 3 3918 then reg_struc.what_reg = 14; 3919 3920 inst_struc.fill1_op = inst_op (code); 3921 3922 if code <= 3 3923 then do; 3924 3925 call cobol_register$load (addr (reg_struc)); 3926 3927 if code = 2 | code = 3 3928 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); 3929 3930 call cobol_emit (inst_ptr, reloc_ptr, 1); 3931 3932 end; 3933 else do; 3934 3935 if code = 6 | code = 7 3936 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); 3937 3938 call cobol_emit (inst_ptr, reloc_ptr, 1); 3939 3940 call cobol_register$release (addr (reg_struc)); 3941 3942 end; 3943 3944 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3945 3946 end load_bin; 3947 3948 bin_move_bin: 3949 proc (sf_ptr, rf_ptr); 3950 /***..... dcl LOCAL_NAME char (12) int static init ("BIN_MOVE_BIN");/**/ 3951 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3952 3953 /* This procedure generate code to move binary data to binary data 3954* through eis instruction. Because of subscripted bin_18 data is 3955* not expected for its alignment, non-eis instructions are not 3956* applicable. */ 3957 3958 dcl (sf_ptr, rf_ptr) ptr; 3959 3960 sf_ptr -> data_name.numeric = "0"b; 3961 sf_ptr -> data_name.alphanum = "1"b; 3962 rf_ptr -> data_name.numeric = "1"b; 3963 rf_ptr -> data_name.alphanum = "1"b; 3964 3965 /* Build input to the addressability utility */ 3966 3967 call set_ips_type5_6 (5, sf_ptr, rf_ptr, null ()); 3968 3969 /* Call the addressability utility to build instruction and two descriptors. */ 3970 3971 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 3972 3973 /* Set the MLR opcode into the instruction. */ 3974 3975 /* [4.2-1] */ 3976 inst_struc.fill1_op = MRL; 3977 3978 /* Emit the instruction to move source to receiving. */ 3979 3980 call cobol_emit (inst_ptr, reloc_ptr, 3); 3981 3982 3983 sf_ptr -> data_name.alphanum = "0"b; 3984 sf_ptr -> data_name.numeric = "1"b; 3985 rf_ptr -> data_name.alphanum = "0"b; 3986 rf_ptr -> data_name.numeric = "1"b; 3987 3988 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 3989 3990 end bin_move_bin; 3991 3992 /* { */ 3993 any_bin_dec: 3994 proc (sf_ptr, rf_ptr); 3995 /***..... dcl LOCAL_NAME char (11) int static init ("ANY_BIN_DEC");/**/ 3996 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 3997 3998 /* 3999* This procedure generates code to move any fixed binary 4000* variable to an unpacked or packed decimal variable. */ 4001 4002 /* DECLARATION OF THE PARAMETERS */ 4003 4004 dcl sf_ptr ptr; 4005 dcl rf_ptr ptr; 4006 4007 /* DESCRIPTION OF THE PARAMETERS */ 4008 4009 /* 4010* PARAMETER DESCRIPTION 4011* sf_ptr Pointer to the data name token for the 4012* fixed binary source variable. (input) 4013* rf_ptr Pointer to the data name token for the 4014* decimal (packed or unpackde) receiving 4015* variable. (input) 4016* 4017**/ 4018 4019 /* DECLARATIONS OF INTERNAL VARIABLES */ 4020 4021 dcl dec_temp_size fixed bin; 4022 dcl ret_offset fixed bin; 4023 dcl dec_tkn_ptr ptr; 4024 dcl temp_result bit (1); 4025 4026 temp_result = "0"b; 4027 4028 /* Determine the size of the temporary required to hold the decimal representation 4029* of the fixed binary. */ 4030 4031 if sf_ptr -> data_name.bin_18 4032 then dec_temp_size = 6; /* includes 1 byte for sign */ 4033 else dec_temp_size = 11; 4034 4035 if (rf_ptr -> data_name.places_left < dec_temp_size | rf_ptr -> data_name.places_right ^= 0) 4036 then do; /* Convert the binary value into a temporary on the stack. */ 4037 /* Allocate space on the stack for the temporary. */ 4038 4039 call cobol_alloc$stack (dec_temp_size + 1, 0, ret_offset); 4040 4041 /* Make a data name token for the decimal temporary. */ 4042 4043 dec_tkn_ptr = null (); 4044 4045 call cobol_make_type9$decimal_9bit (dec_tkn_ptr, 1000 /* stack */, fixed (ret_offset, 24), 4046 dec_temp_size, 0); 4047 4048 /* change sign type from leading separate to trailing separate. */ 4049 4050 dec_tkn_ptr -> data_name.sign_type = "011"b; 4051 /* trailing separate */ 4052 temp_result = "1"b; 4053 4054 end; /* Convert the binary value into a temporary on the stack. */ 4055 4056 else dec_tkn_ptr = rf_ptr; 4057 4058 /* Build input to the addressability utility */ 4059 4060 call set_ips_type5_6 (5, sf_ptr, dec_tkn_ptr, null ()); 4061 4062 /* Build the EIS instruction and descriptors. */ 4063 4064 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 4065 4066 /* Insert BTD opcode. */ 4067 4068 inst_struc.fill1_op = BTD; 4069 4070 /* Emit the code. */ 4071 4072 call cobol_emit (inst_ptr, reloc_ptr, 3); 4073 4074 /* At this point, if code has been generated to convert the short or long binary value into 4075* a trailing separate sign value in the stack, it is now necessary to move the decimal temporary 4076* to the decimal receiving field. */ 4077 4078 if temp_result 4079 then call dec_dec (dec_tkn_ptr, rf_ptr); 4080 4081 4082 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4083 4084 end any_bin_dec; 4085 4086 /* { */ 4087 dec_sb: 4088 proc (sf_ptr, rf_ptr); 4089 /***..... dcl LOCAL_NAME char (6) int static init ("DEC_SB");/**/ 4090 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 4091 4092 /* 4093* This internal procedure generates code to convert a decimal 4094* value (packed or unpacked, unsigned or separate sign) to 4095* short fixed binary. */ 4096 4097 /* DECLARATION OF THE PARAMETERS */ 4098 4099 dcl sf_ptr ptr; 4100 dcl rf_ptr ptr; 4101 4102 /* DESCRIPTION OF THE PARAMETERS */ 4103 4104 /* 4105* 4106* PARAMETER DESCRIPTION 4107* sf_ptr Pointer to the data name token of the 4108* sending decimal field. 4109* rf_ptr Pointer to the data name token of the 4110* short binary receiving field. 4111**/ 4112 4113 /* DECLARATION OF INTERNAL STATIC VARAIBLES */ 4114 4115 dcl arl_18_inst bit (36) int static init ("000000000000010010000000000000000000"b); 4116 /* arg 18 */ 4117 4118 dcl short_binary_mask bit (36) int static init ("100000000000000000011111111111111111"b); 4119 4120 /* DECLARATIONS OF INTERNAL VARIABLES */ 4121 4122 dcl temp_inst bit (36); 4123 dcl temp_inst_ptr ptr; 4124 dcl temp_reloc (1:5) bit (5) aligned; 4125 dcl temp_reloc_ptr ptr; 4126 dcl short_bin_limit fixed bin; 4127 dcl shift_inst_ptr ptr; 4128 4129 dcl 1 reg_load_struc, 4130 2 what_reg fixed bin, 4131 2 reg_no bit (4), 4132 2 lock fixed bin, 4133 2 already_there fixed bin, 4134 2 contains fixed bin; 4135 4136 dcl ret_offset fixed bin; 4137 dcl const_offset fixed bin (24); 4138 dcl mask_ptr ptr; 4139 dcl binary_mask_string char (4) based (mask_ptr); 4140 dcl bin_tkn_ptr ptr; 4141 dcl bump fixed bin; 4142 4143 start_dec_sb: 4144 spl = sf_ptr -> data_name.places_left; 4145 spr = sf_ptr -> data_name.places_right; 4146 4147 if spl <= 0 4148 then do; /* Sending field less than zero, move zero to the receiving field. */ 4149 4150 call dec_zero (temp_tkn_ptr); 4151 4152 call set_ips_type5_6 (5, temp_tkn_ptr, rf_ptr, null ()); 4153 4154 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 4155 4156 inst_struc.fill1_op = DTB; 4157 4158 call cobol_emit (inst_ptr, reloc_ptr, 3); 4159 4160 end; /* Sending field less than zero, move zero to the receiving field. */ 4161 4162 else do; /* Sending field has an integer part. */ 4163 4164 if (sf_ptr -> data_name.places_right ^= 0 4165 | sf_ptr -> data_name.sign_type = "100"b /* leading separate */) 4166 then call dec_dec_fix (sf_ptr, temp_tkn_ptr); 4167 4168 else temp_tkn_ptr = sf_ptr; 4169 4170 /* At this point, code has been generated to convert the decimal variable to an 4171* integer decimal value. (no places to the right of the decimal point) 4172* Now we generate code to convert the fixed decimal to short fixed binary. The 4173* code sequence to be generated is: 4174* 4175* dtb convert fixed decimal to fixed binary 4176* desc9ts source,7,0 4177* desc9a temp1,4 4178* lda temp1 4179* ana =o400000377777 4180* sta temp1 4181* alr 18 4182* orsa temp1 4183* mlr 4184* desc9a temp1(2),2 4185* desc9a final_result,2 4186* 4187* */ 4188 4189 if temp_tkn_ptr -> data_name.bin_16 4190 then short_bin_limit = 5; 4191 else short_bin_limit = 6; 4192 4193 if temp_tkn_ptr -> data_name.places_left > short_bin_limit 4194 then do; /* Modify the token so the short_bin_limit least significant digits 4195* of data are converted. */ 4196 4197 if temp_tkn_ptr = sf_ptr 4198 then do; /* Make a copy of the source token . */ 4199 4200 temp_tkn_ptr = null (); 4201 4202 if sf_ptr -> data_name.subscripted 4203 then call cobol_make_type9$copy_sub (temp_tkn_ptr, sf_ptr); 4204 4205 else call cobol_make_type9$copy (temp_tkn_ptr, sf_ptr); 4206 4207 end; /* Make a copy of the source token. */ 4208 4209 bump = temp_tkn_ptr -> data_name.places_left - short_bin_limit; 4210 4211 call calc_char_offset (bump, temp_tkn_ptr); 4212 4213 temp_tkn_ptr -> data_name.places_left = short_bin_limit; 4214 4215 if temp_tkn_ptr -> data_name.sign_type = "011"b 4216 /* trailing separate */ 4217 then temp_tkn_ptr -> data_name.item_length = short_bin_limit + 1; 4218 else temp_tkn_ptr -> data_name.item_length = short_bin_limit; 4219 4220 end; /* Modify the token so the short_bin_limit least significant digits 4221* of data are converted. */ 4222 4223 if temp_tkn_ptr -> data_name.places_left > (short_bin_limit - 1) 4224 then do; /* Sending field could possibly overflow one half word. Must convert it into a 4225* full word, and then truncate on the left. */ 4226 /* Allocate 4 bytes of word aligned storage on the stack. */ 4227 4228 4229 call cobol_alloc$stack (4, 0, ret_offset); 4230 4231 /* Make a long fixed binary data name token for the temporary storage */ 4232 4233 bin_tkn_ptr = null (); 4234 4235 call cobol_make_type9$long_bin (bin_tkn_ptr, 1000 /* stack */, ret_offset); 4236 4237 end; /* Sending field could possibly overflow one half word.. */ 4238 4239 else bin_tkn_ptr = rf_ptr; /* Can convert directly into the receiving field. */ 4240 4241 /* Generate EIS instruction and two descriptors for a DTB instruction */ 4242 4243 call set_ips_type5_6 (5, temp_tkn_ptr, bin_tkn_ptr, null ()); 4244 4245 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 4246 4247 inst_struc.fill1_op = DTB; 4248 4249 call cobol_emit (inst_ptr, reloc_ptr, 3); 4250 4251 4252 if bin_tkn_ptr ^= rf_ptr 4253 then do; /* Sending field was not converted directly into the receiving field. */ 4254 4255 /* Pool the short binary mask */ 4256 4257 mask_ptr = addr (short_binary_mask); 4258 4259 call cobol_pool$search_op (binary_mask_string, 0, const_offset, in_op); 4260 4261 if in_op = 0 4262 then temp = 3000; 4263 else temp = 3; 4264 4265 /* Make a data name token for the mask */ 4266 4267 mask_ptr = null (); 4268 4269 call cobol_make_type9$alphanumeric (mask_ptr, temp /* constant section */, const_offset, 4); 4270 4271 /* Get the address of the temporary word that contains the fixed binary value. */ 4272 4273 temp_inst_ptr = addr (temp_inst); 4274 temp_reloc_ptr = addr (temp_reloc (1)); 4275 4276 input_struc_basic.type = 1; 4277 input_struc_basic.operand_no = 0; 4278 input_struc_basic.lock = 0; 4279 input_struc_basic.segno = bin_tkn_ptr -> data_name.seg_num; 4280 input_struc_basic.char_offset = bin_tkn_ptr -> data_name.offset; 4281 input_struc_basic.send_receive = 1; 4282 /* sending */ 4283 4284 call cobol_addr (input_ptr, temp_inst_ptr, temp_reloc_ptr); 4285 4286 /* Get the A or Q */ 4287 4288 reg_load_struc.what_reg = 4; /* A or Q */ 4289 reg_load_struc.lock = 0; 4290 reg_load_struc.contains = 0; 4291 4292 call cobol_register$load (addr (reg_load_struc)); 4293 4294 /* Build LDA or LDQ instruction */ 4295 4296 if reg_load_struc.reg_no = "0001"b 4297 then substr (temp_inst, 19, 10) = LDA; 4298 else substr (temp_inst, 19, 10) = LDQ; 4299 4300 call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); 4301 4302 /* Build the basic address of the short binary mask */ 4303 4304 input_struc_basic.segno = mask_ptr -> data_name.seg_num; 4305 input_struc_basic.char_offset = mask_ptr -> data_name.offset; 4306 4307 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 4308 4309 if reg_load_struc.reg_no = "0001"b 4310 then inst_struc_basic.fill1_op = ANA; 4311 else inst_struc_basic.fill1_op = ANQ; 4312 4313 call cobol_emit (inst_ptr, reloc_ptr, 1); 4314 4315 4316 /* Emit code to store the A or Q */ 4317 4318 if reg_load_struc.reg_no = "0001"b 4319 then substr (temp_inst, 19, 10) = STA; 4320 else substr (temp_inst, 19, 10) = STQ; 4321 4322 call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); 4323 4324 /* Emit "arl 18" or "qrl 18" instruction */ 4325 4326 shift_inst_ptr = addr (arl_18_inst); 4327 4328 if reg_load_struc.reg_no = "0001"b 4329 then substr (arl_18_inst, 19, 10) = ARL; 4330 else substr (arl_18_inst, 19, 10) = QRL; 4331 4332 call cobol_emit (shift_inst_ptr, null (), 1); 4333 4334 /* Emit code to OR the A or Q to the temp value. */ 4335 4336 if reg_load_struc.reg_no = "0001"b 4337 then substr (temp_inst, 19, 10) = ORSA; 4338 else substr (temp_inst, 19, 10) = ORSQ; 4339 4340 call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); 4341 4342 /* Generate code to move the two least significant bytes of the fixed binary temporary 4343* into the receiving field. */ 4344 /* Update the character offset in the token that describes the fixed bin temp. */ 4345 4346 bin_tkn_ptr -> data_name.offset = bin_tkn_ptr -> data_name.offset + 2; 4347 4348 bin_tkn_ptr -> data_name.item_length = 2; 4349 bin_tkn_ptr -> data_name.numeric = "0"b; 4350 bin_tkn_ptr -> data_name.alphanum = "1"b; 4351 4352 rf_ptr -> data_name.numeric = "0"b; 4353 rf_ptr -> data_name.alphanum = "1"b; 4354 4355 call set_ips_type5_6 (5, bin_tkn_ptr, rf_ptr, null ()); 4356 4357 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 4358 4359 inst_struc_basic.fill1_op = MLR; 4360 4361 call cobol_emit (inst_ptr, reloc_ptr, 3); 4362 4363 rf_ptr -> data_name.numeric = "1"b; 4364 rf_ptr -> data_name.alphanum = "0"b; 4365 4366 end; /* Sending field was not converted directly into the receiving field. */ 4367 4368 end; /* Sending field has an integer part. */ 4369 4370 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4371 4372 end dec_sb; 4373 4374 /* { */ 4375 dec_dec_fix: 4376 proc (sf_ptr, fixed_sf_ptr); 4377 /***..... dcl LOCAL_NAME char (11) int static init ("DEC_DEC_FIX");/**/ 4378 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 4379 4380 /* 4381* This procedure generates code to fix (truncate places to the 4382* right of the decimal point) a packed or unpacked decimal value. */ 4383 4384 /* DECLARATION OF THE PARAMETERS */ 4385 4386 dcl sf_ptr ptr; 4387 dcl fixed_sf_ptr ptr; 4388 4389 /* DESCRIPTION OF THE PARAMETERS */ 4390 4391 /* 4392* PARAMETER DESCRIPTION 4393* sf_ptr Pointer to the data name token for the decimal 4394* variable to be fixed. (input) 4395* fixed_sf_ptr Pointer to a buffer in which the data name 4396* token for the fixed value is built. (input) 4397* 4398**/ 4399 4400 dcl ret_offset fixed bin; 4401 dcl temp_tok char (500) based; 4402 4403 /* Allocate space on the stack for the fixed value. */ 4404 4405 call cobol_alloc$stack (sf_ptr -> data_name.places_left + 1, 0, ret_offset); 4406 4407 /* Copy the source token into the user-supplied buffer. */ 4408 4409 substr (fixed_sf_ptr -> temp_tok, 1, sf_ptr -> data_name.size) = 4410 substr (sf_ptr -> temp_tok, 1, sf_ptr -> data_name.size); 4411 4412 /* Modify the token copy to describe the fixed value on the stack. */ 4413 4414 fixed_sf_ptr -> data_name.linkage_section = "0"b; 4415 fixed_sf_ptr -> data_name.item_length = fixed_sf_ptr -> data_name.places_left + 1; 4416 fixed_sf_ptr -> data_name.places_right = 0; 4417 fixed_sf_ptr -> data_name.sign_type = "011"b; /* trailing separate */ 4418 fixed_sf_ptr -> data_name.seg_num = 1000; /* stack */ 4419 fixed_sf_ptr -> data_name.offset = ret_offset; 4420 4421 /* Generate code to move the sending filed to the stack temporary. */ 4422 4423 call gen_move_dec_numer (sf_ptr, fixed_sf_ptr); 4424 4425 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4426 4427 end dec_dec_fix; 4428 4429 /* { */ 4430 non_opch_to_opch: 4431 proc (sf_ptr, rf_ptr); 4432 /***..... dcl LOCAL_NAME char (16) int static init ("NON_OPCH_TO_OPCH");/**/ 4433 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 4434 4435 /* 4436* This internal procedure generates code to move a non-overpunch 4437* sign variable to an overpunch sign receiving field. */ 4438 4439 /* DECLARATION OF THE PARAMETERS */ 4440 4441 dcl sf_ptr ptr; 4442 dcl rf_ptr ptr; 4443 4444 /* DECLARATION OF INTERNAL VARIABLES */ 4445 4446 dcl temp_sf_ptr ptr; 4447 dcl return_code fixed bin; 4448 dcl udts_token_ptr ptr; 4449 4450 /* The following declaration are used for numerical literal to opch. 6/1/76 bc. */ 4451 4452 dcl temp_rf_ptr ptr, 4453 move_char char (1), 4454 temp_len fixed bin, 4455 temp_ptr ptr, 4456 temp_space char (250), 4457 temp_sign_type bit (3), 4458 move_digit fixed bin, 4459 an_ptr ptr, 4460 conv_plus (0:9) char (1) static init ("{", "A", "B", "C", "D", "E", "F", "G", "H", "I"), 4461 conv_minus (0:9) char (1) static init ("}", "J", "K", "L", "M", "N", "O", "P", "Q", "R"); 4462 4463 dcl 1 al_lit, 4464 2 size fixed bin, 4465 2 line fixed bin, 4466 2 column fixed bin, 4467 2 type fixed bin, 4468 2 lit_type bit (1), 4469 2 all_lit bit (1), 4470 2 filler1 bit (6), 4471 2 lit_size fixed bin, 4472 2 string char (1); 4473 4474 /* ************************************************ */ 4475 /* START OF EXECUTION */ 4476 /* non_opch_to_opch */ 4477 /* ************************************************ */ 4478 4479 temp_sf_ptr = sf_ptr; 4480 4481 /* Handle the numeric to opch data. 6/1/76 by bc. */ 4482 4483 if numeric_lit_flag = 1 & rf_ptr -> data_name.elementary 4484 then do; 4485 4486 numeric_lit_flag = 0; 4487 temp_rf_ptr = rf_ptr; 4488 temp_rf_ptr -> data_name.item_signed = "0"b; 4489 temp_sign_type = temp_rf_ptr -> data_name.sign_type; 4490 temp_rf_ptr -> data_name.sign_type = "000"b; 4491 4492 call dec_dec (temp_sf_ptr, temp_rf_ptr); 4493 4494 move_char = "0"; 4495 4496 if temp_sign_type = "010"b 4497 then do; 4498 4499 if sf_ptr -> data_name.places_left >= temp_rf_ptr -> data_name.places_left 4500 then if (sf_ptr -> data_name.places_left - temp_rf_ptr -> data_name.places_left + 1 > 0) 4501 then move_char = 4502 substr (lit_str, 4503 sf_ptr -> data_name.places_left - temp_rf_ptr -> data_name.places_left + 1, 4504 1); 4505 4506 end; 4507 else do; 4508 4509 4510 if sf_ptr -> data_name.places_right >= temp_rf_ptr -> data_name.places_right 4511 then if (sf_ptr -> data_name.places_left + temp_rf_ptr -> data_name.places_right > 0) 4512 then move_char = 4513 substr (lit_str, 4514 sf_ptr -> data_name.places_left + temp_rf_ptr -> data_name.places_right, 1); 4515 4516 end; 4517 4518 move_digit = binary (move_char, 35); /* [3.0-2] */ 4519 4520 if substr (lit_str, lit_ln + 1, 1) ^= "-" 4521 then move_char = conv_plus (move_digit); 4522 else move_char = conv_minus (move_digit); 4523 4524 al_lit.type = 3; 4525 al_lit.size = 29; 4526 al_lit.all_lit = "0"b; 4527 al_lit.lit_type = "0"b; 4528 al_lit.lit_size = 1; 4529 al_lit.line = lin; 4530 al_lit.column = col; 4531 al_lit.string = move_char; 4532 an_ptr = addr (al_lit); 4533 temp_ptr = addr (temp_space); 4534 4535 call cobol_make_type9$type2_3 (temp_ptr, an_ptr); 4536 4537 temp_rf_ptr -> data_name.numeric = "0"b; 4538 temp_rf_ptr -> data_name.alphanum = "1"b; 4539 4540 call gen_move_alpha (MLR, "000110000"b, temp_ptr, temp_rf_ptr, "1"b); 4541 4542 if temp_sign_type = "001"b 4543 then do; 4544 4545 temp_len = 4546 fixed (substr (inst_struc.desc_od (2), 25, 12), 12) 4547 + fixed (substr (inst_struc.desc_od (2), 4, 17), 17) - 1; 4548 4549 substr (inst_struc.desc_od (2), 4, 17) = substr (unspec (temp_len), 20, 17); 4550 4551 end; 4552 4553 substr (inst_struc.desc_od (2), 25, 12) = "000000000001"b; 4554 4555 call cobol_emit (inst_ptr, reloc_ptr, 3); 4556 4557 temp_rf_ptr -> data_name.numeric = "1"b; 4558 temp_rf_ptr -> data_name.alphanum = "0"b; 4559 temp_rf_ptr -> data_name.item_signed = "1"b; 4560 temp_rf_ptr -> data_name.sign_type = temp_sign_type; 4561 4562 end; 4563 else do; 4564 4565 /* Check to see if zero should be moved to the rrceiving field, rather than the sending 4566* variable. */ 4567 4568 call check_zero_move (temp_sf_ptr, rf_ptr); 4569 4570 if temp_sf_ptr = sf_ptr 4571 then do; /* Sending variable should be moved. */ 4572 4573 udts_token_ptr = null (); 4574 4575 /* Convert the sending field to numeric decimal, trailing separate sign data if necessary. */ 4576 4577 call num_to_udts (temp_sf_ptr, udts_token_ptr, return_code); 4578 4579 end; /* Sending variable should be moved. */ 4580 4581 else udts_token_ptr = temp_sf_ptr; 4582 4583 call cobol_opch_op_call (udts_token_ptr, rf_ptr); 4584 4585 end; 4586 4587 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4588 4589 end non_opch_to_opch; 4590 4591 /* { */ 4592 opch_to_opch: 4593 proc (sf_ptr, rf_ptr); 4594 /***..... dcl LOCAL_NAME char (12) int static init ("OPCH_TO_OPCH");/**/ 4595 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 4596 /* 4597* This internal procedure generates code that moves an overpunch sign 4598* variable to an overpunch sign variable. */ 4599 4600 /* DECLARATION OF THE PARAMETERS */ 4601 4602 dcl sf_ptr ptr; 4603 dcl rf_ptr ptr; 4604 4605 /* DECLARATION OF INTERNAL VARIABLES */ 4606 4607 dcl temp_sf_ptr ptr; 4608 4609 /* ************************************************ */ 4610 /* START OF EXECUTION */ 4611 /* opch_to_opch */ 4612 /* ************************************************ */ 4613 4614 temp_sf_ptr = sf_ptr; 4615 4616 /* Check to see whether zero should be moved to the receiving field, rather than 4617* the sending variable. */ 4618 4619 call check_zero_move (temp_sf_ptr, rf_ptr); 4620 4621 4622 call cobol_opch_op_call (temp_sf_ptr, rf_ptr); 4623 4624 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4625 4626 end opch_to_opch; 4627 4628 /* { */ 4629 opch_to_non_opch: 4630 proc (sf_ptr, rf_ptr); 4631 /***..... dcl LOCAL_NAME char (16) int static init ("OPCH_TO_NON_OPCH");/**/ 4632 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 4633 4634 /* 4635* This internal procedure generates code to move an overpunch 4636* sign sending variable to any non-overpunch receiving variable. */ 4637 4638 /* Declaration of the Parameters */ 4639 4640 dcl sf_ptr ptr; 4641 dcl rf_ptr ptr; 4642 4643 /* Declarations of Internal Variables. */ 4644 4645 dcl char_offset fixed bin; 4646 dcl temp_sf_ptr ptr; 4647 dcl temp_rf_ptr ptr; /* ************************************************ */ 4648 /* START OF EXECUTION */ 4649 /* INTERNAL PROCEDURE */ 4650 /* opch_to_non_opch */ 4651 /* ************************************************ */ 4652 4653 /* Check to see whether zero should be moved to the receiving field, rather 4654* than the sending variable. */ 4655 4656 temp_sf_ptr = sf_ptr; 4657 4658 call check_zero_move (temp_sf_ptr, rf_ptr); 4659 4660 if temp_sf_ptr ^= sf_ptr /* Move zero, instead of the sending variable. */ 4661 then call num_to_num (temp_sf_ptr, rf_ptr); 4662 4663 else do; /* Move the overpunch sign data to the receiving field. */ 4664 4665 if (rf_ptr -> data_name.display = "0"b /* NOT display */ 4666 | rf_ptr -> data_name.sign_type ^= "011"b /* NOT trailing separate sign */) 4667 then do; /* Must build a temporary, unpacked decimal, trailing 4668* separate sign data item, and move the overpunch sign data into it. */ 4669 4670 /* NOTE: The temporary is the length of the receiving field. */ 4671 4672 call cobol_alloc$stack (rf_ptr -> data_name.places_left + rf_ptr -> data_name.places_right 4673 + 1, 0, char_offset); 4674 4675 temp_rf_ptr = null (); 4676 4677 call cobol_make_type9$decimal_9bit (temp_rf_ptr, 1000 /* stack */, fixed (char_offset, 24), 4678 fixed (rf_ptr -> data_name.places_left, 17), 4679 fixed (rf_ptr -> data_name.places_right, 17)); 4680 4681 /* Change sign type in the temporary to trailing separate. */ 4682 4683 temp_rf_ptr -> data_name.sign_type = "011"b; 4684 4685 end; /* Must build a temporary, unpacked decimal, trailing separate sign data item. */ 4686 4687 else temp_rf_ptr = rf_ptr; 4688 4689 4690 call cobol_opch_op_call (sf_ptr, temp_rf_ptr); 4691 4692 4693 if temp_rf_ptr ^= rf_ptr 4694 then call num_to_num (temp_rf_ptr, rf_ptr); 4695 4696 end; /* Move the overpunch sign data to the receiving field. */ 4697 4698 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4699 4700 end opch_to_non_opch; 4701 4702 /* { */ 4703 check_zero_move: 4704 proc (sf_ptr, rf_ptr); 4705 /***..... dcl LOCAL_NAME char (15) int static init ("CHECK_ZERO_MOVE");/**/ 4706 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ 4707 4708 /* 4709* This internal procedure determines whether any part of a sending 4710* variable will fit into a receiving variable, based on the places 4711* to the left and right of the decimal point contained in the data 4712* name tokens. If no part of the sending variable will fit into the receiving 4713* field, then a representation of a constant equal to zero 4714* is allocated, a data name token is created for the constant, 4715* and the parameter sf_ptr is set to the token for the zero 4716* constant. 4717**/ 4718 4719 /* DECLARATION OF THE PARAMETERS */ 4720 4721 dcl sf_ptr ptr; 4722 dcl rf_ptr ptr; 4723 4724 /* DECLARATION OF INTERNAL STATIC DATA */ 4725 4726 dcl bin_zero fixed bin (35) int static init (0); 4727 4728 dcl dec_zero char (2) int static init ("0+"); 4729 4730 /* DECLARATIONS OF INTERNAL VARIABLES */ 4731 4732 dcl const_ptr ptr; 4733 dcl const_offset fixed bin (24); 4734 dcl bin_zero_const char (4) based (const_ptr); 4735 dcl dec_zero_const char (2) based (const_ptr); 4736 dcl const_length fixed bin; 4737 dcl temp_ptr ptr; 4738 4739 /* ****************************************** */ 4740 /* START OF EXECUTION */ 4741 /* check_zero_move */ 4742 /* ************************************************ */ 4743 4744 if (rf_ptr -> data_name.places_left + sf_ptr -> data_name.places_right) <= 0 4745 | (rf_ptr -> data_name.places_right + sf_ptr -> data_name.places_left) <= 0 4746 then do; /* Move zero to the receiving field, insstead of the source variable. */ 4747 4748 if (rf_ptr -> data_name.bin_18 | rf_ptr -> data_name.bin_36) 4749 then do; /* Receiving is fixed binary. Allocate a fixed binary zero constant. */ 4750 4751 const_ptr = addr (bin_zero); 4752 4753 if rf_ptr -> data_name.bin_18 4754 then const_length = 2; 4755 else const_length = 4; 4756 4757 call cobol_pool$search_op (substr (bin_zero_const, 1, const_length), 0, const_offset, in_op) 4758 ; 4759 4760 if in_op = 0 4761 then temp = 3000; 4762 else temp = 3; 4763 4764 temp_ptr = null (); 4765 4766 if rf_ptr -> data_name.bin_18 4767 then call cobol_make_type9$short_bin (temp_ptr, temp, fixed (const_offset, 17)); 4768 4769 4770 else call cobol_make_type9$long_bin (temp_ptr, temp, fixed (const_offset, 17)); 4771 4772 sf_ptr = temp_ptr; 4773 4774 end; /* Receiving is fixed binary. Allocate a fixed binary zero constant. */ 4775 4776 else do; /* Allocate a decimal, separate trailing sign plus zero constant. */ 4777 4778 const_ptr = addr (dec_zero); 4779 4780 call cobol_pool$search_op (dec_zero_const, 0, const_offset, in_op); 4781 4782 if in_op = 0 4783 then temp = 3000; 4784 else temp = 3; 4785 4786 /* Make a data name token for the constant. */ 4787 4788 temp_ptr = null (); 4789 4790 call cobol_make_type9$decimal_9bit (temp_ptr, temp, const_offset, 4791 fixed (rf_ptr -> data_name.places_left, 17), 1 - rf_ptr -> data_name.places_left); 4792 4793 /* Change the sign type to trailing separate. */ 4794 4795 temp_ptr -> data_name.sign_type = "011"b; 4796 sf_ptr = temp_ptr; 4797 4798 end; /* Allocate a decimal, separate trailing sign, plus zero constant. */ 4799 4800 end; /* Move zero to the receiving field, instead of the source variable. */ 4801 4802 /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ 4803 4804 end check_zero_move; 4805 4806 4807 /*[4.4-2]*/ 4808 4809 declare (SF_dn, RF_dn) char (144); 4810 4811 4812 type_13_to_9: 4813 proc (p, q); 4814 4815 /* convert type 13 token to type 9 token */ 4816 4817 declare (p, q) ptr, 4818 length fixed bin, 4819 dn bit (1296) based (q); 4820 4821 if p -> cdtoken.options.input 4822 then length = 87; 4823 else length = 10 + 13 * p -> cdtoken.mdest; 4824 4825 dn = "0"b; 4826 4827 q -> data_name.size = 112 + p -> cdtoken.name_size; 4828 q -> data_name.line = p -> cdtoken.line; 4829 q -> data_name.column = p -> data_name.column; 4830 q -> data_name.type = 9; 4831 4832 q -> data_name.item_length = length; 4833 q -> data_name.places_left = length; 4834 q -> data_name.places_right = 0; 4835 4836 q -> data_name.communication_section = "1"b; 4837 q -> data_name.level_01 = "1"b; 4838 q -> data_name.non_elementary = "1"b; 4839 q -> data_name.alphanum = "1"b; 4840 4841 q -> data_name.seg_num = p -> cdtoken.cd_seg; 4842 q -> data_name.offset = p -> cdtoken.cd_off; 4843 4844 length = p -> cdtoken.name_size; 4845 4846 q -> data_name.name_size = length; 4847 substr (q -> data_name.name, 1, length) = substr (p -> cdtoken.name, 1, length); 4848 4849 p = q; 4850 4851 end; 4852 4853 /*[4.4-2]*/ 4854 4855 /* INCLUDE FILES USED BY THIS PROCEDURE */ 4856 1 1 1 2 /* BEGIN INCLUDE FILE ... cobol_in_token.incl.pl1 */ 1 3 1 4 /* Last modified August 22, 1974 by AEG */ 1 5 1 6 1 7 declare in_token_ptr ptr; 1 8 1 9 declare 1 in_token aligned based(in_token_ptr), 1 10 2 n fixed bin aligned, 1 11 2 code fixed bin aligned, 1 12 2 token_ptr(0 refer(in_token.n)) ptr aligned; 1 13 1 14 1 15 /* END INCLUDE FILE ... cobol_in_token.incl.pl1 */ 1 16 4857 2 1 2 2 /* BEGIN INCLUDE FILE ... cobol_type40.incl.pl1 */ 2 3 /* Last modified on 11/19/76 by ORN */ 2 4 2 5 /* 2 6*A type 40 token is entered into the name table by the IDED syntax. 2 7*This token contains the information for the alphabet name. 2 8**/ 2 9 2 10 dcl alpha_name_ptr ptr; 2 11 2 12 /* BEGIN DECLARATION OF TYPE40 (ALPHABET NAME) TOKEN */ 2 13 dcl 1 alphabet_name based (alpha_name_ptr), 3 1 3 2 /* begin include file ... cobol_TYPE40.incl.pl1 */ 3 3 /* Last modified on 11/17/76 by ORN */ 3 4 3 5 /* header */ 3 6 2 size fixed bin, 3 7 2 line fixed bin, 3 8 2 column fixed bin, 3 9 2 type fixed bin, 3 10 /* body */ 3 11 2 string_ptr ptr, 3 12 2 prev_rec ptr, 3 13 2 info, 3 14 3 repl bit(8), 3 15 3 one_one bit(1), 3 16 3 onto bit(1), 3 17 2 hival_char char(1), 3 18 2 loval_char char(1), 3 19 2 iw_key fixed bin, 3 20 2 def_line fixed bin, 3 21 2 char_size fixed bin, 3 22 2 hi_value char(1), 3 23 2 segno fixed bin, 3 24 2 offset fixed bin, 3 25 2 dn_offset fixed bin, 3 26 2 table char(512), 3 27 2 name_size fixed bin, 3 28 2 name char(0 refer(alphabet_name.name_size)); 3 29 3 30 /* end include file ... cobol_TYPE40.incl.pl1 */ 3 31 2 14 2 15 /* END DECLARATION OF TYPE40 (ALPHABET NAME) TOKEN */ 2 16 2 17 /* END INCLUDE FILE ... cobol_type40.incl.pl1 */ 2 18 4858 4 1 4 2 /* BEGIN INCLUDE FILE ... cobol_type1.incl.pl1 */ 4 3 /* Last modified on 11/19/76 by ORN */ 4 4 4 5 /* 4 6*A reserved word token is created in the minpral files for each occurrence 4 7*of a reserved word in the source program. The value of the key field 4 8*indicates the specific reserved word which a type 1 token represents. 4 9**/ 4 10 4 11 dcl rw_ptr ptr; 4 12 4 13 /* BEGIN DECLARATION OF TYPE1 (RESERVED WORD) TOKEN */ 4 14 dcl 1 reserved_word based (rw_ptr), 5 1 5 2 /* begin include file ... cobol_TYPE1.incl.pl1 */ 5 3 /* Last modified on 11/17/76 by ORN */ 5 4 /* Last modified on 12/28/76 by FCH */ 5 5 /* Last modified on 12/16/80 by FCH */ 5 6 5 7 /* header */ 5 8 2 size fixed bin, 5 9 2 line fixed bin, 5 10 2 column fixed bin, 5 11 2 type fixed bin, 5 12 /* body */ 5 13 2 key fixed bin, 5 14 /* procedure division class bits */ 5 15 2 verb bit (1), 5 16 2 arith_op bit (1), 5 17 2 figcon bit (1), 5 18 2 terminator bit (1), 5 19 2 end_dec bit (1), 5 20 2 rel_op bit (1), 5 21 2 imper_verb bit (1), 5 22 2 end_cobol bit (1), 5 23 /* data division class bits */ 5 24 2 section_header bit (1), 5 25 2 fs_ind bit (1), 5 26 2 fd_clause bit (1), 5 27 2 dd_clause bit (1), 5 28 2 cd_input bit (1), 5 29 2 cd_output bit (1), 5 30 2 cset_name bit (1), 5 31 2 ss_division bit (1), 5 32 2 repl_jump_ind bit (4), 5 33 2 ided_recovery bit (1), 5 34 2 report_writer bit (5), 5 35 2 ss_desc_entry bit (1), 5 36 2 jump_index fixed bin, 5 37 2 length fixed bin, 5 38 2 name char(0 refer(reserved_word.length)); 5 39 5 40 5 41 5 42 /* end include file ... cobol_TYPE1.incl.pl1 */ 5 43 4 15 4 16 /* END DECLARATION OF TYPE1 (RESERVED WORD) TOKEN */ 4 17 4 18 /* END INCLUDE FILE ... cobol_type1.incl.pl1 */ 4 19 4859 6 1 6 2 /* BEGIN INCLUDE FILE ... cobol_type2.incl.pl1 */ 6 3 /* Last modified on 11/19/76 by ORN */ 6 4 6 5 /* 6 6*A type 2 numeric literal token is entered into the minpral file by the 6 7*lexical analysis phase for each numeric literal encountered in the source 6 8*program. 6 9**/ 6 10 6 11 dcl nlit_ptr ptr; 6 12 6 13 /* BEGIN DECLARATION OF TYPE2 (NUMERIC LITERAL) TOKEN */ 6 14 dcl 1 numeric_lit based (nlit_ptr), 7 1 7 2 /* begin include file ... cobol_TYPE2.incl.pl1 */ 7 3 /* Last modified on 12/28/76 by FCH */ 7 4 7 5 /* header */ 7 6 2 size fixed bin, 7 7 2 line fixed bin, 7 8 2 column fixed bin, 7 9 2 type fixed bin, 7 10 /* body */ 7 11 2 integral bit(1), 7 12 2 floating bit(1), 7 13 2 seg_range bit(1), 7 14 2 filler1 bit(4), 7 15 2 subscript bit(1), 7 16 2 sign char(1), 7 17 2 exp_sign char(1), 7 18 2 exp_places fixed bin, 7 19 2 places_left fixed bin, 7 20 2 places_right fixed bin, 7 21 2 places fixed bin, 7 22 2 literal char(0 refer(numeric_lit.places)); 7 23 7 24 7 25 7 26 /* end include file ... cobol_TYPE2.incl.pl1 */ 7 27 6 15 6 16 /* END DECLARATION OF TYPE2 (NUMERIC LITERAL) TOKEN */ 6 17 6 18 /* END INCLUDE FILE ... cobol_type2.incl.pl1 */ 6 19 4860 8 1 8 2 /* BEGIN INCLUDE FILE ... cobol_type3.incl.pl1 */ 8 3 /* Last modified on 11/19/76 by ORN */ 8 4 8 5 /* 8 6*A type 3 alphanumeric literal token is entered into the minpral file by the 8 7*lexical analysis phase for each alphanumeric literal encountered in the 8 8*source program. 8 9**/ 8 10 8 11 dcl alit_ptr ptr; 8 12 8 13 /* BEGIN DECLARATION OR TYPE3 (ALPHANUMERIC LITERAL) TOKEN */ 8 14 dcl 1 alphanum_lit based (alit_ptr), 9 1 9 2 /* begin include file ... cobol_TYPE3.incl.pl1 */ 9 3 /* Last modified on 11/17/76 by ORN */ 9 4 /* Last modified on 12/28/76 by FCH */ 9 5 9 6 /* header */ 9 7 2 size fixed bin, 9 8 2 line fixed bin, 9 9 2 column fixed bin, 9 10 2 type fixed bin, 9 11 /* body */ 9 12 2 lit_type bit (1), 9 13 2 all_lit bit (1), 9 14 2 filler1 bit (6), 9 15 2 lit_size fixed bin, 9 16 2 string char(0 refer(alphanum_lit.lit_size)); 9 17 9 18 9 19 9 20 /* end include file ... cobol_TYPE3.incl.pl1 */ 9 21 8 15 8 16 /* END DECLARATION OF TYPE3 (ALPHANUMERIC LITERAL) TOKEN */ 8 17 8 18 /* END INCLUDE FILE ... cobol_type3.incl.pl1 */ 8 19 4861 10 1 10 2 /* BEGIN INCLUDE FILE ... cobol_type9.incl.pl1 */ 10 3 /* Last modified on 11/19/76 by ORN */ 10 4 10 5 /* 10 6*A type 9 data name token is entered into the name table by the data 10 7*division syntax phase for each data name described in the data division. 10 8*The replacement phase subsequently replaces type 8 user word references 10 9*to data names in the procedure division minpral file with the corresponding 10 10*type 9 tokens from the name table. 10 11**/ 10 12 10 13 /* dcl dn_ptr ptr; */ 10 14 10 15 /* BEGIN DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 10 16 dcl 1 data_name based (dn_ptr), 11 1 11 2 /* begin include file ... cobol_TYPE9.incl.pl1 */ 11 3 /* Last modified on 06/19/77 by ORN */ 11 4 /* Last modified on 12/28/76 by FCH */ 11 5 11 6 /* header */ 11 7 2 size fixed bin, 11 8 2 line fixed bin, 11 9 2 column fixed bin, 11 10 2 type fixed bin, 11 11 /* body */ 11 12 2 string_ptr ptr, 11 13 2 prev_rec ptr, 11 14 2 searched bit (1), 11 15 2 duplicate bit (1), 11 16 2 saved bit (1), 11 17 2 debug_ind bit (1), 11 18 2 filler2 bit (3), 11 19 2 used_as_sub bit (1), 11 20 2 def_line fixed bin, 11 21 2 level fixed bin, 11 22 2 linkage fixed bin, 11 23 2 file_num fixed bin, 11 24 2 size_rtn fixed bin, 11 25 2 item_length fixed bin(24), 11 26 2 places_left fixed bin, 11 27 2 places_right fixed bin, 11 28 /* description */ 11 29 2 file_section bit (1), 11 30 2 working_storage bit (1), 11 31 2 constant_section bit (1), 11 32 2 linkage_section bit (1), 11 33 2 communication_section bit (1), 11 34 2 report_section bit (1), 11 35 2 level_77 bit (1), 11 36 2 level_01 bit (1), 11 37 2 non_elementary bit (1), 11 38 2 elementary bit (1), 11 39 2 filler_item bit (1), 11 40 2 s_of_rdf bit (1), 11 41 2 o_of_rdf bit (1), 11 42 2 bin_18 bit (1), 11 43 2 bin_36 bit (1), 11 44 2 pic_has_l bit (1), 11 45 2 pic_is_do bit (1), 11 46 2 numeric bit (1), 11 47 2 numeric_edited bit (1), 11 48 2 alphanum bit (1), 11 49 2 alphanum_edited bit (1), 11 50 2 alphabetic bit (1), 11 51 2 alphabetic_edited bit (1), 11 52 2 pic_has_p bit (1), 11 53 2 pic_has_ast bit (1), 11 54 2 item_signed bit(1), 11 55 2 sign_separate bit (1), 11 56 2 display bit (1), 11 57 2 comp bit (1), 11 58 2 ascii_packed_dec_h bit (1), /* as of 8/16/76 this field used for comp8. */ 11 59 2 ascii_packed_dec bit (1), 11 60 2 ebcdic_packed_dec bit (1), 11 61 2 bin_16 bit (1), 11 62 2 bin_32 bit (1), 11 63 2 usage_index bit (1), 11 64 2 just_right bit (1), 11 65 2 compare_argument bit (1), 11 66 2 sync bit (1), 11 67 2 temporary bit (1), 11 68 2 bwz bit (1), 11 69 2 variable_length bit (1), 11 70 2 subscripted bit (1), 11 71 2 occurs_do bit (1), 11 72 2 key_a bit (1), 11 73 2 key_d bit (1), 11 74 2 indexed_by bit (1), 11 75 2 value_numeric bit (1), 11 76 2 value_non_numeric bit (1), 11 77 2 value_signed bit (1), 11 78 2 sign_type bit (3), 11 79 2 pic_integer bit (1), 11 80 2 ast_when_zero bit (1), 11 81 2 label_record bit (1), 11 82 2 sign_clause_occurred bit (1), 11 83 2 okey_dn bit (1), 11 84 2 subject_of_keyis bit (1), 11 85 2 exp_redefining bit (1), 11 86 2 sync_in_rec bit (1), 11 87 2 rounded bit (1), 11 88 2 ad_bit bit (1), 11 89 2 debug_all bit (1), 11 90 2 overlap bit (1), 11 91 2 sum_counter bit (1), 11 92 2 exp_occurs bit (1), 11 93 2 linage_counter bit (1), 11 94 2 rnm_01 bit (1), 11 95 2 aligned bit (1), 11 96 2 not_user_writable bit (1), 11 97 2 database_key bit (1), 11 98 2 database_data_item bit (1), 11 99 2 seg_num fixed bin, 11 100 2 offset fixed bin(24), 11 101 2 initial_ptr fixed bin, 11 102 2 edit_ptr fixed bin, 11 103 2 occurs_ptr fixed bin, 11 104 2 do_rec char(5), 11 105 2 bitt bit (1), 11 106 2 byte bit (1), 11 107 2 half_word bit (1), 11 108 2 word bit (1), 11 109 2 double_word bit (1), 11 110 2 half_byte bit (1), 11 111 2 filler5 bit (1), 11 112 2 bit_offset bit (4), 11 113 2 son_cnt bit (16), 11 114 2 max_red_size fixed bin(24), 11 115 2 name_size fixed bin, 11 116 2 name char(0 refer(data_name.name_size)); 11 117 11 118 11 119 11 120 /* end include file ... cobol_TYPE9.incl.pl1 */ 11 121 10 17 10 18 /* END DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 10 19 10 20 /* END INCLUDE FILE ... cobol_type9.incl.pl1 */ 10 21 4862 4863 4864 /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ 4865 /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ 4866 4867 /***..... dcl Trace_Bit bit(1) static external;/**/ 4868 /***..... dcl Trace_Lev fixed bin static external;/**/ 4869 /***..... dcl Trace_Line char(36) static external;/**/ 4870 /***..... dcl ioa_ entry options(variable); /**/ 4871 /***..... dcl MY_NAME char (14) int static init ("COBOL_MOVE_GEN");/**/ 4872 4873 declare 1 cdtoken based (dn_ptr), 12 1 12 2 /* begin include file ... cobol_TYPE13.incl.pl1 12 3*/* Last modified on 11/18/76 by ORN */ 12 4 12 5 /* header */ 12 6 2 size fixed bin, 12 7 2 line fixed bin, 12 8 2 column fixed bin, 12 9 2 type fixed bin, /* cd = 13 */ 12 10 /* body */ 12 11 2 string_ptr ptr, 12 12 2 prev_rec ptr, 12 13 2 info, 12 14 3 searched bit(1), 12 15 3 duplicate bit(1), 12 16 3 filler1 bit(6), 12 17 2 options, 12 18 3 input bit(1), 12 19 3 output bit(1), 12 20 3 initial bit(1), 12 21 2 def_line fixed bin, 12 22 2 cd_num fixed bin, 12 23 2 cd_seg fixed bin, 12 24 2 cd_off fixed bin(24), 12 25 2 max_redef fixed bin, 12 26 2 mdest fixed bin, 12 27 2 name_size fixed bin, 12 28 2 name char(0 refer(cdtoken.name_size)); 12 29 12 30 /* end include file ... cobol_TYPE13.incl.pl1 */ 12 31 4874 4875 13 1 13 2 /* BEGIN INCLUDE FILE ... cobol_type19.incl.pl1 */ 13 3 /* last modified on 11/19/76 by ORN */ 13 4 13 5 /* 13 6*A type 19 end of statement token is created in the procedure division 13 7*minpral file at the end of each minpral statement generated by the 13 8*procedure division syntax phase. A minpral statement may be a complete or 13 9*partial source language statement. A type 19 token contains information 13 10*describing the statement which it delimits. 13 11**/ 13 12 13 13 dcl eos_ptr ptr; 13 14 13 15 /* BEGIN DECLARATION OF TYPE19 (END STATEMENT) TOKEN */ 13 16 dcl 1 end_stmt based (eos_ptr), 14 1 14 2 /* begin include file ... cobol_TYPE19.incl.pl1 */ 14 3 /* Last modified on 11/17/76 by ORN */ 14 4 14 5 /* header */ 14 6 2 size fixed bin, 14 7 2 line fixed bin, 14 8 2 column fixed bin, 14 9 2 type fixed bin, 14 10 /* body */ 14 11 2 verb fixed bin, 14 12 2 e fixed bin, 14 13 2 h fixed bin, 14 14 2 i fixed bin, 14 15 2 j fixed bin, 14 16 2 a bit (3), 14 17 2 b bit (1), 14 18 2 c bit (1), 14 19 2 d bit (2), 14 20 2 f bit (2), 14 21 2 g bit (2), 14 22 2 k bit (5), 14 23 2 always_an bit (1); 14 24 14 25 /* end include file ... cobol_TYPE19.incl.pl1 */ 14 26 13 17 13 18 /* END DECLARATION OF TYPE19 (END STATEMENT) TOKEN */ 13 19 13 20 /* 13 21*FIELD CONTENTS 13 22* 13 23*size The total size in bytes of this end of statement token. 13 24*line 0 13 25*column 0 13 26*type 19 13 27*verb A value indicating the verb in this statement 13 28* 1 = accept 13 29* 2 = add 13 30* 3 = on size error 13 31* 4 = alter 13 32* 5 = call 13 33* 7 = cancel 13 34* 8 = close 13 35* 9 = divide 13 36* 10 = multiply 13 37* 11 = subtract 13 38* 12 = exit 13 39* 14 = go 13 40* 15 = merge 13 41* 16 = initiate 13 42* 17 = inspect 13 43* 18 = move 13 44* 19 = open 13 45* 20 = perform 13 46* 21 = read 13 47* 23 = receive 13 48* 24 = release 13 49* 25 = return 13 50* 26 = search 13 51* 27 = rewrite 13 52* 29 = seek 13 53* 30 = send 13 54* 31 = set 13 55* 33 = stop 13 56* 34 = string 13 57* 35 = suspend 13 58* 36 = terminate 13 59* 37 = unstring 13 60* 38 = write 13 61* 39 = use 13 62* 40 = compute 13 63* 41 = disable 13 64* 42 = display 13 65* 43 = enable 13 66* 45 = generate 13 67* 46 = hold 13 68* 48 = process 13 69* 49 = sort 13 70* 52 = procedure 13 71* 53 = declaratives 13 72* 54 = section name 13 73* 55 = paragraph name 13 74* 98 = end 13 75*e,h,i,j The significance of these fields differs with each 13 76* statement. These fields are normally used as counters. 13 77*a,b,c,d,f,g,k The significance of these fields differs with each 13 78* statement. These fields are normally used as indicators. 13 79**/ 13 80 13 81 /* END INCLUDE FILE ... cobol_type19.incl.pl1 */ 13 82 4876 15 1 15 2 /* BEGIN INCLUDE FILE ... cobol_edit_ext.incl.pl1 */ 15 3 /* <<< LAST MODIFIED ON 08-16-74 >>> */ 15 4 15 5 /* 15 6*An edit extension is included in a type 9 data name token when the data 15 7*item is described with a picture clause defining the item as alphanumeric 15 8*edited or numeric edited. 15 9**/ 15 10 15 11 /* ***STRUCTURE SIZE INFORMATION*** */ 15 12 /* THE SIZE OF THIS STRUCTURE IN BYTES, (EXCLUDING VARIABLE 15 13* LENGTH ENTITIES), FOR EACH HARDWARE IMPLEMENTATION IS: 15 14* 15 15* HARDWARE | SIZE (BYTES) 15 16* --------------------------------- 15 17* 6180 | 20 15 18* P7 | 10 15 19* --------------------------------- 15 20**/ 15 21 15 22 /* THE EDIT EXTENSION STRUCTURE */ 15 23 15 24 dcl edit_ptr ptr; 15 25 15 26 dcl 1 editor based (edit_ptr), 15 27 2 fixed_insert fixed bin (15), 15 28 2 float_insert fixed bin (15), 15 29 2 start_suppress fixed bin (15), 15 30 2 max_suppress fixed bin (15), 15 31 2 ecm_size fixed bin (15), 15 32 2 ecm char (256); 15 33 15 34 15 35 /* 15 36* 15 37*FIELD CONTENTS 15 38* 15 39*fixed_insert Describes the fixed insertion required for this item 15 40* 0 = no fixed insertion 15 41* 1 = replace last character of the edit control mask 15 42* with a space if the value of the sending item is 15 43* positive or zero 15 44* 2 = replace last character of the edit control mask 15 45* with "+" if the value of the sending item is 15 46* positive or zero 15 47* 3 = replace first character of the edit control mask 15 48* with a space if the value of the sending item is 15 49* positive or zero 15 50* 4 = replace first character of the edit control mask 15 51* with "+" if the value of the sending item is 15 52* positive or zero 15 53* 5 = replace last two characters of the edit control 15 54* mask with spaces if the value of the sending item 15 55* is positive or zero 15 56*float_insert Describes the floating insertion required for this item 15 57* 0 = no floating insertion 15 58* 1 = float currency symbol 15 59* 2 = float "+" 15 60* 3 = float "-" 15 61*start_suppress Number of leading characters to skip before starting 15 62* zero suppression. 15 63*max_suppress Maximum number of characters to be zero suppressed. 15 64*ecm_size Number of characters in the edit control mask. 15 65*ecm Edit control mask for this data item, based on the NPL 15 66* Central Processor specification. 15 67**/ 15 68 15 69 /* END INCLUDE FILE ... cobol_edit_ext.incl.pl1 */ 15 70 4877 16 1 16 2 /* BEGIN INCLUDE FILE ... cobol_.incl.pl1 */ 16 3 /* last modified Feb 4, 1977 by ORN */ 16 4 16 5 /* This file defines all external data used in the generator phase of Multics Cobol */ 16 6 16 7 /* POINTERS */ 16 8 dcl cobol_$text_base_ptr ptr ext; 16 9 dcl text_base_ptr ptr defined (cobol_$text_base_ptr); 16 10 dcl cobol_$con_end_ptr ptr ext; 16 11 dcl con_end_ptr ptr defined (cobol_$con_end_ptr); 16 12 dcl cobol_$def_base_ptr ptr ext; 16 13 dcl def_base_ptr ptr defined (cobol_$def_base_ptr); 16 14 dcl cobol_$link_base_ptr ptr ext; 16 15 dcl link_base_ptr ptr defined (cobol_$link_base_ptr); 16 16 dcl cobol_$sym_base_ptr ptr ext; 16 17 dcl sym_base_ptr ptr defined (cobol_$sym_base_ptr); 16 18 dcl cobol_$reloc_text_base_ptr ptr ext; 16 19 dcl reloc_text_base_ptr ptr defined (cobol_$reloc_text_base_ptr); 16 20 dcl cobol_$reloc_def_base_ptr ptr ext; 16 21 dcl reloc_def_base_ptr ptr defined (cobol_$reloc_def_base_ptr); 16 22 dcl cobol_$reloc_link_base_ptr ptr ext; 16 23 dcl reloc_link_base_ptr ptr defined (cobol_$reloc_link_base_ptr); 16 24 dcl cobol_$reloc_sym_base_ptr ptr ext; 16 25 dcl reloc_sym_base_ptr ptr defined (cobol_$reloc_sym_base_ptr); 16 26 dcl cobol_$reloc_work_base_ptr ptr ext; 16 27 dcl reloc_work_base_ptr ptr defined (cobol_$reloc_work_base_ptr); 16 28 dcl cobol_$pd_map_ptr ptr ext; 16 29 dcl pd_map_ptr ptr defined (cobol_$pd_map_ptr); 16 30 dcl cobol_$fixup_ptr ptr ext; 16 31 dcl fixup_ptr ptr defined (cobol_$fixup_ptr); 16 32 dcl cobol_$initval_base_ptr ptr ext; 16 33 dcl initval_base_ptr ptr defined (cobol_$initval_base_ptr); 16 34 dcl cobol_$initval_file_ptr ptr ext; 16 35 dcl initval_file_ptr ptr defined (cobol_$initval_file_ptr); 16 36 dcl cobol_$perform_list_ptr ptr ext; 16 37 dcl perform_list_ptr ptr defined (cobol_$perform_list_ptr); 16 38 dcl cobol_$alter_list_ptr ptr ext; 16 39 dcl alter_list_ptr ptr defined (cobol_$alter_list_ptr); 16 40 dcl cobol_$seg_init_list_ptr ptr ext; 16 41 dcl seg_init_list_ptr ptr defined (cobol_$seg_init_list_ptr); 16 42 dcl cobol_$temp_token_area_ptr ptr ext; 16 43 dcl temp_token_area_ptr ptr defined (cobol_$temp_token_area_ptr); 16 44 dcl cobol_$temp_token_ptr ptr ext; 16 45 dcl temp_token_ptr ptr defined (cobol_$temp_token_ptr); 16 46 dcl cobol_$token_block1_ptr ptr ext; 16 47 dcl token_block1_ptr ptr defined (cobol_$token_block1_ptr); 16 48 dcl cobol_$token_block2_ptr ptr ext; 16 49 dcl token_block2_ptr ptr defined (cobol_$token_block2_ptr); 16 50 dcl cobol_$minpral5_ptr ptr ext; 16 51 dcl minpral5_ptr ptr defined (cobol_$minpral5_ptr); 16 52 dcl cobol_$tag_table_ptr ptr ext; 16 53 dcl tag_table_ptr ptr defined (cobol_$tag_table_ptr); 16 54 dcl cobol_$map_data_ptr ptr ext; 16 55 dcl map_data_ptr ptr defined (cobol_$map_data_ptr); 16 56 dcl cobol_$ptr_status_ptr ptr ext; 16 57 dcl ptr_status_ptr ptr defined (cobol_$ptr_status_ptr); 16 58 dcl cobol_$reg_status_ptr ptr ext; 16 59 dcl reg_status_ptr ptr defined (cobol_$reg_status_ptr); 16 60 dcl cobol_$misc_base_ptr ptr ext; 16 61 dcl misc_base_ptr ptr defined (cobol_$misc_base_ptr); 16 62 dcl cobol_$misc_end_ptr ptr ext; 16 63 dcl misc_end_ptr ptr defined (cobol_$misc_end_ptr); 16 64 dcl cobol_$list_ptr ptr ext; 16 65 dcl list_ptr ptr defined (cobol_$list_ptr); 16 66 dcl cobol_$allo1_ptr ptr ext; 16 67 dcl allo1_ptr ptr defined (cobol_$allo1_ptr); 16 68 dcl cobol_$eln_ptr ptr ext; 16 69 dcl eln_ptr ptr defined (cobol_$eln_ptr); 16 70 dcl cobol_$diag_ptr ptr ext; 16 71 dcl diag_ptr ptr defined (cobol_$diag_ptr); 16 72 dcl cobol_$xref_token_ptr ptr ext; 16 73 dcl xref_token_ptr ptr defined (cobol_$xref_token_ptr); 16 74 dcl cobol_$xref_chain_ptr ptr ext; 16 75 dcl xref_chain_ptr ptr defined (cobol_$xref_chain_ptr); 16 76 dcl cobol_$statement_info_ptr ptr ext; 16 77 dcl statement_info_ptr ptr defined (cobol_$statement_info_ptr); 16 78 dcl cobol_$reswd_ptr ptr ext; 16 79 dcl reswd_ptr ptr defined (cobol_$reswd_ptr); 16 80 dcl cobol_$op_con_ptr ptr ext; 16 81 dcl op_con_ptr ptr defined (cobol_$op_con_ptr); 16 82 dcl cobol_$ntbuf_ptr ptr ext; 16 83 dcl ntbuf_ptr ptr defined (cobol_$ntbuf_ptr); 16 84 dcl cobol_$main_pcs_ptr ptr ext; 16 85 dcl main_pcs_ptr ptr defined (cobol_$main_pcs_ptr); 16 86 dcl cobol_$include_info_ptr ptr ext; 16 87 dcl include_info_ptr ptr defined (cobol_$include_info_ptr); 16 88 16 89 /* FIXED BIN */ 16 90 dcl cobol_$text_wd_off fixed bin ext; 16 91 dcl text_wd_off fixed bin defined (cobol_$text_wd_off); 16 92 dcl cobol_$con_wd_off fixed bin ext; 16 93 dcl con_wd_off fixed bin defined (cobol_$con_wd_off); 16 94 dcl cobol_$def_wd_off fixed bin ext; 16 95 dcl def_wd_off fixed bin defined (cobol_$def_wd_off); 16 96 dcl cobol_$def_max fixed bin ext; 16 97 dcl def_max fixed bin defined (cobol_$def_max); 16 98 dcl cobol_$link_wd_off fixed bin ext; 16 99 dcl link_wd_off fixed bin defined (cobol_$link_wd_off); 16 100 dcl cobol_$link_max fixed bin ext; 16 101 dcl link_max fixed bin defined (cobol_$link_max); 16 102 dcl cobol_$sym_wd_off fixed bin ext; 16 103 dcl sym_wd_off fixed bin defined (cobol_$sym_wd_off); 16 104 dcl cobol_$sym_max fixed bin ext; 16 105 dcl sym_max fixed bin defined (cobol_$sym_max); 16 106 dcl cobol_$reloc_text_max fixed bin(24) ext; 16 107 dcl reloc_text_max fixed bin(24) defined (cobol_$reloc_text_max); 16 108 dcl cobol_$reloc_def_max fixed bin(24) ext; 16 109 dcl reloc_def_max fixed bin(24) defined (cobol_$reloc_def_max); 16 110 dcl cobol_$reloc_link_max fixed bin(24) ext; 16 111 dcl reloc_link_max fixed bin(24) defined (cobol_$reloc_link_max); 16 112 dcl cobol_$reloc_sym_max fixed bin(24) ext; 16 113 dcl reloc_sym_max fixed bin(24) defined (cobol_$reloc_sym_max); 16 114 dcl cobol_$reloc_work_max fixed bin(24) ext; 16 115 dcl reloc_work_max fixed bin(24) defined (cobol_$reloc_work_max); 16 116 dcl cobol_$pd_map_index fixed bin ext; 16 117 dcl pd_map_index fixed bin defined (cobol_$pd_map_index); 16 118 dcl cobol_$cobol_data_wd_off fixed bin ext; 16 119 dcl cobol_data_wd_off fixed bin defined (cobol_$cobol_data_wd_off); 16 120 dcl cobol_$stack_off fixed bin ext; 16 121 dcl stack_off fixed bin defined (cobol_$stack_off); 16 122 dcl cobol_$max_stack_off fixed bin ext; 16 123 dcl max_stack_off fixed bin defined (cobol_$max_stack_off); 16 124 dcl cobol_$init_stack_off fixed bin ext; 16 125 dcl init_stack_off fixed bin defined (cobol_$init_stack_off); 16 126 dcl cobol_$pd_map_sw fixed bin ext; 16 127 dcl pd_map_sw fixed bin defined (cobol_$pd_map_sw); 16 128 dcl cobol_$next_tag fixed bin ext; 16 129 dcl next_tag fixed bin defined (cobol_$next_tag); 16 130 dcl cobol_$data_init_flag fixed bin ext; 16 131 dcl data_init_flag fixed bin defined (cobol_$data_init_flag); 16 132 dcl cobol_$seg_init_flag fixed bin ext; 16 133 dcl seg_init_flag fixed bin defined (cobol_$seg_init_flag); 16 134 dcl cobol_$alter_flag fixed bin ext; 16 135 dcl alter_flag fixed bin defined (cobol_$alter_flag); 16 136 dcl cobol_$sect_eop_flag fixed bin ext; 16 137 dcl sect_eop_flag fixed bin defined (cobol_$sect_eop_flag); 16 138 dcl cobol_$para_eop_flag fixed bin ext; 16 139 dcl para_eop_flag fixed bin defined (cobol_$para_eop_flag); 16 140 dcl cobol_$priority_no fixed bin ext; 16 141 dcl priority_no fixed bin defined (cobol_$priority_no); 16 142 dcl cobol_$compile_count fixed bin ext; 16 143 dcl compile_count fixed bin defined (cobol_$compile_count); 16 144 dcl cobol_$ptr_assumption_ind fixed bin ext; 16 145 dcl ptr_assumption_ind fixed bin defined (cobol_$ptr_assumption_ind); 16 146 dcl cobol_$reg_assumption_ind fixed bin ext; 16 147 dcl reg_assumption_ind fixed bin defined (cobol_$reg_assumption_ind); 16 148 dcl cobol_$perform_para_index fixed bin ext; 16 149 dcl perform_para_index fixed bin defined (cobol_$perform_para_index); 16 150 dcl cobol_$perform_sect_index fixed bin ext; 16 151 dcl perform_sect_index fixed bin defined (cobol_$perform_sect_index); 16 152 dcl cobol_$alter_index fixed bin ext; 16 153 dcl alter_index fixed bin defined (cobol_$alter_index); 16 154 dcl cobol_$list_off fixed bin ext; 16 155 dcl list_off fixed bin defined (cobol_$list_off); 16 156 dcl cobol_$constant_offset fixed bin ext; 16 157 dcl constant_offset fixed bin defined (cobol_$constant_offset); 16 158 dcl cobol_$misc_max fixed bin ext; 16 159 dcl misc_max fixed bin defined (cobol_$misc_max); 16 160 dcl cobol_$pd_map_max fixed bin ext; 16 161 dcl pd_map_max fixed bin defined (cobol_$pd_map_max); 16 162 dcl cobol_$map_data_max fixed bin ext; 16 163 dcl map_data_max fixed bin defined (cobol_$map_data_max); 16 164 dcl cobol_$fixup_max fixed bin ext; 16 165 dcl fixup_max fixed bin defined (cobol_$fixup_max); 16 166 dcl cobol_$tag_table_max fixed bin ext; 16 167 dcl tag_table_max fixed bin defined (cobol_$tag_table_max); 16 168 dcl cobol_$temp_token_max fixed bin ext; 16 169 dcl temp_token_max fixed bin defined (cobol_$temp_token_max); 16 170 dcl cobol_$allo1_max fixed bin ext; 16 171 dcl allo1_max fixed bin defined (cobol_$allo1_max); 16 172 dcl cobol_$eln_max fixed bin ext; 16 173 dcl eln_max fixed bin defined (cobol_$eln_max); 16 174 dcl cobol_$debug_enable fixed bin ext; 16 175 dcl debug_enable fixed bin defined (cobol_$debug_enable); 16 176 dcl cobol_$non_source_offset fixed bin ext; 16 177 dcl non_source_offset fixed bin defined (cobol_$non_source_offset); 16 178 dcl cobol_$initval_flag fixed bin ext; 16 179 dcl initval_flag fixed bin defined (cobol_$initval_flag); 16 180 dcl cobol_$date_compiled_sw fixed bin ext; 16 181 dcl date_compiled_sw fixed bin defined (cobol_$date_compiled_sw); 16 182 dcl cobol_$include_cnt fixed bin ext; 16 183 dcl include_cnt fixed bin defined (cobol_$include_cnt); 16 184 dcl cobol_$fs_charcnt fixed bin ext; 16 185 dcl fs_charcnt fixed bin defined (cobol_$fs_charcnt); 16 186 dcl cobol_$ws_charcnt fixed bin ext; 16 187 dcl ws_charcnt fixed bin defined (cobol_$ws_charcnt); 16 188 dcl cobol_$coms_charcnt fixed bin ext; 16 189 dcl coms_charcnt fixed bin defined (cobol_$coms_charcnt); 16 190 dcl cobol_$ls_charcnt fixed bin ext; 16 191 dcl ls_charcnt fixed bin defined (cobol_$ls_charcnt); 16 192 dcl cobol_$cons_charcnt fixed bin ext; 16 193 dcl cons_charcnt fixed bin defined (cobol_$cons_charcnt); 16 194 dcl cobol_$value_cnt fixed bin ext; 16 195 dcl value_cnt fixed bin defined (cobol_$value_cnt); 16 196 dcl cobol_$cd_cnt fixed bin ext; 16 197 dcl cd_cnt fixed bin defined (cobol_$cd_cnt); 16 198 dcl cobol_$fs_wdoff fixed bin ext; 16 199 dcl fs_wdoff fixed bin defined (cobol_$fs_wdoff); 16 200 dcl cobol_$ws_wdoff fixed bin ext; 16 201 dcl ws_wdoff fixed bin defined (cobol_$ws_wdoff); 16 202 dcl cobol_$coms_wdoff fixed bin ext; 16 203 dcl coms_wdoff fixed bin defined (cobol_$coms_wdoff); 16 204 16 205 /* CHARACTER */ 16 206 dcl cobol_$scratch_dir char (168) aligned ext; 16 207 dcl scratch_dir char (168) aligned defined (cobol_$scratch_dir); /* -42- */ 16 208 dcl cobol_$obj_seg_name char (32) aligned ext; 16 209 dcl obj_seg_name char (32) aligned defined (cobol_$obj_seg_name); /* -8- */ 16 210 16 211 /* BIT */ 16 212 dcl cobol_$xref_bypass bit(1) aligned ext; 16 213 dcl xref_bypass bit(1) aligned defined (cobol_$xref_bypass); /* -1- */ 16 214 dcl cobol_$same_sort_merge_proc bit(1) aligned ext; 16 215 dcl same_sort_merge_proc bit(1) aligned defined (cobol_$same_sort_merge_proc); /* -1- */ 16 216 16 217 16 218 /* END INCLUDE FILE ... cobol_incl.pl1*/ 16 219 16 220 4878 17 1 17 2 /* BEGIN INCLUDE FILE ... cobol_fixed_common.incl.pl1 */ 17 3 /* Modified on 10/27/82 by FCH, [5.1-1], cobol_cln added to save last line num, BUG543(phx13643) */ 17 4 /* Modified on 07/31/80 by FCH, [4.3-1], use_reporting field added for Report Writer */ 17 5 /* Modified on 03/30/79 by FCH, [4.1-1], -card option added */ 17 6 /* Modified on 03/30/79 by FCH, [4.0-2], -svNM option added */ 17 7 /* Modified on 03/02/79 by FCH, [4.0-1], -levNM option added */ 17 8 /* Modified by RAL on 10/13/78, [4.0-0], Added option exp from fil2. */ 17 9 /* Modified by BC on 06/20/77, descriptor added. */ 17 10 /* Modified by BC on 06/02/77, init_cd_seg, init_cd_offset added. */ 17 11 /* Modified by BC on 1/21/77, options.profile added. */ 17 12 /* Modified by FCH on 7/6/76, sysin_fno & sysout_fno deleted, accept_device & display_device added */ 17 13 /* Modified by FCH on 5/20/77, comp_level added */ 17 14 17 15 17 16 /* THE SIZE OF THIS STRUCTURE IN BYTES, (EXCLUDING VARIABLE 17 17* LENGTH ENTITIES), FOR EACH HARDWARE IMPLEMENTATION IS: 17 18* 17 19* HARDWARE | SIZE (BYTES) 17 20* --------------------------------- 17 21* 645/6180 | 464 17 22* P7 | 396 17 23* --------------------------------- 17 24* */ 17 25 17 26 dcl 1 fixed_common based ( cobol_com_ptr), 17 27 2 prog_name char (30), 17 28 2 compiler_rev_no char (25), 17 29 2 phase_name char (6), 17 30 2 currency char (1), 17 31 2 fatal_no fixed bin, 17 32 2 warn_no fixed bin, 17 33 2 proc_counter fixed bin, 17 34 2 spec_tag_counter fixed bin, 17 35 2 file_count fixed bin, 17 36 2 filedescr_offsets (20) char (5), 17 37 2 perf_alter_info char (5), 17 38 2 another_perform_info char (5), 17 39 2 sort_in_info char (5), 17 40 2 odo_info char (5), 17 41 2 size_seg fixed bin, 17 42 2 size_offset fixed bin(24), 17 43 2 size_perform_info char (5), 17 44 2 rename_info char (5), 17 45 2 report_names char (5), 17 46 2 rw_buf_seg fixed bin, 17 47 2 rw_buf_offset fixed bin(24), 17 48 2 rw_buf_length fixed bin(24), 17 49 2 file_keys char (5), 17 50 2 search_keys char (5), 17 51 2 dd_seg_size fixed bin(24), 17 52 2 pd_seg_size fixed bin(24), 17 53 2 seg_limit fixed bin , 17 54 2 number_of_dd_segs fixed bin, 17 55 2 seg_info char (5), 17 56 2 number_of_ls_pointers fixed bin, 17 57 2 link_sec_seg fixed bin, 17 58 2 link_sec_offset fixed bin(24), 17 59 2 sra_clauses fixed bin, 17 60 2 fix_up_info char (5), 17 61 2 linage_info char (5), 17 62 2 first_dd_item char (5), 17 63 2 sort_out_info char (5), 17 64 2 db_info char (5), 17 65 2 realm_info char (5), 17 66 2 rc_realm_info char (5), 17 67 2 last_file_key char (5), 17 68 2 prog_coll_seq fixed bin, 17 69 2 init_cd_seg fixed bin, 17 70 2 init_cd_offset fixed bin(24), 17 71 2 input_error_exit fixed bin, 17 72 2 output_error_exit fixed bin, 17 73 2 i_o_error_exit fixed bin, 17 74 2 extend_error_exit fixed bin, 17 75 2 dummy15 fixed bin, 17 76 2 options, 17 77 3 cu bit (1), 17 78 3 st bit (1), 17 79 3 wn bit (1), 17 80 3 obs bit (1), 17 81 3 dm bit (1), 17 82 3 xrl bit (1), 17 83 3 xrn bit (1), 17 84 3 src bit (1), 17 85 3 obj bit (1), 17 86 3 exs bit (1), 17 87 3 sck bit (1), 17 88 3 rno bit (1), 17 89 3 u_l bit (1), 17 90 3 cnv bit (1), 17 91 3 cos bit (1), 17 92 3 fmt bit (1), 17 93 3 profile bit(1), 17 94 3 nw bit (1), 17 95 3 exp bit (1), /* [4.0-0] */ 17 96 3 card bit (1), /*[4.1-1]*/ 17 97 3 fil2 bit (5), 17 98 3 m_map bit (1), 17 99 3 m_bf bit (1), 17 100 3 m_fat bit (1), 17 101 3 m_wn bit (1), 17 102 3 m_obs bit(1), 17 103 3 pd bit(1), 17 104 3 oc bit(1), 17 105 2 supervisor bit (1), 17 106 2 dec_comma bit (1), 17 107 2 init_cd bit (1), 17 108 2 corr bit (1), 17 109 2 initl bit (1), 17 110 2 debug bit (1), 17 111 2 report bit (1), 17 112 2 sync_in_prog bit (1), 17 113 2 pd_section bit (1), 17 114 2 list_switch bit (1), 17 115 2 alpha_cond bit (1), 17 116 2 num_cond bit (1), 17 117 2 spec_sysin bit (1), 17 118 2 spec_sysout bit (1), 17 119 2 cpl_files bit (1), 17 120 2 obj_dec_comma bit (1), 17 121 2 default_sign_type bit (3), 17 122 2 use_debug bit(1), 17 123 2 syntax_trace bit(1), 17 124 2 comp_defaults, 17 125 3 comp bit(1), 17 126 3 comp_1 bit(1), 17 127 3 comp_2 bit(1), 17 128 3 comp_3 bit(1), 17 129 3 comp_4 bit(1), 17 130 3 comp_5 bit(1), 17 131 3 comp_6 bit(1), 17 132 3 comp_7 bit(1), 17 133 3 comp_8 bit(1), 17 134 2 disp_defaults, 17 135 3 disp bit(1), 17 136 3 disp_1 bit(1), 17 137 3 disp_2 bit(1), 17 138 3 disp_3 bit(1), 17 139 3 disp_4 bit(1), 17 140 3 disp_5 bit(1), 17 141 3 disp_6 bit(1), 17 142 3 disp_7 bit(1), 17 143 2 descriptor bit(2), 17 144 2 levsv bit(3), /*[4.0-1]*/ 17 145 2 use_reporting bit(1), /*[4.3-1]*/ 17 146 2 cd bit(1), /*[4.4-1]*/ 17 147 2 dummy17 bit(3), 17 148 2 lvl_rstr bit(32), 17 149 2 inst_rstr bit(32), 17 150 2 comp_level char(1), 17 151 2 dummy18 char(30), 17 152 2 object_sign char (1), 17 153 2 last_print_rec char (5), 17 154 2 coll_seq_info char (5), 17 155 2 sys_status_seg fixed bin, 17 156 2 sys_status_offset fixed bin(24), 17 157 2 compiler_id fixed bin, 17 158 2 date_comp_ln fixed bin, 17 159 2 compile_mode bit(36), 17 160 2 default_temp fixed bin, 17 161 2 accept_device fixed bin, 17 162 2 display_device fixed bin, 17 163 2 cobol_cln fixed bin, /*[5.1-1]*/ 17 164 2 alphabet_offset fixed bin; 17 165 17 166 17 167 17 168 /* END INCLUDE FILE ... cobol_fixed_common.incl.pl1 */ 17 169 4879 18 1 18 2 /* BEGIN INCLUDE FILE ... cobol_ext_.incl.pl1 */ 18 3 /* Last modified on 06/17/76 by ORN */ 18 4 /* Last modified on 12/28/76 by FCH */ 18 5 /* Last modified on 12/01/80 by FCH */ 18 6 18 7 /* <<< SHARED EXTERNALS INCLUDE FILE >>> */ 18 8 18 9 18 10 dcl cobol_ext_$cobol_afp ptr ext; 18 11 dcl cobol_afp ptr defined ( cobol_ext_$cobol_afp); 18 12 dcl cobol_ext_$cobol_analin_fileno ptr ext; 18 13 dcl cobol_analin_fileno ptr defined ( cobol_ext_$cobol_analin_fileno); 18 14 dcl cobol_ext_$report_first_token ptr ext; 18 15 dcl report_first_token ptr defined( cobol_ext_$report_first_token); 18 16 dcl cobol_ext_$report_last_token ptr ext; 18 17 dcl report_last_token ptr defined ( cobol_ext_$report_last_token); 18 18 dcl cobol_ext_$cobol_eltp ptr ext; 18 19 dcl cobol_eltp ptr defined ( cobol_ext_$cobol_eltp); 18 20 dcl cobol_ext_$cobol_cmfp ptr ext; 18 21 dcl cobol_cmfp ptr defined ( cobol_ext_$cobol_cmfp); 18 22 dcl cobol_ext_$cobol_com_fileno ptr ext; 18 23 dcl cobol_com_fileno ptr defined ( cobol_ext_$cobol_com_fileno); 18 24 dcl cobol_ext_$cobol_com_ptr ptr ext; 18 25 dcl cobol_com_ptr ptr defined ( cobol_ext_$cobol_com_ptr); 18 26 dcl cobol_ext_$cobol_dfp ptr ext; 18 27 dcl cobol_dfp ptr defined ( cobol_ext_$cobol_dfp); 18 28 dcl cobol_ext_$cobol_hfp ptr ext; 18 29 dcl cobol_hfp ptr defined ( cobol_ext_$cobol_hfp); 18 30 dcl cobol_ext_$cobol_m1fp ptr ext; 18 31 dcl cobol_m1fp ptr defined ( cobol_ext_$cobol_m1fp); 18 32 dcl cobol_ext_$cobol_m2fp ptr ext; 18 33 dcl cobol_m2fp ptr defined ( cobol_ext_$cobol_m2fp); 18 34 dcl cobol_ext_$cobol_min1_fileno ptr ext; 18 35 dcl cobol_min1_fileno ptr defined ( cobol_ext_$cobol_min1_fileno); 18 36 dcl cobol_ext_$cobol_min2_fileno_ptr ptr ext; 18 37 dcl cobol_min2_fileno_ptr ptr defined ( cobol_ext_$cobol_min2_fileno_ptr); 18 38 dcl cobol_ext_$cobol_name_fileno ptr ext; 18 39 dcl cobol_name_fileno ptr defined ( cobol_ext_$cobol_name_fileno); 18 40 dcl cobol_ext_$cobol_name_fileno_ptr ptr ext; 18 41 dcl cobol_name_fileno_ptr ptr defined ( cobol_ext_$cobol_name_fileno_ptr); 18 42 dcl cobol_ext_$cobol_ntfp ptr ext; 18 43 dcl cobol_ntfp ptr defined ( cobol_ext_$cobol_ntfp); 18 44 dcl cobol_ext_$cobol_pdofp ptr ext; 18 45 dcl cobol_pdofp ptr defined ( cobol_ext_$cobol_pdofp); 18 46 dcl cobol_ext_$cobol_pfp ptr ext; 18 47 dcl cobol_pfp ptr defined ( cobol_ext_$cobol_pfp); 18 48 dcl cobol_ext_$cobol_rm2fp ptr ext; 18 49 dcl cobol_rm2fp ptr defined ( cobol_ext_$cobol_rm2fp); 18 50 dcl cobol_ext_$cobol_rmin2fp ptr ext; 18 51 dcl cobol_rmin2fp ptr defined ( cobol_ext_$cobol_rmin2fp); 18 52 dcl cobol_ext_$cobol_curr_in ptr ext; 18 53 dcl cobol_curr_in ptr defined ( cobol_ext_$cobol_curr_in); 18 54 dcl cobol_ext_$cobol_curr_out ptr ext; 18 55 dcl cobol_curr_out ptr defined ( cobol_ext_$cobol_curr_out); 18 56 dcl cobol_ext_$cobol_sfp ptr ext; 18 57 dcl cobol_sfp ptr defined ( cobol_ext_$cobol_sfp); 18 58 dcl cobol_ext_$cobol_w1p ptr ext; 18 59 dcl cobol_w1p ptr defined ( cobol_ext_$cobol_w1p); 18 60 dcl cobol_ext_$cobol_w2p ptr ext; 18 61 dcl cobol_w2p ptr defined ( cobol_ext_$cobol_w2p); 18 62 dcl cobol_ext_$cobol_w3p ptr ext; 18 63 dcl cobol_w3p ptr defined ( cobol_ext_$cobol_w3p); 18 64 dcl cobol_ext_$cobol_w5p ptr ext; 18 65 dcl cobol_w5p ptr defined ( cobol_ext_$cobol_w5p); 18 66 dcl cobol_ext_$cobol_w6p ptr ext; 18 67 dcl cobol_w6p ptr defined ( cobol_ext_$cobol_w6p); 18 68 dcl cobol_ext_$cobol_w7p ptr ext; 18 69 dcl cobol_w7p ptr defined ( cobol_ext_$cobol_w7p); 18 70 dcl cobol_ext_$cobol_x3fp ptr ext; 18 71 dcl cobol_x3fp ptr defined ( cobol_ext_$cobol_x3fp); 18 72 dcl cobol_ext_$cobol_rwdd ptr ext; 18 73 dcl cobol_rwdd ptr defined(cobol_ext_$cobol_rwdd); 18 74 dcl cobol_ext_$cobol_rwpd ptr ext; 18 75 dcl cobol_rwpd ptr defined(cobol_ext_$cobol_rwpd); 18 76 18 77 18 78 dcl cobol_ext_$cobol_fileno1 fixed bin(24)ext; 18 79 dcl cobol_fileno1 fixed bin(24)defined ( cobol_ext_$cobol_fileno1); 18 80 dcl cobol_ext_$cobol_options_len fixed bin(24)ext; 18 81 dcl cobol_options_len fixed bin(24)defined ( cobol_ext_$cobol_options_len); 18 82 dcl cobol_ext_$cobol_pdout_fileno fixed bin(24)ext; 18 83 dcl cobol_pdout_fileno fixed bin(24)defined ( cobol_ext_$cobol_pdout_fileno); 18 84 dcl cobol_ext_$cobol_print_fileno fixed bin(24)ext; 18 85 dcl cobol_print_fileno fixed bin(24)defined ( cobol_ext_$cobol_print_fileno); 18 86 dcl cobol_ext_$cobol_rmin2_fileno fixed bin(24)ext; 18 87 dcl cobol_rmin2_fileno fixed bin(24)defined ( cobol_ext_$cobol_rmin2_fileno); 18 88 dcl cobol_ext_$cobol_x1_fileno fixed bin(24)ext; 18 89 dcl cobol_x1_fileno fixed bin(24)defined ( cobol_ext_$cobol_x1_fileno); 18 90 dcl cobol_ext_$cobol_x2_fileno fixed bin(24)ext; 18 91 dcl cobol_x2_fileno fixed bin(24)defined ( cobol_ext_$cobol_x2_fileno); 18 92 dcl cobol_ext_$cobol_x3_fileno fixed bin(24)ext; 18 93 dcl cobol_x3_fileno fixed bin(24)defined ( cobol_ext_$cobol_x3_fileno); 18 94 18 95 dcl cobol_ext_$cobol_lpr char (5) ext; 18 96 dcl cobol_lpr char (5) defined ( cobol_ext_$cobol_lpr); /* -2- */ 18 97 dcl cobol_ext_$cobol_options char (120) ext; 18 98 dcl cobol_options char (120) defined ( cobol_ext_$cobol_options); /* -30- */ 18 99 18 100 dcl cobol_ext_$cobol_xlast8 bit (1) ext; 18 101 dcl cobol_xlast8 bit (1) defined ( cobol_ext_$cobol_xlast8); /* -1- */ 18 102 dcl cobol_ext_$report_exists bit (1) ext; 18 103 dcl report_exists bit (1) defined ( cobol_ext_$report_exists); 18 104 18 105 18 106 /* <<< END OF SHARED EXTERNALS INCLUDE FILE >>> */ 18 107 /* END INCLUDE FILE ... cobol_ext_.incl.pl1 */ 18 108 4880 19 1 19 2 /* BEGIN INCLUDE FILE ... cobol_addr_tokens.incl.pl1 */ 19 3 19 4 19 5 /****^ HISTORY COMMENTS: 19 6* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8058), 19 7* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 19 8* MCR8058 cobol_addr_tokens.incl.pl1 Change array extents to refer to 19 9* constants rather than variables. 19 10* END HISTORY COMMENTS */ 19 11 19 12 19 13 /* Last modified on 10/1/74 by tg */ 19 14 19 15 19 16 /* parameter list */ 19 17 19 18 dcl (input_ptr, inst_ptr, reloc_ptr) ptr; 19 19 19 20 19 21 /* input_struc_basic is used for type 1 addressing */ 19 22 19 23 dcl 1 input_struc_basic based (input_ptr), 19 24 2 type fixed bin, 19 25 2 operand_no fixed bin, 19 26 2 lock fixed bin, 19 27 2 segno fixed bin, 19 28 2 char_offset fixed bin (24), 19 29 2 send_receive fixed bin; 19 30 19 31 19 32 dcl 1 input_struc based (input_ptr), 19 33 2 type fixed bin, 19 34 2 operand_no fixed bin, 19 35 2 lock fixed bin, 19 36 2 operand (0 refer (input_struc.operand_no)), 19 37 3 token_ptr ptr, 19 38 3 send_receive fixed bin, 19 39 3 ic_mod fixed bin, 19 40 3 size_sw fixed bin; 19 41 19 42 /* reloc_struc is used for all types of addressing * all types */ 19 43 19 44 dcl 1 reloc_struc (input_struc.operand_no + 1) based (reloc_ptr), 19 45 2 left_wd bit (5) aligned, 19 46 2 right_wd bit (5) aligned; 19 47 19 48 /* Instruction format for 1 word instruction */ 19 49 19 50 19 51 dcl 1 inst_struc_basic based (inst_ptr) aligned, 19 52 2 y unaligned, 19 53 3 pr bit (3) unaligned, 19 54 3 wd_offset bit (15) unaligned, 19 55 2 fill1_op bit (10) unaligned, 19 56 2 zero1 bit (1) unaligned, 19 57 2 pr_spec bit (1) unaligned, 19 58 2 tm bit (2) unaligned, 19 59 2 td bit (4) unaligned; 19 60 19 61 19 62 /* The detailed definitions of the fields in this structure 19 63* can be found in the GMAP manual section 8 */ 19 64 /* EIS instruction format for 2_4 word instructions */ 19 65 19 66 dcl 1 inst_struc based (inst_ptr) aligned, 19 67 2 inst unaligned, 19 68 3 zero1 bit (2) unaligned, 19 69 3 mf3 unaligned, 19 70 4 pr_spec bit (1) unaligned, 19 71 4 reg_or_length bit (1) unaligned, 19 72 4 zero2 bit (1) unaligned, 19 73 4 reg_mod bit (4) unaligned, 19 74 3 zero3 bit (2) unaligned, 19 75 3 mf2 unaligned, 19 76 4 pr_spec bit (1) unaligned, 19 77 4 reg_or_length bit (1) unaligned, 19 78 4 zero4 bit (1) unaligned, 19 79 4 reg_mod bit (4) unaligned, 19 80 3 fill1_op bit (10) unaligned, 19 81 3 zero5 bit (1) unaligned, 19 82 3 mf1 unaligned, 19 83 4 pr_spec bit (1) unaligned, 19 84 4 reg_or_length bit (1) unaligned, 19 85 4 zero6 bit (1) unaligned, 19 86 4 reg_mod bit (4) unaligned, 19 87 2 desc_ext unaligned, 19 88 3 desc (512) unaligned, 19 89 4 desc_od bit (36) unaligned; 19 90 19 91 /* The detailed definitions of the fields in this structure 19 92* can be found in the GMAP manual section 8. 19 93* The desc_ext is the descriptor extension of this eis 19 94* instruction. The number of descriptors associated with 19 95* this instruction is equavalent to the operand number. 19 96* Depending on operand data type, the descriptor 19 97* can be alphanumeric or numeric. The structures of the 19 98* alphanumeric and the numeric descriptors are defined 19 99* below. */ 19 100 19 101 /* alphanumeric descriptor format */ 19 102 19 103 dcl 1 desc_an based (desc_an_ptr) unaligned, 19 104 2 desc_f (512) unaligned, 19 105 3 y unaligned, 19 106 4 pr bit (3) unaligned, 19 107 4 wd_offset bit (15) unaligned, 19 108 3 char_n bit (3) unaligned, 19 109 3 zero1 bit (1) unaligned, 19 110 3 ta bit (2), 19 111 3 n bit (12) unaligned; 19 112 19 113 19 114 /* The detailed definitions of the fields in this structure can 19 115* be found in the GMAP manual section 8. */ 19 116 /* numeric descriptor format */ 19 117 19 118 dcl desc_nn_ptr ptr; 19 119 dcl desc_an_ptr ptr; 19 120 19 121 19 122 dcl 1 desc_nn based (desc_nn_ptr) unaligned, 19 123 2 desc_f (512) unaligned, 19 124 3 y unaligned, 19 125 4 pr bit (3) unaligned, 19 126 4 wd_offset bit (15) unaligned, 19 127 3 digit_n bit (3) unaligned, 19 128 3 tn bit (1) unaligned, 19 129 3 sign_type bit (2) unaligned, 19 130 3 scal bit (6) unaligned, 19 131 3 n bit (6) unaligned; 19 132 19 133 19 134 /* The detailed definitions of fields in this structure can 19 135* be found in the GMAP manual section 8. */ 19 136 /* END INCLUDE FILE ... cobol_addr_tokens.incl.pl1 */ 19 137 4881 4882 4883 end cobol_move_gen; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0830.5 cobol_move_gen.pl1 >spec>install>MR12.3-1048>cobol_move_gen.pl1 4857 1 11/11/82 1712.7 cobol_in_token.incl.pl1 >ldd>include>cobol_in_token.incl.pl1 4858 2 03/27/82 0439.8 cobol_type40.incl.pl1 >ldd>include>cobol_type40.incl.pl1 2-14 3 11/11/82 1712.8 cobol_TYPE40.incl.pl1 >ldd>include>cobol_TYPE40.incl.pl1 4859 4 03/27/82 0439.8 cobol_type1.incl.pl1 >ldd>include>cobol_type1.incl.pl1 4-15 5 11/11/82 1712.8 cobol_TYPE1.incl.pl1 >ldd>include>cobol_TYPE1.incl.pl1 4860 6 03/27/82 0439.8 cobol_type2.incl.pl1 >ldd>include>cobol_type2.incl.pl1 6-15 7 11/11/82 1712.8 cobol_TYPE2.incl.pl1 >ldd>include>cobol_TYPE2.incl.pl1 4861 8 03/27/82 0439.8 cobol_type3.incl.pl1 >ldd>include>cobol_type3.incl.pl1 8-15 9 11/11/82 1712.8 cobol_TYPE3.incl.pl1 >ldd>include>cobol_TYPE3.incl.pl1 4862 10 03/27/82 0439.9 cobol_type9.incl.pl1 >ldd>include>cobol_type9.incl.pl1 10-17 11 11/11/82 1712.7 cobol_TYPE9.incl.pl1 >ldd>include>cobol_TYPE9.incl.pl1 4874 12 03/27/82 0439.6 cobol_TYPE13.incl.pl1 >ldd>include>cobol_TYPE13.incl.pl1 4876 13 03/27/82 0439.8 cobol_type19.incl.pl1 >ldd>include>cobol_type19.incl.pl1 13-17 14 03/27/82 0439.6 cobol_TYPE19.incl.pl1 >ldd>include>cobol_TYPE19.incl.pl1 4877 15 03/27/82 0439.7 cobol_edit_ext.incl.pl1 >ldd>include>cobol_edit_ext.incl.pl1 4878 16 11/11/82 1712.7 cobol_.incl.pl1 >ldd>include>cobol_.incl.pl1 4879 17 11/11/82 1712.8 cobol_fixed_common.incl.pl1 >ldd>include>cobol_fixed_common.incl.pl1 4880 18 03/27/82 0431.3 cobol_ext_.incl.pl1 >ldd>include>cobol_ext_.incl.pl1 4881 19 05/24/89 0811.7 cobol_addr_tokens.incl.pl1 >spec>install>MR12.3-1048>cobol_addr_tokens.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. ALS constant bit(10) initial packed unaligned dcl 66 ref 3452 ANA constant bit(10) initial packed unaligned dcl 78 ref 4309 ANAQ constant bit(10) initial packed unaligned dcl 100 ref 3708 ANQ constant bit(10) initial packed unaligned dcl 80 ref 4311 ARL constant bit(10) initial packed unaligned dcl 86 ref 4328 ARS constant bit(10) initial packed unaligned dcl 70 ref 3462 BTD constant bit(10) initial packed unaligned dcl 92 ref 4068 CMPN constant bit(10) initial packed unaligned dcl 60 ref 2202 DS 015574 constant char(1) initial packed unaligned dcl 136 ref 1355 1371 1384 1461 1670 1680 2020 2026 2367 DTB constant bit(10) initial packed unaligned dcl 94 ref 3561 3656 4156 4247 LDA constant bit(10) initial packed unaligned dcl 62 ref 3440 4296 LDAQ constant bit(10) initial packed unaligned dcl 98 ref 3693 LDQ constant bit(10) initial packed unaligned dcl 64 ref 3442 4298 MLR 000012 internal static bit(10) initial packed unaligned dcl 54 set ref 544* 850* 973 1549* 1721* 1785* 2451 2795 3734 4359 4540* MRL 000013 internal static bit(10) initial packed unaligned dcl 56 set ref 854* 971 3976 MVE 000010 internal static bit(10) initial packed unaligned dcl 50 set ref 1522* MVN constant bit(10) initial packed unaligned dcl 58 ref 2564 MVNE 000011 internal static bit(10) initial packed unaligned dcl 52 set ref 2129* ORSA constant bit(10) initial packed unaligned dcl 88 ref 3718 4336 ORSQ constant bit(10) initial packed unaligned dcl 90 ref 4338 QLS constant bit(10) initial packed unaligned dcl 68 ref 3454 QRL constant bit(10) initial packed unaligned dcl 96 ref 4330 QRS constant bit(10) initial packed unaligned dcl 72 ref 3464 RF_dn 001627 automatic char(144) packed unaligned dcl 4809 set ref 383 383 SF_dn 001563 automatic char(144) packed unaligned dcl 4809 set ref 377 377 STA constant bit(10) initial packed unaligned dcl 74 ref 3476 4318 STQ constant bit(10) initial packed unaligned dcl 76 ref 3478 3713 4320 addr builtin function dcl 303 ref 377 377 383 383 493 494 495 496 497 498 499 500 627 1076 1076 1078 1078 1182 1182 1304 1305 1577 1578 2414 2414 3428 3428 3436 3436 3444 3444 3456 3456 3466 3466 3473 3473 3480 3480 3484 3484 3664 3674 3675 3690 3690 3747 3747 3925 3925 3940 3940 4257 4273 4274 4292 4292 4326 4532 4533 4751 4778 addrel builtin function dcl 303 ref 1307 1584 al_lit 000220 automatic structure level 1 unaligned dcl 4463 set ref 4532 alit_ptr 001700 automatic pointer dcl 8-11 set ref 555* 557 565 566 578 580 all_lit 4(01) 000220 automatic bit(1) level 2 in structure "al_lit" packed packed unaligned dcl 4463 in procedure "non_opch_to_opch" set ref 4526* all_lit 4(01) based bit(1) level 2 in structure "alphanum_lit" packed packed unaligned dcl 8-14 in procedure "cobol_move_gen" ref 557 alphabet_name based structure level 1 unaligned dcl 2-13 alphabetic 21(21) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 804 1139 alphabetic_edited 21(22) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 572 807 1215 alphanum 21(19) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 343* 349* 750* 773* 797* 804 866* 939* 943 1139 3726* 3728* 3741* 3961* 3963* 3983* 3985* 4350* 4353* 4364* 4538* 4558* 4839* alphanum_edited 21(20) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 572 807 1215 alphanum_lit based structure level 1 unaligned dcl 8-14 an_ptr 000216 automatic pointer dcl 4452 set ref 4532* 4535* arl_18_inst 000053 internal static bit(36) initial packed unaligned dcl 4115 set ref 4326 4328* 4330* ascii_packed_dec 21(30) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 2713 3314* ascii_packed_dec_h 21(29) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 2695 ast_when_zero 22(17) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 1689 asterisk 000453 automatic fixed bin(17,0) dcl 176 set ref 1690* 1760 1901 awz 000452 automatic fixed bin(17,0) dcl 176 set ref 1689* 1695 2131 bin_16 21(32) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 4189 bin_18 21(13) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 631 3315* 3320 4031 4748 4753 4766 bin_32 21(33) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 3596 bin_36 21(14) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 634 3316* 3328 3841 4748 bin_tkn_ptr 000144 automatic pointer dcl 3546 in procedure "dec_lb" set ref 3638* 3640* 3643 3648* 3652* 3660 3678 3679 3724 3725 3726 3730* bin_tkn_ptr 000206 automatic pointer dcl 4140 in procedure "dec_sb" set ref 4233* 4235* 4239* 4243* 4252 4279 4280 4346 4346 4348 4349 4350 4355* bin_zero 000055 internal static fixed bin(35,0) initial dcl 4726 set ref 4751 bin_zero_const based char(4) packed unaligned dcl 4734 ref 4757 4757 binary builtin function dcl 303 ref 4518 binary_mask_string based char(4) packed unaligned dcl 4139 in procedure "dec_sb" set ref 4259* binary_mask_string based char(8) packed unaligned dcl 3547 in procedure "dec_lb" set ref 3668* bit_offset 31(16) based bit(4) level 2 packed packed unaligned dcl 10-16 set ref 2700 2704* 2709* bump 000114 automatic fixed bin(17,0) dcl 3527 in procedure "dec_lb" set ref 3615* 3617* bump 000210 automatic fixed bin(17,0) dcl 4141 in procedure "dec_sb" set ref 4209* 4211* bwz 000451 automatic fixed bin(17,0) dcl 176 in procedure "cobol_move_gen" set ref 1688* 1747 1812 1867 1952 2023 2055 2320 bwz 22(03) based bit(1) level 2 in structure "data_name" packed packed unaligned dcl 10-16 in procedure "cobol_move_gen" ref 1688 bz_status 000465 automatic fixed bin(17,0) dcl 184 set ref 1794* 1816* 1867 1873* 1952 1961* 2320 2326* cd_off 14 based fixed bin(24,0) level 2 dcl 4873 ref 4842 cd_seg 13 based fixed bin(17,0) level 2 dcl 4873 ref 4841 cdtoken based structure level 1 unaligned dcl 4873 char_offset 000124 automatic fixed bin(17,0) dcl 4645 in procedure "opch_to_non_opch" set ref 4672* 4677 4677 char_offset 4 based fixed bin(24,0) level 2 in structure "input_struc_basic" dcl 19-23 in procedure "cobol_move_gen" set ref 1073* 3679* 3703* 4280* 4305* cobol_$compile_count 000144 external static fixed bin(17,0) dcl 16-142 ref 440 444 cobol_$main_pcs_ptr 000136 external static pointer dcl 16-84 ref 1102 1102 1113 1113 cobol_$next_tag 000142 external static fixed bin(17,0) dcl 16-128 set ref 1734 1735* 1735 2208 2209* 2209 cobol_$text_wd_off 000140 external static fixed bin(17,0) dcl 16-90 ref 1188 1737 2214 cobol_addr 000062 constant entry external dcl 262 ref 1076 2151 2206 2449 2535 2568 2793 3428 3473 3559 3654 3683 3705 3732 3913 3971 4064 4154 4245 4284 4307 4357 cobol_alloc$stack 000064 constant entry external dcl 262 ref 525 835 1321 3194 3347 3633 4039 4229 4405 4672 cobol_com_ptr defined pointer dcl 18-25 ref 505 509 cobol_define_tag 000066 constant entry external dcl 262 ref 1732 2131 cobol_emit 000070 constant entry external dcl 262 ref 1078 1197 1208 1731 2153 2212 2491 2509 2588 2800 3444 3456 3466 3480 3563 3658 3695 3710 3715 3720 3736 3930 3938 3980 4072 4158 4249 4300 4313 4322 4332 4340 4361 4555 cobol_ext_$cobol_com_ptr 000146 external static pointer dcl 18-24 ref 505 505 509 509 cobol_get_num_code 000110 constant entry external dcl 262 ref 2895 2932 2987 3042 3102 cobol_io_util$move 000150 constant entry external dcl 2442 ref 2466 cobol_io_util$move_lit 000124 constant entry external dcl 262 ref 2537 cobol_make_bin_const 000132 constant entry external dcl 294 ref 631 634 cobol_make_tagref 000072 constant entry external dcl 262 ref 1737 2214 cobol_make_type9$alphanumeric 000074 constant entry external dcl 262 ref 840 1228 1518 1720 1784 2128 4269 cobol_make_type9$copy 000120 constant entry external dcl 262 ref 3611 4205 cobol_make_type9$copy_sub 000122 constant entry external dcl 262 ref 3608 4202 cobol_make_type9$decimal_9bit 000076 constant entry external dcl 262 ref 1285 3295 4045 4677 4790 cobol_make_type9$long_bin 000114 constant entry external dcl 262 ref 3640 4235 4770 cobol_make_type9$short_bin 000116 constant entry external dcl 262 ref 4766 cobol_make_type9$type2_3 000100 constant entry external dcl 262 ref 585 4535 cobol_opch_op_call 000130 constant entry external dcl 292 ref 4583 4622 4690 cobol_pool 000104 constant entry external dcl 262 ref 1514 1716 2127 cobol_pool$search_op 000102 constant entry external dcl 262 ref 671 1176 1222 1279 1776 2171 3668 4259 4757 4780 cobol_register$load 000112 constant entry external dcl 262 ref 3436 3690 3925 4292 cobol_register$release 000134 constant entry external dcl 296 ref 3484 3747 3940 cobol_set_pr 000106 constant entry external dcl 262 ref 1182 code parameter fixed bin(17,0) dcl 3884 ref 3877 3915 3917 3917 3920 3922 3927 3927 3935 3935 col 000116 automatic fixed bin(17,0) dcl 151 set ref 454* 456 463* 2412* 4530 column 2 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 463 4829* 4829 column 2 based fixed bin(17,0) level 2 in structure "reserved_word" dcl 4-14 in procedure "cobol_move_gen" ref 454 column 2 000220 automatic fixed bin(17,0) level 2 in structure "al_lit" dcl 4463 in procedure "non_opch_to_opch" set ref 4530* communication_section 21(04) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 4836* const_length 000103 automatic fixed bin(17,0) dcl 4736 set ref 4753* 4755* 4757 4757 const_offset 000202 automatic fixed bin(24,0) dcl 4137 in procedure "dec_sb" set ref 4259* 4269* const_offset 000142 automatic fixed bin(24,0) dcl 3545 in procedure "dec_lb" set ref 3668* 3671* 3671 3703 const_offset 000102 automatic fixed bin(24,0) dcl 4733 in procedure "check_zero_move" set ref 4757* 4766 4766 4770 4770 4780* 4790* const_ptr 000100 automatic pointer dcl 4732 set ref 4751* 4757 4757 4778* 4780 contains 4 000174 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 4129 in procedure "dec_sb" set ref 4290* contains 4 000116 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 3530 in procedure "dec_lb" set ref 3688* contains 4 000116 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 3399 in procedure "sb_lb" set ref 3434* control_no 000033 internal static fixed bin(17,0) initial dcl 155 set ref 440 444* conv_minus 000024 constant char(1) initial array packed unaligned dcl 4452 ref 4522 conv_plus 000027 constant char(1) initial array packed unaligned dcl 4452 ref 4520 count 000472 automatic fixed bin(17,0) dcl 187 set ref 1347* 1353 1358 1361* 1361 1369 1375* 1375 1382* 1383 1388* 1388 1454* 1456 1456* 1458* 1458 1459 1464 1479 1838* 1840 1840* 1842* 1842 1844 1849 2013* 2014 2014* 2016* 2016 2018 2026 2026 2050 2359* 2361 2361* 2363* 2363 2365 2390 cs_offset 000133 automatic fixed bin(24,0) dcl 159 in procedure "cobol_move_gen" set ref 671* 677 1176* 1188 1222* 1228* 1279* 1285* 1514* 1518* 1716* 1720* 1776* 1784* 2127* 2128* cs_offset 000100 automatic fixed bin(24,0) dcl 2168 in procedure "dec_zero" set ref 2171* 2181 curr_char 002260 automatic fixed bin(17,0) dcl 2829 set ref 2840* 2845 2845 2847* 2847 2856 2857* 2857 curr_char_off 000100 automatic fixed bin(17,0) dcl 2688 set ref 2741* 2742 currency_char 000457 automatic char(1) packed unaligned dcl 180 set ref 509* 1771 1924 1928 1929 data_name based structure level 1 unaligned dcl 10-16 dec_temp_size 000100 automatic fixed bin(17,0) dcl 4021 set ref 4031* 4033* 4035 4039 4045* dec_tkn_ptr 000102 automatic pointer dcl 4023 set ref 4043* 4045* 4050 4056* 4060* 4078* dec_zero 000056 internal static char(2) initial packed unaligned dcl 4728 set ref 4778 dec_zero_const based char(2) packed unaligned dcl 4735 set ref 4780* delta parameter fixed bin(17,0) dcl 2688 in procedure "calc_char_offset" set ref 2660 2698 2698* 2698 2703* 2703 2708* 2708 2726* 2726 2729* 2729 2738 2741 2746 delta 000114 automatic fixed bin(17,0) dcl 149 in procedure "cobol_move_gen" set ref 1306* 1307 1583* 1584 desc 1 based structure array level 3 packed packed unaligned dcl 19-66 desc_ext 1 based structure level 2 packed packed unaligned dcl 19-66 desc_od 1 based bit(36) array level 4 packed packed unaligned dcl 19-66 set ref 1189* 1190* 1191* 1192* 1193* 1194* 1194 1200* 1200 1202* 1206* 2210* 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2503* 2503 2504* 2537 2537 2537 2537 2537 2537 2798* 4545 4545 4549* 4553* display 21(27) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 644* 868* 905 915 915 1560 1560 2179* 3309* 3340 4665 dn based bit(1296) packed unaligned dcl 4817 set ref 4825* dn_ptr parameter pointer dcl 2690 ref 2660 2695 2700 2704 2709 2713 2718 2718 2720 2735 2738 2738 2741 2742 2746 2746 dum_buff based char(500) packed unaligned dcl 3288 set ref 3301* 3301 e 5 based fixed bin(17,0) level 2 dcl 13-16 set ref 483 486* 486 491 ecm 000241 automatic char(1) array packed unaligned dcl 167 in procedure "cobol_move_gen" set ref 1304 1355 1358* 1360* 1371 1374* 1384 1387* 1454 1461 1577 1602* 1616* 1670 1673* 1680 1683* 1767* 1771* 1838 2013 2020 2085 2258 2262 2263 2276 2278 2299 2359 2367 2372 2383 ecm 5 based char(256) level 2 in structure "editor" packed packed unaligned dcl 15-26 in procedure "cobol_move_gen" ref 1309 1590 ecm_limit 000510 automatic fixed bin(17,0) dcl 196 set ref 1451* 1452 1454 1456 ecm_lnth 000344 automatic fixed bin(17,0) dcl 170 set ref 1308* 1309 1309 1353 1369 1383 1544 1545 1589* 1590 1590 1595* 1603 1604* 1604 1609 1615* 1615 1616 1668 1679 1776 1776 1782 2005 2007 2009 2083 2083 ecm_ptr 000342 automatic pointer dcl 169 set ref 1304* 1309 1454 1577* 1590 1603 1609 1701 1776 1776 1838 2013 2026 2359 ecm_size 4 based fixed bin(15,0) level 2 dcl 15-26 ref 1308 1589 ecm_str based char(256) packed unaligned dcl 168 set ref 1309* 1454 1590* 1603* 1609* 1701 1776 1776 1838 2013 2026 2359 edit_ptr 26 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" ref 1306 1580 1583 edit_ptr 001704 automatic pointer dcl 15-24 in procedure "cobol_move_gen" set ref 1307* 1308 1309 1584* 1585 1586 1587 1588 1589 1590 editor based structure level 1 unaligned dcl 15-26 eis_ 000520 automatic bit(36) array packed unaligned dcl 213 set ref 494 1184* 1186* 1199* 1729* 2146* 2201* 2444* 2480* 2487* 2505* 2531* 2563* 2570* 2573* 2576* 2582* 2583* 2584* 2585* 2789* 2796* 2797* 3419* elementary 21(09) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 642* 4483 end_fix 000476 automatic fixed bin(17,0) dcl 191 set ref 2005* 2007* 2009* 2011 2013 2014 2026 end_stmt based structure level 1 unaligned dcl 13-16 end_supp 000462 automatic fixed bin(17,0) dcl 181 set ref 1626* 1764 1771 1977 2357 2359 2361 enf00 015602 constant bit(9) initial packed unaligned dcl 113 ref 1818 1970 2107 enf01 015601 constant bit(9) initial packed unaligned dcl 114 ref 1815 1958 enf10 015600 constant bit(9) initial packed unaligned dcl 115 ref 1968 enf11 015577 constant bit(9) initial packed unaligned dcl 116 ref 1956 eos_ptr 001702 automatic pointer dcl 13-13 set ref 481* 483 486 486 491 1188 1189 1204 1206 err_msg parameter char packed unaligned dcl 2405 set ref 2397 2412* err_msg_lnth 10 002114 automatic fixed bin(17,0) level 2 dcl 2400 set ref 2412* error_info 002114 automatic structure level 1 dcl 2400 set ref 2414 2414 error_msg 11 002114 automatic char(168) level 2 dcl 2400 set ref 2412* es_status 000464 automatic fixed bin(17,0) dcl 184 set ref 1793* 1820* 1874* 1877 1882* 1962* 1965 1973* 2100 2327* 2331 2336* fc_hival constant fixed bin(17,0) initial dcl 140 ref 1099 fc_loval constant fixed bin(17,0) initial dcl 141 ref 1110 fc_quote constant fixed bin(17,0) initial dcl 142 ref 1123 fc_space constant fixed bin(17,0) initial dcl 139 ref 1090 fc_zero constant fixed bin(17,0) initial dcl 138 ref 1058 fill parameter bit(9) packed unaligned dcl 2438 ref 2418 2451 2480 2482 2505 fill1_op 0(18) based bit(10) level 3 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" set ref 2147* 2202* 2445* 2564* 2795* 3561* 3656* 3734* 3920* 3927* 3935* 3976* 4068* 4156* 4247* fill1_op 0(18) based bit(10) level 2 in structure "inst_struc_basic" packed packed unaligned dcl 19-51 in procedure "cobol_move_gen" set ref 3440* 3442* 3476* 3478* 3708* 4309* 4311* 4359* fixed builtin function dcl 303 ref 840 840 1306 1583 1596 1688 1689 1690 1691 2466 2466 2466 2466 2466 2466 2466 2466 2537 2537 2537 2537 3194 3194 3347 3347 4045 4045 4545 4545 4677 4677 4677 4677 4677 4677 4766 4766 4770 4770 4790 4790 fixed_common based structure level 1 unaligned dcl 17-26 fixed_insert based fixed bin(15,0) level 2 dcl 15-26 ref 1585 fixed_sf_ptr parameter pointer dcl 4387 set ref 4375 4409 4414 4415 4415 4416 4417 4418 4419 4423* fl 000124 automatic fixed bin(17,0) dcl 154 set ref 1586* 1621* 1771 1898 1921 1937 1956 1968 float_insert 1 based fixed bin(15,0) level 2 dcl 15-26 ref 1586 fx 000123 automatic fixed bin(17,0) dcl 154 set ref 1585* 1601* 1614* 1618* 1801 1809 2005 2007 2007 2075 2090 2097 hival constant char(1) initial packed unaligned dcl 134 ref 1104 hival_char 10(18) based char(1) level 2 packed packed unaligned dcl 2-13 ref 1102 i 7 based fixed bin(17,0) level 2 dcl 13-16 set ref 1188* 1189 1204* 1206 ic_mod 7 based fixed bin(17,0) array level 3 dcl 19-32 set ref 2622* 2627* 2642* 2647* 2652* idx 000235 automatic fixed bin(17,0) dcl 161 set ref 2026* 2028 2290* 2374* 2765* 2765* 2767* 2771 2771 2771 2771 ign constant bit(9) initial packed unaligned dcl 117 ref 1445 1499 1861 1996 2117 in_op 001562 automatic fixed bin(17,0) dcl 257 set ref 671* 673 1176* 1184 1222* 1224 1279* 1281 1776* 1778 2171* 2173 3668* 3699 4259* 4261 4757* 4760 4780* 4782 in_token based structure level 1 dcl 1-9 in_token_ptr parameter pointer dcl 1-7 ref 47 372 449 452 461 480 481 481 index builtin function dcl 303 ref 1701 2026 2276 2372 input 10(08) based bit(1) level 3 packed packed unaligned dcl 4873 ref 4821 input_ptr 001706 automatic pointer dcl 19-18 set ref 493* 1069 1070 1071 1072 1073 1074 1076* 2151* 2206* 2449* 2535* 2568* 2616 2617 2618 2620 2621 2622 2623 2625 2626 2627 2628 2636 2637 2638 2640 2641 2642 2643 2645 2646 2647 2648 2650 2651 2652 2653 2793* 3422 3423 3424 3425 3426 3428* 3471 3473* 3559* 3654* 3676 3677 3678 3679 3680 3683* 3699 3701 3703 3705* 3732* 3906 3908 3909 3910 3911 3913* 3971* 4064* 4154* 4245* 4276 4277 4278 4279 4280 4281 4284* 4304 4305 4307* 4357* input_struc based structure level 1 unaligned dcl 19-32 input_struc_basic based structure level 1 unaligned dcl 19-23 insa constant bit(9) initial packed unaligned dcl 122 ref 1905 insb constant bit(9) initial packed unaligned dcl 123 ref 1845 1911 1948 2045 insert_char_no 000473 automatic fixed bin(17,0) dcl 187 set ref 2276* 2278 2285* 2292 2296 2372* 2376 2380 insert_table_status 000466 automatic char(8) packed unaligned dcl 186 set ref 1434* 1795* 1887 1892* 1929* 1942* 2028 2034* 2055 2061* 2079* 2258 2263* 2276 2284* 2372 insm constant bit(9) initial packed unaligned dcl 121 ref 2268 insn_0 015576 constant bit(9) initial packed unaligned dcl 119 ref 2084 insn_4 015575 constant bit(9) initial packed unaligned dcl 120 ref 1804 2093 insp constant bit(9) initial packed unaligned dcl 124 ref 1473 insrt_op 000475 automatic bit(9) packed unaligned dcl 189 set ref 1473* 1845* 1905* 1911* 1948* 2045* 2292* 2293 2376* 2377 inst based structure level 2 packed packed unaligned dcl 19-66 inst_op 000032 constant bit(10) initial array packed unaligned dcl 3885 ref 3920 inst_ptr 001710 automatic pointer dcl 19-18 set ref 494* 1189 1190 1191 1192 1193 1194 1194 1197* 1200 1200 1202 1206 1208* 1731* 2147 2151* 2153* 2202 2206* 2210 2212* 2445 2449* 2455 2455 2455 2455 2455 2455 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2491* 2501 2501 2502 2503 2503 2504 2509* 2535* 2537 2537 2537 2537 2537 2537 2564 2568* 2588* 2793* 2795 2798 2800* 3428* 3440 3442 3444* 3473* 3476 3478 3480* 3559* 3561 3563* 3654* 3656 3658* 3705* 3708 3710* 3732* 3734 3736* 3913* 3920 3927 3930* 3935 3938* 3971* 3976 3980* 4064* 4068 4072* 4154* 4156 4158* 4245* 4247 4249* 4307* 4309 4311 4313* 4357* 4359 4361* 4545 4545 4549 4553 4555* inst_struc based structure level 1 dcl 19-66 inst_struc_basic based structure level 1 dcl 19-51 instr 000100 automatic bit(10) packed unaligned dcl 104 in procedure "cobol_move_gen" set ref 971* 973* 980* instr parameter bit(10) packed unaligned dcl 2142 in procedure "gen_move_edit" ref 2137 2147 integral 4 based bit(1) level 2 packed packed unaligned dcl 6-14 ref 648 ioa_$rsnnl 000060 constant entry external dcl 262 ref 2412 ioa_str 002177 automatic char(44) initial packed unaligned dcl 2406 set ref 2406* 2412* ips 000524 automatic bit(36) array packed unaligned dcl 216 set ref 493 ips_typ parameter fixed bin(17,0) dcl 2611 ref 2594 2613 2633 item_length 16 based fixed bin(24,0) level 2 dcl 10-16 set ref 523 654* 662* 662 671 671 798 867 935* 935 1152 1291* 1311 1313 1418* 1484* 1489* 1544* 2067* 2067 2184* 2493 2495 2497 3194 3194 3229* 3231* 3231 3325* 3333* 3336* 3347 3347 3621* 3624* 3643* 3724* 4215* 4218* 4348* 4415* 4832* item_signed 21(25) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 915 1289* 1560 1691 2576 2720 4488* 4559* ival_num 000032 internal static fixed bin(17,0) initial dcl 155 set ref 456* 456 ix 002261 automatic fixed bin(17,0) dcl 2830 set ref 2854* j 000114 automatic fixed bin(17,0) dcl 3770 in procedure "lb_sb" set ref 3787* 3789* 3791* j 000100 automatic fixed bin(17,0) dcl 3821 in procedure "bin_same_bin" set ref 3854* 3856* 3858* 3860* 3862* 3864* just_right 21(35) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 572 971 1353 1399 key 4 based fixed bin(17,0) level 2 dcl 4-14 ref 1058 1090 1099 1110 1123 left_adjust 000501 automatic fixed bin(17,0) dcl 192 set ref 1393* 1402* 1408* 1415 1415* 1420* 1441 1444 1464* 1464 1489 1490 1493 1532* 1534 1535* 1628* 1630 1643* 1662* 1668 1674* 1674 1857 1860 1992 1995 len 000100 automatic fixed bin(17,0) dcl 2437 set ref 2493* 2495* 2497 2504 length 002272 automatic fixed bin(17,0) dcl 4817 set ref 4821* 4823* 4832 4833 4844* 4846 4847 4847 level_01 21(07) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 4837* lin 000115 automatic fixed bin(17,0) dcl 151 set ref 453* 456 462* 2412* 4529 line 1 based fixed bin(17,0) level 2 in structure "reserved_word" dcl 4-14 in procedure "cobol_move_gen" ref 453 line 1 000220 automatic fixed bin(17,0) level 2 in structure "al_lit" dcl 4463 in procedure "non_opch_to_opch" set ref 4529* line 1 based fixed bin(17,0) level 2 in structure "numeric_lit" dcl 6-14 in procedure "cobol_move_gen" ref 640 line 1 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 462 640* 4828* line 1 based fixed bin(17,0) level 2 in structure "cdtoken" dcl 4873 in procedure "cobol_move_gen" ref 4828 linkage_section 21(03) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 530* 1328* 2455 2455 3200* 3307* 4414* lit_ln parameter fixed bin(17,0) dcl 2527 in procedure "gen_move_lit" ref 2515 2537 2537 lit_ln 000234 automatic fixed bin(17,0) dcl 161 in procedure "cobol_move_gen" set ref 565* 566 566 578* 580* 654* 655 655 663 668 1056* 1143 1156 1160 1160 1160 2762 2765 2765 2765 2767 2767 2771 2834 2838 2845 2856 2856 2857 4520 lit_size 5 based fixed bin(17,0) level 2 in structure "alphanum_lit" dcl 8-14 in procedure "cobol_move_gen" ref 565 566 578 580 580 lit_size 5 000220 automatic fixed bin(17,0) level 2 in structure "al_lit" dcl 4463 in procedure "non_opch_to_opch" set ref 4528* lit_str parameter char packed unaligned dcl 2527 in procedure "gen_move_lit" ref 2515 2537 2537 lit_str 000134 automatic char(256) packed unaligned dcl 160 in procedure "cobol_move_gen" set ref 566* 655* 663* 668* 671 671 1084* 1093* 1102* 1104* 1113* 1115* 1123* 1171* 1176 1176 1222 1222 1258* 1275* 1279 1279 1706* 1713* 1714* 1716 1716 1750* 2767* 2767 2771* 2771 2796 2845 2856 2865* 4499 4510 4520 lit_type 4 000220 automatic bit(1) level 2 packed packed unaligned dcl 4463 set ref 4527* literal 11 based char level 2 packed packed unaligned dcl 6-14 ref 655 lock 2 based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 19-23 in procedure "cobol_move_gen" set ref 1071* 4278* lock 2 000174 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 4129 in procedure "dec_sb" set ref 4289* lock 2 000511 automatic fixed bin(17,0) level 2 in structure "set_ptr_struc" dcl 199 in procedure "cobol_move_gen" set ref 1179* lock 2 000116 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 3530 in procedure "dec_lb" set ref 3687* lock 2 000116 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 3399 in procedure "sb_lb" set ref 3433* lock 2 based fixed bin(17,0) level 2 in structure "input_struc" dcl 19-32 in procedure "cobol_move_gen" set ref 2618* 2638* 3424* 3909* long_bin_limit 000134 automatic fixed bin(17,0) dcl 3542 set ref 3596* 3598* 3600 3615 3619 3621 3624 3628 long_binary_mask 000040 internal static bit(72) initial packed unaligned dcl 3520 set ref 3664 loval constant char(1) initial packed unaligned dcl 130 ref 1115 loval_char 10(27) based char(1) level 2 packed packed unaligned dcl 2-13 ref 1113 lte_1 015605 constant bit(9) initial packed unaligned dcl 110 ref 1890 2032 2059 2078 2261 2282 lte_3 015604 constant bit(9) initial packed unaligned dcl 111 ref 1940 lte_5 015603 constant bit(9) initial packed unaligned dcl 112 ref 1927 m 000106 automatic fixed bin(17,0) dcl 149 set ref 336* 336 354 372 492* mask_ptr 000140 automatic pointer dcl 3544 in procedure "dec_lb" set ref 3664* 3668 mask_ptr 000204 automatic pointer dcl 4138 in procedure "dec_sb" set ref 4257* 4259 4267* 4269* 4304 4305 max_supp 000461 automatic fixed bin(17,0) dcl 181 set ref 1588* 1623* 1626 max_suppress 3 based fixed bin(15,0) level 2 dcl 15-26 ref 1588 mdest 16 based fixed bin(17,0) level 2 dcl 4873 ref 4823 mf1 0(29) based structure level 3 packed packed unaligned dcl 19-66 set ref 2501* mf2 0(11) based structure level 3 packed packed unaligned dcl 19-66 ref 2501 mflc constant bit(9) initial packed unaligned dcl 127 ref 1932 mfls constant bit(9) initial packed unaligned dcl 128 ref 1945 micro_op 000474 automatic bit(9) packed unaligned dcl 189 set ref 1445* 1465* 1499* 1861* 1904* 1910* 1932* 1945* 1996* 2039* 2117* 2230* 2232* 2235 2268* module_name 002114 automatic char(32) level 2 dcl 2400 set ref 2410* mop 000346 automatic bit(9) array packed unaligned dcl 172 set ref 1305 1578 1804* 1815* 1818* 1871* 1880* 1890* 1927* 1940* 1956* 1958* 1968* 1970* 2032* 2059* 2078* 2084* 2093* 2103* 2107* 2235* 2261* 2282* 2293* 2324* 2334* 2377* mop_ptr 000446 automatic pointer dcl 174 set ref 1305* 1514 1514 1578* 1891 1928 1941 2033 2060 2080 2085 2127 2127 2262 2283 2299 2383 mop_str based char(256) packed unaligned dcl 173 set ref 1514 1514 1891* 1928* 1941* 2033* 2060* 2080* 2085* 2127 2127 2262* 2283* 2299* 2383* move_char 000110 automatic char(1) packed unaligned dcl 4452 set ref 4494* 4499* 4510* 4518 4520* 4522* 4531 move_digit 000214 automatic fixed bin(17,0) dcl 4452 set ref 4518* 4520 4522 move_num 000030 internal static fixed bin(17,0) initial dcl 155 set ref 443* 447* 447 464* 464 2412* move_special_bit 000035 internal static bit(1) initial packed unaligned dcl 253 set ref 741* 822 845 848* ms_ptr 000756 automatic pointer dcl 229 set ref 497* 1518* 1522* 2128* 2129* ms_tkn 000760 automatic char(200) packed unaligned dcl 230 set ref 497 ms_tkn_ptr parameter pointer dcl 2143 in procedure "gen_move_edit" set ref 2137 2149* ms_tkn_ptr parameter pointer dcl 2609 in procedure "set_ips_type5_6" ref 2594 2645 msg_1 000014 internal static char(24) initial packed unaligned dcl 144 set ref 428* msg_2 000022 internal static char(24) initial packed unaligned dcl 145 set ref 726* mvc constant bit(9) initial packed unaligned dcl 118 ref 1465 2039 mvza constant bit(9) initial packed unaligned dcl 125 ref 1904 mvzb constant bit(9) initial packed unaligned dcl 126 ref 1910 n 000107 automatic fixed bin(17,0) dcl 149 in procedure "cobol_move_gen" set ref 1353* 1355 1358 1360* 1369* 1371 1374* 1383* 1384 1387* 1452* 1454 1454 1454 1456 1461 1479* 1479* 1668* 1670 1673* 1679* 1680 1683* 1701* 1703 1714 1716 1716 1718 1764* 1767* 1836* 1838 1838 1838 1840 1849* 1849* 2011* 2013 2013 2013 2014 2020 2026 2026 2050* 2050* 2083* 2085* 2258 2262 2263 2276 2278 2299 2357* 2359 2359 2359 2361 2367 2372 2383 2390* 2390* n based fixed bin(17,0) level 2 in structure "in_token" dcl 1-9 in procedure "cobol_move_gen" ref 481 n_ecm 000345 automatic fixed bin(17,0) dcl 171 set ref 1435* 1451 1452 1796* 1806* 1822* 1828 1836 1852* 1919* 1919 1977* 2011 2357 n_mop 000450 automatic fixed bin(17,0) dcl 175 set ref 1430* 1505 1514 1514 1518 1520* 1797* 1805* 1821* 1871 1872* 1872 1880 1881* 1881 1890 1891 1893* 1893 1927 1928 1930* 1930 1940 1941 1943* 1943 1956 1958 1960* 1960 1968 1970 1972* 1972 2032 2033 2035* 2035 2059 2060 2062* 2062 2078 2080 2081* 2081 2084 2085 2086* 2086 2093 2094* 2094 2103 2104* 2104 2107 2108* 2108 2124 2127 2127 2128 2235 2236* 2236 2261 2262 2264* 2264 2282 2283 2286* 2286 2293 2294* 2294 2299 2300* 2300 2324 2325* 2325 2334 2335* 2335 2377 2378* 2378 2383 2384* 2384 n_rf 000110 automatic fixed bin(17,0) dcl 149 set ref 354 491* 517 name 20 based char level 2 in structure "cdtoken" packed packed unaligned dcl 4873 in procedure "cobol_move_gen" ref 4847 name 34 based char level 2 in structure "data_name" packed packed unaligned dcl 10-16 in procedure "cobol_move_gen" set ref 1065 4847* name_size 33 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 1065 1065 4846* 4847 name_size 17 based fixed bin(17,0) level 2 in structure "cdtoken" dcl 4873 in procedure "cobol_move_gen" ref 4827 4844 4847 nc_move_num 000031 internal static fixed bin(17,0) initial dcl 155 set ref 465* 465 ne_bit 000036 internal static bit(1) initial packed unaligned dcl 253 set ref 724* 2487 new_sf_ptr 000556 automatic pointer dcl 226 set ref 496* 527 530 531 532 533 538 541* 544* 546 585* 587 1228* 1230 1285* 1287 1565* 1567* 1569 3197 3200 3201 3203 3205 3206 3211* 3213 new_sf_tkn 000560 automatic char(500) packed unaligned dcl 227 set ref 496 627 628* 629* nlit_ptr 001676 automatic pointer dcl 6-11 set ref 622* 631* 634* 640 648 651 652 654 655 657 663 no_char1 000471 automatic fixed bin(17,0) dcl 187 set ref 1349* 1351* 1358 1367 1379 1383 no_chars 000470 automatic fixed bin(17,0) dcl 187 set ref 1348* 1353 1358 1367* 1367 1369 1369 1444* 1459* 1498* 1844* 1860* 1995* 2018* 2116* 2228 2230 2232 2234* 2234 2255 2290 2365* 2374 no_emit parameter bit(1) packed unaligned dcl 2441 ref 2418 2451 2509 non_elementary 21(08) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 729 732 765 768 1139 4838* null builtin function dcl 303 ref 449 838 1076 1076 1078 1078 1102 1113 1197 1197 1208 1208 1565 1731 1731 1737 1737 2204 2204 2206 2206 2212 2212 2214 2214 2414 2414 2447 2447 2533 2533 2533 2533 2535 2535 2566 2566 2791 2791 2791 2791 2793 2793 2800 2800 3295 3456 3456 3466 3466 3557 3557 3607 3638 3652 3652 3730 3730 3967 3967 4043 4060 4060 4152 4152 4200 4233 4243 4243 4267 4332 4332 4355 4355 4573 4675 4764 4788 numeric 21(17) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 342* 350* 535 572 643* 724 735 749* 768 772* 781 865* 880 940* 1239 1293 2178* 3725* 3727* 3740* 3960* 3962* 3984* 3986* 4349* 4352* 4363* 4537* 4557* numeric_edited 21(18) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 572 788 796* 883 numeric_lit based structure level 1 unaligned dcl 6-14 numeric_lit_flag 001561 automatic fixed bin(17,0) dcl 256 set ref 502* 646* 4483 4486* numeric_source_proc 001526 automatic entry variable initial array dcl 247 set ref 247* 247* 247* 247* 247* 2899 nword 000101 automatic fixed bin(17,0) dcl 2688 set ref 2738* 2742 obj_dec_comma 134(11) based bit(1) level 2 packed packed unaligned dcl 17-26 ref 505 obj_dec_pt_char 000456 automatic char(1) packed unaligned dcl 179 set ref 505* 507* 1701 1714 object_sign 146(27) based char(1) level 2 packed packed unaligned dcl 17-26 ref 509 offset 24 based fixed bin(24,0) level 2 dcl 10-16 set ref 533* 677* 908* 908 1073 1331* 1547* 2181* 2738 2738 2741 2742* 2746* 2746 3206* 3349* 3446 3679 3787 3854 3860 4280 4305 4346* 4346 4419* 4842* only_an 001557 automatic bit(1) packed unaligned dcl 252 set ref 487* 489* 2579 op_code parameter bit(10) packed unaligned dcl 2436 ref 2418 2445 2451 operand 4 based structure array level 2 unaligned dcl 19-32 operand_no 1 based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 19-23 in procedure "cobol_move_gen" set ref 1070* 3677* 4277* operand_no 1 based fixed bin(17,0) level 2 in structure "input_struc" dcl 19-32 in procedure "cobol_move_gen" set ref 2617* 2637* 2643 3423* 3908* opnd_ln 000507 automatic fixed bin(17,0) dcl 196 set ref 1429* 1435 1437* 1439* 1451 1482 1484 1485 1527* options 10(08) based structure level 2 packed packed unaligned dcl 4873 overlap 000502 automatic fixed bin(17,0) dcl 192 in procedure "cobol_move_gen" set ref 1633* 1637* 1639 1642* 1652* 1656* 1658 1661* 1698 1725 1744 overlap 22(27) based bit(1) level 2 in structure "data_name" packed packed unaligned dcl 10-16 in procedure "cobol_move_gen" ref 517 p parameter pointer dcl 4817 set ref 4812 4821 4823 4827 4828 4829 4841 4842 4844 4847 4849* pic_has_ast 21(24) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 1690 pic_has_p 21(23) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 2455 2482 pic_integer 22(16) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 648* pl 000111 automatic fixed bin(17,0) dcl 149 set ref 1152* 1156 1156 1161 1161 1164 1168 1204 1236* 1242 1248 1251 1259* 1264 1267 1269 1275 1279 1279 1285* 1291 places 10 based fixed bin(17,0) level 2 dcl 6-14 ref 654 655 places_left 6 based fixed bin(17,0) level 2 in structure "numeric_lit" dcl 6-14 in procedure "cobol_move_gen" ref 651 places_left 17 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 651* 798* 867* 1218 1236 1312 1419* 1485* 1490* 1545* 1572 1574 2182* 2455 2482 2493 2493 2718 3148 3151 3228* 3323* 3331* 3336 3549 3569 3569 3600 3615 3619* 3628 4035 4143 4193 4209 4213* 4223 4405 4415 4499 4499 4499 4499 4499 4499 4510 4510 4672 4677 4677 4744 4744 4790 4790 4790 4833* places_right 20 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 652* 1237 1349 1349 1573 1575 2068* 2068 2183* 2455 2482 2495 2718 3150 3152 3324* 3332* 3336 3550 3569 4035 4145 4164 4416* 4510 4510 4510 4510 4672 4677 4677 4744 4744 4834* places_right 7 based fixed bin(17,0) level 2 in structure "numeric_lit" dcl 6-14 in procedure "cobol_move_gen" ref 652 pointer_no 1 000511 automatic bit(3) level 2 dcl 199 set ref 1192 pr 000112 automatic fixed bin(17,0) dcl 149 set ref 1237* 1245 1249* 1251 1259 1267 1269 1275 1275 1279 1279 1285* 1291 pr_spec 0(29) based bit(1) level 4 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" set ref 2455 pr_spec 0(11) based bit(1) level 4 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" ref 2455 q parameter pointer dcl 4817 ref 4812 4825 4827 4828 4829 4830 4832 4833 4834 4836 4837 4838 4839 4841 4842 4846 4847 4849 quote constant char(1) initial packed unaligned dcl 132 ref 1123 rec_tkn based char(500) packed unaligned dcl 166 set ref 527* 901* 1323* 1338* 3197* 3197 3219* 3219 reg_load_struc 000116 automatic structure level 1 unaligned dcl 3530 in procedure "dec_lb" set ref 3690 3690 3747 3747 reg_load_struc 000116 automatic structure level 1 unaligned dcl 3399 in procedure "sb_lb" set ref 3436 3436 3484 3484 reg_load_struc 000174 automatic structure level 1 unaligned dcl 4129 in procedure "dec_sb" set ref 4292 4292 reg_mod 0(32) based bit(4) level 4 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" set ref 2455 reg_mod 0(14) based bit(4) level 4 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" ref 2455 reg_no 1 000116 automatic bit(4) level 2 in structure "reg_load_struc" packed packed unaligned dcl 3399 in procedure "sb_lb" set ref 3440 3452 3462 3476 reg_no 1 000174 automatic bit(4) level 2 in structure "reg_load_struc" packed packed unaligned dcl 4129 in procedure "dec_sb" set ref 4296 4309 4318 4328 4336 reg_num 1 000042 internal static bit(4) level 2 packed packed unaligned dcl 3897 set ref 3927 3935 reg_or_length 0(12) based bit(1) level 4 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" ref 2455 reg_or_length 0(30) based bit(1) level 4 in structure "inst_struc" packed packed unaligned dcl 19-66 in procedure "cobol_move_gen" set ref 2455 2502* reg_struc 000042 internal static structure level 1 unaligned dcl 3897 set ref 3925 3925 3940 3940 reloc_info 000546 automatic structure array level 1 dcl 219 set ref 495 reloc_ptr 001712 automatic pointer dcl 19-18 set ref 495* 2151* 2153* 2449* 2491* 2509* 2568* 2588* 3559* 3563* 3654* 3658* 3705* 3710* 3732* 3736* 3913* 3930* 3938* 3971* 3980* 4064* 4072* 4154* 4158* 4245* 4249* 4307* 4313* 4357* 4361* 4555* remainder_count 002257 automatic fixed bin(17,0) dcl 2828 set ref 2838* 2842 2845 2845 2845 2847 req_ln 000236 automatic fixed bin(17,0) dcl 162 set ref 1160* 1161 1161* 1164* 1168 1171* 1176 1176 1191 1202 1204 1218* 1222 1222 1228* 1248* 1251* 1267* 1269* 1274* 1275 1275 1718* 1720* 1782* 1784* 2762 2765 2771 2771 2771 2834 2838 2865 2865 reserved_word based structure level 1 unaligned dcl 4-14 ret_offset 000115 automatic fixed bin(17,0) dcl 3528 in procedure "dec_lb" set ref 3633* 3635* 3635 3640* ret_offset 001556 automatic fixed bin(17,0) dcl 251 in procedure "cobol_move_gen" set ref 835* 840 840 ret_offset 000101 automatic fixed bin(17,0) dcl 4022 in procedure "any_bin_dec" set ref 4039* 4045 4045 ret_offset 000100 automatic fixed bin(17,0) dcl 3287 in procedure "num_to_udts" set ref 3347* 3349 ret_offset 000201 automatic fixed bin(17,0) dcl 4136 in procedure "dec_sb" set ref 4229* 4235* ret_offset 000220 automatic fixed bin(17,0) dcl 4400 in procedure "dec_dec_fix" set ref 4405* 4419 return_code parameter fixed bin(17,0) dcl 3265 in procedure "num_to_udts" set ref 3247 3291* return_code 001552 automatic fixed bin(17,0) dcl 249 in procedure "cobol_move_gen" set ref 926* 928 1567* return_code 000102 automatic fixed bin(17,0) dcl 4447 in procedure "non_opch_to_opch" set ref 4577* rf_code 000104 automatic fixed bin(17,0) dcl 2980 in procedure "sb_source" set ref 2987* 2991 rf_code 000104 automatic fixed bin(17,0) dcl 2927 in procedure "dec_source" set ref 2932* 2934 rf_code 000104 automatic fixed bin(17,0) dcl 3089 in procedure "opch_source" set ref 3102* 3105 rf_code 000104 automatic fixed bin(17,0) dcl 3035 in procedure "lb_source" set ref 3042* 3046 rf_cpy_ptr 001242 automatic pointer dcl 235 set ref 499* 1323 1327 rf_length 000505 automatic fixed bin(17,0) dcl 194 set ref 1313* 1315 1321* 1433 1437 1439 1482* 1482 1524 rf_places 000504 automatic fixed bin(17,0) dcl 194 set ref 1312* 1344 1348 1403 1408 1418 1419 rf_ptr parameter pointer dcl 3083 in procedure "opch_source" set ref 3072 3098 3102* rf_ptr parameter pointer dcl 2887 in procedure "num_to_num" set ref 2872 2899* rf_ptr parameter pointer dcl 2974 in procedure "sb_source" set ref 2962 2983 2987* rf_ptr parameter pointer dcl 3136 in procedure "dec_dec" set ref 3122 3151 3152 3157* 3164* 3172* 3182* 3234* rf_ptr parameter pointer dcl 4005 in procedure "any_bin_dec" set ref 3993 4035 4035 4056 4078* rf_ptr parameter pointer dcl 3504 in procedure "dec_lb" set ref 3490 3557* 3569 3648 3660 3727 3728 3730* 3740 3741 rf_ptr parameter pointer dcl 3958 in procedure "bin_move_bin" set ref 3948 3962 3963 3967* 3985 3986 rf_ptr parameter pointer dcl 3375 in procedure "sb_lb" set ref 3363 3409 3412* 3471 rf_ptr parameter pointer dcl 4100 in procedure "dec_sb" set ref 4087 4152* 4239 4252 4352 4353 4355* 4363 4364 rf_ptr parameter pointer dcl 4603 in procedure "opch_to_opch" set ref 4592 4619* 4622* rf_ptr parameter pointer dcl 4442 in procedure "non_opch_to_opch" set ref 4430 4483 4487 4568* 4583* rf_ptr parameter pointer dcl 3820 in procedure "bin_same_bin" set ref 3805 3834 3837* 3846* 3851 3860 3864* 3869* rf_ptr parameter pointer dcl 4722 in procedure "check_zero_move" ref 4703 4744 4744 4748 4748 4753 4766 4790 4790 4790 rf_ptr parameter pointer dcl 2919 in procedure "dec_source" set ref 2906 2930 2932* rf_ptr parameter pointer dcl 3264 in procedure "num_to_udts" set ref 3247 3295 3295* 3301 3306 3307 3308 3309 3310 3314 3315 3316 3323 3324 3325 3331 3332 3333 3336 3347 3347 3349 3350 3354* rf_ptr 000130 automatic pointer dcl 157 in procedure "cobol_move_gen" set ref 372* 383 383* 517 572 572 572 572 572 572 572 580* 631 634 726 729 768 768 772 773 804 804 807 807 880 880* 883 943 971 980* 1065 1065 1065 1072 1073 1139 1139 1139 1152 1168 1171* 1182* 1215 1215 1218 1236 1237 1239 1293 1293* 1306 1307 1312 1313 1315 1323 1323 1323 1326 1327* 1328 1329 1330 1331 1353 1399 1484 1485 1522* 1527* 1544 1545 1546 1547 1549* 1574 1575 1580 1583 1584 1596 1688 1689 1690 1691 1721* 1785* 2129* 2791* rf_ptr parameter pointer dcl 3029 in procedure "lb_source" set ref 3017 3038 3042* rf_ptr parameter pointer dcl 4641 in procedure "opch_to_non_opch" set ref 4629 4658* 4660* 4665 4665 4672 4672 4677 4677 4677 4677 4687 4693 4693* rf_ptr parameter pointer dcl 2527 in procedure "gen_move_lit" set ref 2515 2533* rf_ptr parameter pointer dcl 3769 in procedure "lb_sb" set ref 3756 3782 3787 3791* 3796* rf_st 000477 automatic fixed bin(17,0) dcl 191 set ref 1596* 1598 1611 rf_temp_sw 000506 automatic fixed bin(17,0) dcl 194 set ref 1319* 1431* 1541 rf_tkn_cpy 001244 automatic char(500) packed unaligned dcl 236 set ref 499 rf_tkn_ptr parameter pointer dcl 2560 in procedure "gen_move_dec_numer" set ref 2545 2566* 2570 2573 2576 rf_tkn_ptr parameter pointer dcl 2143 in procedure "gen_move_edit" set ref 2137 2149* rf_tkn_ptr parameter pointer dcl 2439 in procedure "gen_move_alpha" set ref 2418 2447* 2455 2497 2497 rf_tkn_ptr parameter pointer dcl 2609 in procedure "set_ips_type5_6" ref 2594 2625 2650 right_adjust 000500 automatic fixed bin(17,0) dcl 192 set ref 1394* 1403* 1409* 1421* 1493* 1495 1498 1629* 1633 1644* 1652 1663* 1679 1684* 1684 2064 2069* 2113 2116 rounded 22(24) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 2570 rpl 000121 automatic fixed bin(17,0) dcl 152 set ref 1574* 1595 1628 1633 1637 1644 1662 3151* 3172 3177 3226 3228 3229 rpr 000122 automatic fixed bin(17,0) dcl 152 set ref 1575* 1595 1629 1633 1644 1656 1662 3152* 3157 rw_ptr 001674 automatic pointer dcl 4-11 set ref 452* 453 454 1055* 1058 1090 1099 1110 1123 save_rf_ptr 000104 automatic pointer dcl 147 set ref 1326* 1549* save_sf_ptr 000102 automatic pointer dcl 147 set ref 374 480* 546* 587* 627* 1334 3213* seg_num 23 based fixed bin(17,0) level 2 dcl 10-16 set ref 532* 673* 675* 822 822 822 822 1072 1330* 1546* 2180* 2735 3203* 3350* 3678 4279 4304 4418* 4841* segno 3 based fixed bin(17,0) level 2 dcl 19-23 set ref 1072* 3678* 3699* 3701* 4279* 4304* send_receive 5 based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 19-23 in procedure "cobol_move_gen" set ref 1074* 3680* 4281* send_receive 6 based fixed bin(17,0) array level 3 in structure "input_struc" dcl 19-32 in procedure "cobol_move_gen" set ref 2621* 2626* 2641* 2646* 2651* ses00 015611 constant bit(9) initial packed unaligned dcl 106 ref 1880 2103 ses01 015610 constant bit(9) initial packed unaligned dcl 107 ref 1871 ses10 015607 constant bit(9) initial packed unaligned dcl 108 ref 2334 ses11 015606 constant bit(9) initial packed unaligned dcl 109 ref 2324 set_ptr_struc 000511 automatic structure level 1 dcl 199 set ref 1182 1182 sf_category_sw 000240 automatic fixed bin(17,0) dcl 163 set ref 339 346 501* 748* 864* sf_code 000100 automatic fixed bin(17,0) dcl 2891 set ref 2895* 2899 sf_cpy_ptr 001042 automatic pointer dcl 232 set ref 498* 901 911* 926* 935 935 935 938 1338 1341 3219 3222 sf_places 000503 automatic fixed bin(17,0) dcl 194 set ref 1311* 1334 1344 1348 1403 1408 1412 1486 1493 1529 1534* 1534 sf_ptr parameter pointer dcl 4721 in procedure "check_zero_move" set ref 4703 4744 4744 4772* 4796* sf_ptr parameter pointer dcl 3768 in procedure "lb_sb" set ref 3756 3785* 3796* sf_ptr parameter pointer dcl 3958 in procedure "bin_move_bin" set ref 3948 3960 3961 3967* 3983 3984 sf_ptr parameter pointer dcl 4004 in procedure "any_bin_dec" set ref 3993 4031 4060* sf_ptr parameter pointer dcl 4640 in procedure "opch_to_non_opch" set ref 4629 4656 4660 4690* sf_ptr parameter pointer dcl 3082 in procedure "opch_source" ref 3072 3097 sf_ptr parameter pointer dcl 4386 in procedure "dec_dec_fix" set ref 4375 4405 4409 4409 4409 4423* sf_ptr parameter pointer dcl 4099 in procedure "dec_sb" set ref 4087 4143 4145 4164 4164 4164* 4168 4197 4202 4202* 4205* sf_ptr parameter pointer dcl 4441 in procedure "non_opch_to_opch" ref 4430 4479 4499 4499 4499 4510 4510 4510 4570 sf_ptr parameter pointer dcl 2886 in procedure "num_to_num" set ref 2872 2895* 2899* sf_ptr parameter pointer dcl 3503 in procedure "dec_lb" set ref 3490 3549 3550 3569 3569 3569 3569* 3575 3603 3608 3608* 3611* sf_ptr 000126 automatic pointer dcl 157 in procedure "cobol_move_gen" set ref 342 343 349 350 374* 377 377* 417 420 423 425 461* 462 463 480* 517 517 517 523 527 527 527 535 538 541* 544* 546* 555 585* 587* 622 627* 631* 634* 639 640 641 642 643 644 648 651 652 654 660 661 662 662 667 671 671 673 675 677 724 732 735 738 749 750 765 781 788 796 797 798 798 822 822 822 822 850* 854* 856* 865 866 867 867 868 880* 901 901 901 905 905 908 908 911 915 915 915 915 926* 938* 939 940 980* 1055 1230* 1287* 1288 1289 1290 1291 1293* 1311 1334 1338 1338 1338 1341* 1349 1349 1415* 1418 1419 1489 1490 1522* 1532* 1560 1560 1560 1560 1567* 1569* 1572 1573 2067 2067 2068 2068 2129* 2204* sf_ptr parameter pointer dcl 3374 in procedure "sb_lb" set ref 3363 3409 3412* 3425 3446 sf_ptr parameter pointer dcl 2918 in procedure "dec_source" ref 2906 2929 sf_ptr parameter pointer dcl 3135 in procedure "dec_dec" set ref 3122 3148 3150 3157* 3172* 3189 3194 3194 3197 3197 3197 3211* 3213* 3219 3219 3219 3222* 3226* 3228 3229 3231 3231 3231 3234* sf_ptr parameter pointer dcl 3819 in procedure "bin_same_bin" set ref 3805 3834 3837* 3841 3844* 3851 3854 3858* 3869* sf_ptr parameter pointer dcl 3263 in procedure "num_to_udts" set ref 3247 3301 3301 3301 3320 3328 3336 3336 3340 3340 3340 3354* sf_ptr parameter pointer dcl 3028 in procedure "lb_source" ref 3017 3037 sf_ptr parameter pointer dcl 4602 in procedure "opch_to_opch" ref 4592 4614 sf_ptr parameter pointer dcl 2973 in procedure "sb_source" ref 2962 2982 sf_stack_sw 000237 automatic fixed bin(17,0) dcl 163 set ref 389 503* 522* 3192* sf_tkn_cpy 001044 automatic char(500) packed unaligned dcl 233 set ref 498 sf_tkn_ptr parameter pointer dcl 2560 in procedure "gen_move_dec_numer" set ref 2545 2566* 2573 sf_tkn_ptr parameter pointer dcl 2609 in procedure "set_ips_type5_6" ref 2594 2620 2640 sf_tkn_ptr parameter pointer dcl 2143 in procedure "gen_move_edit" set ref 2137 2149* sf_tkn_ptr parameter pointer dcl 2439 in procedure "gen_move_alpha" set ref 2418 2447* 2455 2455 2455 2455 2482 2482 2482 2493 2493 2493 2495 2495 shift_inst 000037 internal static bit(36) initial packed unaligned dcl 3389 set ref 3452* 3454* 3456 3456 3462* 3464* 3466 3466 shift_inst_ptr 000172 automatic pointer dcl 4127 set ref 4326* 4332* short_bin_limit 000170 automatic fixed bin(17,0) dcl 4126 set ref 4189* 4191* 4193 4209 4213 4215 4218 4223 short_binary_mask 000054 internal static bit(36) initial packed unaligned dcl 4118 set ref 4257 sign 4(09) based char(1) level 2 in structure "numeric_lit" packed packed unaligned dcl 6-14 in procedure "cobol_move_gen" ref 657 663 sign 000454 automatic fixed bin(17,0) dcl 176 in procedure "cobol_move_gen" set ref 1691* 1757 sign_separate 21(26) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 660* 915 935 1290* 1560 3231 3308* sign_type 22(13) based bit(3) level 2 packed packed unaligned dcl 10-16 set ref 538 538* 661* 667* 905 1288* 1596 2185* 2573 2573 3189 3201* 3310* 3340 3569 3621 4050* 4164 4215 4417* 4489 4490* 4560* 4665 4683* 4795* signal_ 000126 constant entry external dcl 262 ref 2414 size based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 527 527 639* 901 901 1323 1323 1338 1338 3197 3197 3219 3219 3301 3301 4409 4409 4827* size 000220 automatic fixed bin(17,0) level 2 in structure "al_lit" dcl 4463 in procedure "non_opch_to_opch" set ref 4525* size 000113 automatic fixed bin(17,0) dcl 149 in procedure "cobol_move_gen" set ref 523* 525* size_sw 10 based fixed bin(17,0) array level 3 dcl 19-32 set ref 2623* 2628* 2643* 2648* 2653* 3426* 3911* snd_tkn based char(500) packed unaligned dcl 165 ref 527 901 1323 1338 source_reloc 000114 automatic bit(36) packed unaligned dcl 3394 set ref 3420* 3428 3428 3444 3444 3473 3473 3480 3480 space constant char(1) initial packed unaligned dcl 131 ref 657 1093 spl 000117 automatic fixed bin(17,0) dcl 152 set ref 1572* 1628 1643 1652 1656 1663 3148* 3154 3172 3226 3549* 3552 4143* 4147 spr 000120 automatic fixed bin(17,0) dcl 152 set ref 1573* 1629 1637 1643 1652 1663 3150* 3177 3229 3550* 4145* start_supp 000460 automatic fixed bin(17,0) dcl 181 set ref 1587* 1622* 1626 1764 1764 1825 1828 1836 1838 1840 1852 start_suppress 2 based fixed bin(15,0) level 2 dcl 15-26 ref 1587 stk_offset 000132 automatic fixed bin(17,0) dcl 158 set ref 525* 533 1321* 1331 1547 3194* 3206 string 6 based char level 2 in structure "alphanum_lit" packed packed unaligned dcl 8-14 in procedure "cobol_move_gen" set ref 566 580* string 6 000220 automatic char(1) level 2 in structure "al_lit" packed packed unaligned dcl 4463 in procedure "non_opch_to_opch" set ref 4531* stz_inst 000034 internal static bit(18) initial array packed unaligned dcl 243 set ref 1076 1076 1078 1078 subscripted 22(05) based bit(1) level 2 packed packed unaligned dcl 10-16 set ref 517 531* 572 1168 1315 1329* 3205* 3306* 3340 3409 3409 3608 3782 3834 3834 3851 3851 4202 substr builtin function dcl 303 set ref 527* 527 566* 566 628* 629* 655* 655 663* 663 668* 671 671 901* 901 1065 1084* 1093* 1102* 1104* 1113* 1115* 1123* 1176 1176 1189* 1189 1190* 1191* 1191 1192* 1193* 1194* 1194 1202* 1202 1206* 1206 1222 1222 1258* 1275* 1279 1279 1306 1309* 1309 1323* 1323 1338* 1338 1454 1514 1514 1583 1590* 1590 1603* 1609* 1706* 1713* 1714* 1716 1716 1750* 1776 1776 1838 1887 1891* 1892* 1928* 1929* 1941* 1942* 2013 2026 2028 2033* 2034* 2055 2060* 2061* 2079* 2080* 2085* 2127 2127 2176* 2230* 2232* 2232 2258 2262* 2263* 2283* 2284* 2292* 2292 2299* 2359 2376* 2376 2383* 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2466 2480* 2487* 2504* 2504 2505* 2537 2537 2537 2537 2537 2537 2537 2537 2570* 2573* 2576* 2582* 2583* 2584* 2585* 2767* 2767 2771* 2771 2796* 2796 2797* 2845* 2845 2856* 2856 2865* 2865 3197* 3197 3219* 3219 3301* 3301 3446 3452* 3454* 3462* 3464* 3693* 3713* 3718* 3787 3854 3860 3927* 3927 3935* 3935 4296* 4298* 4318* 4320* 4328* 4330* 4336* 4338* 4409* 4409 4499 4510 4520 4545 4545 4549* 4549 4553* 4757 4757 4847* 4847 supp_char 000463 automatic char(1) packed unaligned dcl 183 set ref 1760* 1762* 1767 switch 3 000511 automatic fixed bin(17,0) level 2 dcl 199 set ref 1180* tag 000455 automatic fixed bin(17,0) dcl 178 set ref 1732* 1734* 1737* 2131* 2208* 2214* temp 001560 automatic fixed bin(17,0) dcl 255 set ref 1224* 1226* 1228* 1281* 1283* 1285* 1516* 1518* 1778* 1780* 1784* 2173* 2175* 2180 4261* 4263* 4269* 4760* 4762* 4766* 4770* 4782* 4784* 4790* temp_inst 000154 automatic bit(36) packed unaligned dcl 4122 in procedure "dec_sb" set ref 4273 4296* 4298* 4318* 4320* 4336* 4338* temp_inst 000127 automatic bit(36) packed unaligned dcl 3539 in procedure "dec_lb" set ref 3674 3693* 3713* 3718* temp_inst_ptr 000130 automatic pointer dcl 3540 in procedure "dec_lb" set ref 3674* 3683* 3695* 3715* 3720* temp_inst_ptr 000156 automatic pointer dcl 4123 in procedure "dec_sb" set ref 4273* 4284* 4300* 4322* 4340* temp_len 000111 automatic fixed bin(17,0) dcl 4452 set ref 4545* 4549 temp_ptr 000112 automatic pointer dcl 4452 in procedure "non_opch_to_opch" set ref 4533* 4535* 4540* temp_ptr parameter pointer dcl 3883 in procedure "load_bin" ref 3877 3910 temp_ptr 000104 automatic pointer dcl 4737 in procedure "check_zero_move" set ref 4764* 4766* 4770* 4772 4788* 4790* 4795 4796 temp_reloc 000132 automatic bit(5) array dcl 3541 in procedure "dec_lb" set ref 3675 temp_reloc 000160 automatic bit(5) array dcl 4124 in procedure "dec_sb" set ref 4274 temp_reloc_ptr 000166 automatic pointer dcl 4125 in procedure "dec_sb" set ref 4274* 4284* 4300* 4322* 4340* temp_reloc_ptr 000136 automatic pointer dcl 3543 in procedure "dec_lb" set ref 3675* 3683* 3695* 3715* 3720* temp_result 000104 automatic bit(1) packed unaligned dcl 4024 set ref 4026* 4052* 4078 temp_rf_ptr 000130 automatic pointer dcl 4647 in procedure "opch_to_non_opch" set ref 4675* 4677* 4683 4687* 4690* 4693 4693* temp_rf_ptr 000106 automatic pointer dcl 4452 in procedure "non_opch_to_opch" set ref 4487* 4488 4489 4490 4492* 4499 4499 4499 4510 4510 4510 4537 4538 4540* 4557 4558 4559 4560 temp_sf_ptr 000126 automatic pointer dcl 4646 in procedure "opch_to_non_opch" set ref 4656* 4658* 4660 4660* temp_sf_ptr 000114 automatic pointer dcl 4607 in procedure "opch_to_opch" set ref 4614* 4619* 4622* temp_sf_ptr 000100 automatic pointer dcl 4446 in procedure "non_opch_to_opch" set ref 4479* 4492* 4568* 4570 4577* 4581 temp_sign_type 000213 automatic bit(3) packed unaligned dcl 4452 set ref 4489* 4496 4542 4560 temp_space 000114 automatic char(250) packed unaligned dcl 4452 set ref 4533 temp_tkn 001444 automatic char(200) packed unaligned dcl 239 in procedure "cobol_move_gen" set ref 500 temp_tkn based char(200) packed unaligned dcl 2169 in procedure "dec_zero" set ref 2176* temp_tkn_ptr parameter pointer dcl 2167 in procedure "dec_zero" ref 2159 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 temp_tkn_ptr 001442 automatic pointer dcl 238 in procedure "cobol_move_gen" set ref 500* 1720* 1721* 1784* 1785* 2199* 2204* 3162* 3164* 3180* 3182* 3555* 3557* 3569* 3575* 3596 3600 3603 3607* 3608* 3611* 3615 3617* 3619 3621 3621 3624 3628 3652* 4150* 4152* 4164* 4168* 4189 4193 4197 4200* 4202* 4205* 4209 4211* 4213 4215 4215 4218 4223 4243* temp_tok based char(500) packed unaligned dcl 4401 set ref 4409* 4409 temporary 22(02) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 1065 tlength 000102 automatic fixed bin(17,0) dcl 2691 set ref 2718* 2720* 2720 2726 token_ptr 2 based pointer array level 2 in structure "in_token" dcl 1-9 in procedure "cobol_move_gen" ref 372 449 452 461 480 481 token_ptr 4 based pointer array level 3 in structure "input_struc" dcl 19-32 in procedure "cobol_move_gen" set ref 2620* 2625* 2640* 2645* 2650* 3425* 3471* 3910* type based fixed bin(17,0) level 2 in structure "input_struc" dcl 19-32 in procedure "cobol_move_gen" set ref 2616* 2636* 3422* 3906* type 3 000220 automatic fixed bin(17,0) level 2 in structure "al_lit" dcl 4463 in procedure "non_opch_to_opch" set ref 4524* type based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 19-23 in procedure "cobol_move_gen" set ref 1069* 3676* 4276* type 3 based fixed bin(17,0) level 2 in structure "data_name" dcl 10-16 in procedure "cobol_move_gen" set ref 377 383 417 420 423 425 517 517 641* 726 2177* 4830* udts_token_ptr 000104 automatic pointer dcl 4448 set ref 4573* 4577* 4581* 4583* unspec builtin function dcl 303 ref 1189 1191 1202 1206 1306 1583 2232 2292 2376 2504 2796 3446 3787 3854 3860 4549 variable_length 22(04) based bit(1) level 2 packed packed unaligned dcl 10-16 ref 572 738 2497 verify builtin function dcl 303 ref 1454 1838 2013 2359 what_pointer 000511 automatic fixed bin(17,0) level 2 dcl 199 set ref 1178* what_reg 000042 internal static fixed bin(17,0) level 2 in structure "reg_struc" dcl 3897 in procedure "load_bin" set ref 3915* 3917* what_reg 000116 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 3530 in procedure "dec_lb" set ref 3686* what_reg 000116 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 3399 in procedure "sb_lb" set ref 3432* what_reg 000174 automatic fixed bin(17,0) level 2 in structure "reg_load_struc" dcl 4129 in procedure "dec_sb" set ref 4288* whole_string_count 002256 automatic fixed bin(17,0) dcl 2827 set ref 2834* 2851 2854 work_rf_ptr 000102 automatic pointer dcl 2926 in procedure "dec_source" set ref 2930* 2936* 2940* 2945* 2950* 2955* work_rf_ptr 000102 automatic pointer dcl 3034 in procedure "lb_source" set ref 3038* 3048* 3055* 3060* 3065* work_rf_ptr 000102 automatic pointer dcl 3088 in procedure "opch_source" set ref 3098* 3107* 3116* work_rf_ptr 000102 automatic pointer dcl 2979 in procedure "sb_source" set ref 2983* 2993* 3000* 3005* 3010* work_sf_ptr 001554 automatic pointer dcl 250 in procedure "cobol_move_gen" set ref 838* 840* 850* 854* 856 work_sf_ptr 000100 automatic pointer dcl 2925 in procedure "dec_source" set ref 2929* 2936* 2940* 2945* 2950* 2955* work_sf_ptr 000100 automatic pointer dcl 2978 in procedure "sb_source" set ref 2982* 2993* 3000* 3005* 3010* work_sf_ptr 000100 automatic pointer dcl 3087 in procedure "opch_source" set ref 3097* 3107* 3116* work_sf_ptr 000100 automatic pointer dcl 3033 in procedure "lb_source" set ref 3037* 3048* 3055* 3060* 3065* work_string 002244 automatic char(40) packed unaligned dcl 2826 set ref 2845* 2856* 2865 zero constant char(1) initial packed unaligned dcl 135 ref 1084 1258 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. STBA internal static bit(10) initial packed unaligned dcl 82 STBQ internal static bit(10) initial packed unaligned dcl 84 STZ internal static bit(10) initial packed unaligned dcl 102 allo1_max defined fixed bin(17,0) dcl 16-171 allo1_ptr defined pointer dcl 16-67 alpha_name_ptr automatic pointer dcl 2-10 alter_flag defined fixed bin(17,0) dcl 16-135 alter_index defined fixed bin(17,0) dcl 16-153 alter_list_ptr defined pointer dcl 16-39 cd_cnt defined fixed bin(17,0) dcl 16-197 cobol_$allo1_max external static fixed bin(17,0) dcl 16-170 cobol_$allo1_ptr external static pointer dcl 16-66 cobol_$alter_flag external static fixed bin(17,0) dcl 16-134 cobol_$alter_index external static fixed bin(17,0) dcl 16-152 cobol_$alter_list_ptr external static pointer dcl 16-38 cobol_$cd_cnt external static fixed bin(17,0) dcl 16-196 cobol_$cobol_data_wd_off external static fixed bin(17,0) dcl 16-118 cobol_$coms_charcnt external static fixed bin(17,0) dcl 16-188 cobol_$coms_wdoff external static fixed bin(17,0) dcl 16-202 cobol_$con_end_ptr external static pointer dcl 16-10 cobol_$con_wd_off external static fixed bin(17,0) dcl 16-92 cobol_$cons_charcnt external static fixed bin(17,0) dcl 16-192 cobol_$constant_offset external static fixed bin(17,0) dcl 16-156 cobol_$data_init_flag external static fixed bin(17,0) dcl 16-130 cobol_$date_compiled_sw external static fixed bin(17,0) dcl 16-180 cobol_$debug_enable external static fixed bin(17,0) dcl 16-174 cobol_$def_base_ptr external static pointer dcl 16-12 cobol_$def_max external static fixed bin(17,0) dcl 16-96 cobol_$def_wd_off external static fixed bin(17,0) dcl 16-94 cobol_$diag_ptr external static pointer dcl 16-70 cobol_$eln_max external static fixed bin(17,0) dcl 16-172 cobol_$eln_ptr external static pointer dcl 16-68 cobol_$fixup_max external static fixed bin(17,0) dcl 16-164 cobol_$fixup_ptr external static pointer dcl 16-30 cobol_$fs_charcnt external static fixed bin(17,0) dcl 16-184 cobol_$fs_wdoff external static fixed bin(17,0) dcl 16-198 cobol_$include_cnt external static fixed bin(17,0) dcl 16-182 cobol_$include_info_ptr external static pointer dcl 16-86 cobol_$init_stack_off external static fixed bin(17,0) dcl 16-124 cobol_$initval_base_ptr external static pointer dcl 16-32 cobol_$initval_file_ptr external static pointer dcl 16-34 cobol_$initval_flag external static fixed bin(17,0) dcl 16-178 cobol_$link_base_ptr external static pointer dcl 16-14 cobol_$link_max external static fixed bin(17,0) dcl 16-100 cobol_$link_wd_off external static fixed bin(17,0) dcl 16-98 cobol_$list_off external static fixed bin(17,0) dcl 16-154 cobol_$list_ptr external static pointer dcl 16-64 cobol_$ls_charcnt external static fixed bin(17,0) dcl 16-190 cobol_$map_data_max external static fixed bin(17,0) dcl 16-162 cobol_$map_data_ptr external static pointer dcl 16-54 cobol_$max_stack_off external static fixed bin(17,0) dcl 16-122 cobol_$minpral5_ptr external static pointer dcl 16-50 cobol_$misc_base_ptr external static pointer dcl 16-60 cobol_$misc_end_ptr external static pointer dcl 16-62 cobol_$misc_max external static fixed bin(17,0) dcl 16-158 cobol_$non_source_offset external static fixed bin(17,0) dcl 16-176 cobol_$ntbuf_ptr external static pointer dcl 16-82 cobol_$obj_seg_name external static char(32) dcl 16-208 cobol_$op_con_ptr external static pointer dcl 16-80 cobol_$para_eop_flag external static fixed bin(17,0) dcl 16-138 cobol_$pd_map_index external static fixed bin(17,0) dcl 16-116 cobol_$pd_map_max external static fixed bin(17,0) dcl 16-160 cobol_$pd_map_ptr external static pointer dcl 16-28 cobol_$pd_map_sw external static fixed bin(17,0) dcl 16-126 cobol_$perform_list_ptr external static pointer dcl 16-36 cobol_$perform_para_index external static fixed bin(17,0) dcl 16-148 cobol_$perform_sect_index external static fixed bin(17,0) dcl 16-150 cobol_$priority_no external static fixed bin(17,0) dcl 16-140 cobol_$ptr_assumption_ind external static fixed bin(17,0) dcl 16-144 cobol_$ptr_status_ptr external static pointer dcl 16-56 cobol_$reg_assumption_ind external static fixed bin(17,0) dcl 16-146 cobol_$reg_status_ptr external static pointer dcl 16-58 cobol_$reloc_def_base_ptr external static pointer dcl 16-20 cobol_$reloc_def_max external static fixed bin(24,0) dcl 16-108 cobol_$reloc_link_base_ptr external static pointer dcl 16-22 cobol_$reloc_link_max external static fixed bin(24,0) dcl 16-110 cobol_$reloc_sym_base_ptr external static pointer dcl 16-24 cobol_$reloc_sym_max external static fixed bin(24,0) dcl 16-112 cobol_$reloc_text_base_ptr external static pointer dcl 16-18 cobol_$reloc_text_max external static fixed bin(24,0) dcl 16-106 cobol_$reloc_work_base_ptr external static pointer dcl 16-26 cobol_$reloc_work_max external static fixed bin(24,0) dcl 16-114 cobol_$reswd_ptr external static pointer dcl 16-78 cobol_$same_sort_merge_proc external static bit(1) dcl 16-214 cobol_$scratch_dir external static char(168) dcl 16-206 cobol_$sect_eop_flag external static fixed bin(17,0) dcl 16-136 cobol_$seg_init_flag external static fixed bin(17,0) dcl 16-132 cobol_$seg_init_list_ptr external static pointer dcl 16-40 cobol_$stack_off external static fixed bin(17,0) dcl 16-120 cobol_$statement_info_ptr external static pointer dcl 16-76 cobol_$sym_base_ptr external static pointer dcl 16-16 cobol_$sym_max external static fixed bin(17,0) dcl 16-104 cobol_$sym_wd_off external static fixed bin(17,0) dcl 16-102 cobol_$tag_table_max external static fixed bin(17,0) dcl 16-166 cobol_$tag_table_ptr external static pointer dcl 16-52 cobol_$temp_token_area_ptr external static pointer dcl 16-42 cobol_$temp_token_max external static fixed bin(17,0) dcl 16-168 cobol_$temp_token_ptr external static pointer dcl 16-44 cobol_$text_base_ptr external static pointer dcl 16-8 cobol_$token_block1_ptr external static pointer dcl 16-46 cobol_$token_block2_ptr external static pointer dcl 16-48 cobol_$value_cnt external static fixed bin(17,0) dcl 16-194 cobol_$ws_charcnt external static fixed bin(17,0) dcl 16-186 cobol_$ws_wdoff external static fixed bin(17,0) dcl 16-200 cobol_$xref_bypass external static bit(1) dcl 16-212 cobol_$xref_chain_ptr external static pointer dcl 16-74 cobol_$xref_token_ptr external static pointer dcl 16-72 cobol_afp defined pointer dcl 18-11 cobol_analin_fileno defined pointer dcl 18-13 cobol_cmfp defined pointer dcl 18-21 cobol_com_fileno defined pointer dcl 18-23 cobol_curr_in defined pointer dcl 18-53 cobol_curr_out defined pointer dcl 18-55 cobol_data_wd_off defined fixed bin(17,0) dcl 16-119 cobol_dfp defined pointer dcl 18-27 cobol_eltp defined pointer dcl 18-19 cobol_ext_$cobol_afp external static pointer dcl 18-10 cobol_ext_$cobol_analin_fileno external static pointer dcl 18-12 cobol_ext_$cobol_cmfp external static pointer dcl 18-20 cobol_ext_$cobol_com_fileno external static pointer dcl 18-22 cobol_ext_$cobol_curr_in external static pointer dcl 18-52 cobol_ext_$cobol_curr_out external static pointer dcl 18-54 cobol_ext_$cobol_dfp external static pointer dcl 18-26 cobol_ext_$cobol_eltp external static pointer dcl 18-18 cobol_ext_$cobol_fileno1 external static fixed bin(24,0) dcl 18-78 cobol_ext_$cobol_hfp external static pointer dcl 18-28 cobol_ext_$cobol_lpr external static char(5) packed unaligned dcl 18-95 cobol_ext_$cobol_m1fp external static pointer dcl 18-30 cobol_ext_$cobol_m2fp external static pointer dcl 18-32 cobol_ext_$cobol_min1_fileno external static pointer dcl 18-34 cobol_ext_$cobol_min2_fileno_ptr external static pointer dcl 18-36 cobol_ext_$cobol_name_fileno external static pointer dcl 18-38 cobol_ext_$cobol_name_fileno_ptr external static pointer dcl 18-40 cobol_ext_$cobol_ntfp external static pointer dcl 18-42 cobol_ext_$cobol_options external static char(120) packed unaligned dcl 18-97 cobol_ext_$cobol_options_len external static fixed bin(24,0) dcl 18-80 cobol_ext_$cobol_pdofp external static pointer dcl 18-44 cobol_ext_$cobol_pdout_fileno external static fixed bin(24,0) dcl 18-82 cobol_ext_$cobol_pfp external static pointer dcl 18-46 cobol_ext_$cobol_print_fileno external static fixed bin(24,0) dcl 18-84 cobol_ext_$cobol_rm2fp external static pointer dcl 18-48 cobol_ext_$cobol_rmin2_fileno external static fixed bin(24,0) dcl 18-86 cobol_ext_$cobol_rmin2fp external static pointer dcl 18-50 cobol_ext_$cobol_rwdd external static pointer dcl 18-72 cobol_ext_$cobol_rwpd external static pointer dcl 18-74 cobol_ext_$cobol_sfp external static pointer dcl 18-56 cobol_ext_$cobol_w1p external static pointer dcl 18-58 cobol_ext_$cobol_w2p external static pointer dcl 18-60 cobol_ext_$cobol_w3p external static pointer dcl 18-62 cobol_ext_$cobol_w5p external static pointer dcl 18-64 cobol_ext_$cobol_w6p external static pointer dcl 18-66 cobol_ext_$cobol_w7p external static pointer dcl 18-68 cobol_ext_$cobol_x1_fileno external static fixed bin(24,0) dcl 18-88 cobol_ext_$cobol_x2_fileno external static fixed bin(24,0) dcl 18-90 cobol_ext_$cobol_x3_fileno external static fixed bin(24,0) dcl 18-92 cobol_ext_$cobol_x3fp external static pointer dcl 18-70 cobol_ext_$cobol_xlast8 external static bit(1) packed unaligned dcl 18-100 cobol_ext_$report_exists external static bit(1) packed unaligned dcl 18-102 cobol_ext_$report_first_token external static pointer dcl 18-14 cobol_ext_$report_last_token external static pointer dcl 18-16 cobol_fileno1 defined fixed bin(24,0) dcl 18-79 cobol_hfp defined pointer dcl 18-29 cobol_lpr defined char(5) packed unaligned dcl 18-96 cobol_m1fp defined pointer dcl 18-31 cobol_m2fp defined pointer dcl 18-33 cobol_min1_fileno defined pointer dcl 18-35 cobol_min2_fileno_ptr defined pointer dcl 18-37 cobol_name_fileno defined pointer dcl 18-39 cobol_name_fileno_ptr defined pointer dcl 18-41 cobol_ntfp defined pointer dcl 18-43 cobol_options defined char(120) packed unaligned dcl 18-98 cobol_options_len defined fixed bin(24,0) dcl 18-81 cobol_pdofp defined pointer dcl 18-45 cobol_pdout_fileno defined fixed bin(24,0) dcl 18-83 cobol_pfp defined pointer dcl 18-47 cobol_print_fileno defined fixed bin(24,0) dcl 18-85 cobol_rm2fp defined pointer dcl 18-49 cobol_rmin2_fileno defined fixed bin(24,0) dcl 18-87 cobol_rmin2fp defined pointer dcl 18-51 cobol_rwdd defined pointer dcl 18-73 cobol_rwpd defined pointer dcl 18-75 cobol_sfp defined pointer dcl 18-57 cobol_w1p defined pointer dcl 18-59 cobol_w2p defined pointer dcl 18-61 cobol_w3p defined pointer dcl 18-63 cobol_w5p defined pointer dcl 18-65 cobol_w6p defined pointer dcl 18-67 cobol_w7p defined pointer dcl 18-69 cobol_x1_fileno defined fixed bin(24,0) dcl 18-89 cobol_x2_fileno defined fixed bin(24,0) dcl 18-91 cobol_x3_fileno defined fixed bin(24,0) dcl 18-93 cobol_x3fp defined pointer dcl 18-71 cobol_xlast8 defined bit(1) packed unaligned dcl 18-101 compile_count defined fixed bin(17,0) dcl 16-143 coms_charcnt defined fixed bin(17,0) dcl 16-189 coms_wdoff defined fixed bin(17,0) dcl 16-203 con_end_ptr defined pointer dcl 16-11 con_wd_off defined fixed bin(17,0) dcl 16-93 cons_charcnt defined fixed bin(17,0) dcl 16-193 const_ptr automatic pointer dcl 147 constant_offset defined fixed bin(17,0) dcl 16-157 data_init_flag defined fixed bin(17,0) dcl 16-131 date_compiled_sw defined fixed bin(17,0) dcl 16-181 debug_enable defined fixed bin(17,0) dcl 16-175 def_base_ptr defined pointer dcl 16-13 def_max defined fixed bin(17,0) dcl 16-97 def_wd_off defined fixed bin(17,0) dcl 16-95 desc_an based structure level 1 packed packed unaligned dcl 19-103 desc_an_ptr automatic pointer dcl 19-119 desc_nn based structure level 1 packed packed unaligned dcl 19-122 desc_nn_ptr automatic pointer dcl 19-118 diag_ptr defined pointer dcl 16-71 dn_ptr automatic pointer dcl 246 eln_max defined fixed bin(17,0) dcl 16-173 eln_ptr defined pointer dcl 16-69 fixup_max defined fixed bin(17,0) dcl 16-165 fixup_ptr defined pointer dcl 16-31 fs_charcnt defined fixed bin(17,0) dcl 16-185 fs_wdoff defined fixed bin(17,0) dcl 16-199 include_cnt defined fixed bin(17,0) dcl 16-183 include_info_ptr defined pointer dcl 16-87 init_stack_off defined fixed bin(17,0) dcl 16-125 initval_base_ptr defined pointer dcl 16-33 initval_file_ptr defined pointer dcl 16-35 initval_flag defined fixed bin(17,0) dcl 16-179 link_base_ptr defined pointer dcl 16-15 link_max defined fixed bin(17,0) dcl 16-101 link_wd_off defined fixed bin(17,0) dcl 16-99 list_off defined fixed bin(17,0) dcl 16-155 list_ptr defined pointer dcl 16-65 ls_charcnt defined fixed bin(17,0) dcl 16-191 main_pcs_ptr defined pointer dcl 16-85 map_data_max defined fixed bin(17,0) dcl 16-163 map_data_ptr defined pointer dcl 16-55 max_stack_off defined fixed bin(17,0) dcl 16-123 microp_bits automatic structure level 1 dcl 208 minpral5_ptr defined pointer dcl 16-51 misc_base_ptr defined pointer dcl 16-61 misc_end_ptr defined pointer dcl 16-63 misc_max defined fixed bin(17,0) dcl 16-159 nchar automatic fixed bin(17,0) dcl 2688 new_char_off automatic fixed bin(17,0) dcl 2688 next_tag defined fixed bin(17,0) dcl 16-129 no_char2 automatic fixed bin(17,0) dcl 187 non_source_offset defined fixed bin(17,0) dcl 16-177 ntbuf_ptr defined pointer dcl 16-83 obj_seg_name defined char(32) dcl 16-209 op_con_ptr defined pointer dcl 16-81 para_eop_flag defined fixed bin(17,0) dcl 16-139 pd_map_index defined fixed bin(17,0) dcl 16-117 pd_map_max defined fixed bin(17,0) dcl 16-161 pd_map_ptr defined pointer dcl 16-29 pd_map_sw defined fixed bin(17,0) dcl 16-127 perform_list_ptr defined pointer dcl 16-37 perform_para_index defined fixed bin(17,0) dcl 16-149 perform_sect_index defined fixed bin(17,0) dcl 16-151 priority_no defined fixed bin(17,0) dcl 16-141 ptr_assumption_ind defined fixed bin(17,0) dcl 16-145 ptr_status_ptr defined pointer dcl 16-57 reg_assumption_ind defined fixed bin(17,0) dcl 16-147 reg_status_ptr defined pointer dcl 16-59 reloc_def_base_ptr defined pointer dcl 16-21 reloc_def_max defined fixed bin(24,0) dcl 16-109 reloc_link_base_ptr defined pointer dcl 16-23 reloc_link_max defined fixed bin(24,0) dcl 16-111 reloc_struc based structure array level 1 unaligned dcl 19-44 reloc_sym_base_ptr defined pointer dcl 16-25 reloc_sym_max defined fixed bin(24,0) dcl 16-113 reloc_text_base_ptr defined pointer dcl 16-19 reloc_text_max defined fixed bin(24,0) dcl 16-107 reloc_work_base_ptr defined pointer dcl 16-27 reloc_work_max defined fixed bin(24,0) dcl 16-115 report_exists defined bit(1) packed unaligned dcl 18-103 report_first_token defined pointer dcl 18-15 report_last_token defined pointer dcl 18-17 reswd_ptr defined pointer dcl 16-79 ret_offset automatic fixed bin(17,0) dcl 3396 same_sort_merge_proc defined bit(1) dcl 16-215 scratch_dir defined char(168) dcl 16-207 sect_eop_flag defined fixed bin(17,0) dcl 16-137 seg_init_flag defined fixed bin(17,0) dcl 16-133 seg_init_list_ptr defined pointer dcl 16-41 slash internal static char(1) initial packed unaligned dcl 133 stack_off defined fixed bin(17,0) dcl 16-121 statement_info_ptr defined pointer dcl 16-77 sym_base_ptr defined pointer dcl 16-17 sym_max defined fixed bin(17,0) dcl 16-105 sym_wd_off defined fixed bin(17,0) dcl 16-103 tag_table_max defined fixed bin(17,0) dcl 16-167 tag_table_ptr defined pointer dcl 16-53 temp_ptr automatic pointer dcl 3397 temp_token_area_ptr defined pointer dcl 16-43 temp_token_max defined fixed bin(17,0) dcl 16-169 temp_token_ptr defined pointer dcl 16-45 text_base_ptr defined pointer dcl 16-9 text_wd_off defined fixed bin(17,0) dcl 16-91 token_block1_ptr defined pointer dcl 16-47 token_block2_ptr defined pointer dcl 16-49 value_cnt defined fixed bin(17,0) dcl 16-195 ws_charcnt defined fixed bin(17,0) dcl 16-187 ws_wdoff defined fixed bin(17,0) dcl 16-201 xref_bypass defined bit(1) dcl 16-213 xref_chain_ptr defined pointer dcl 16-75 xref_token_ptr defined pointer dcl 16-73 NAMES DECLARED BY EXPLICIT CONTEXT. any_bin_dec 012756 constant entry internal dcl 3993 ref 2993 3048 begin 000213 constant label dcl 372 ref 322 bin_move_bin 012635 constant entry internal dcl 3948 ref 3412 3796 3837 3869 bin_same_bin 012260 constant entry internal dcl 3805 ref 3000 3060 binx 012437 constant label dcl 3874 ref 3838 build_litstr 007416 constant entry internal dcl 2752 ref 1166 1220 build_litstr_right_just 007547 constant entry internal dcl 2806 ref 1253 1271 calc_char_offset 007267 constant entry internal dcl 2660 ref 1415 1527 1532 3226 3617 4211 check_zero_move 015130 constant entry internal dcl 4703 ref 4568 4619 4658 ck_n_ne 001427 constant entry internal dcl 876 ref 781 870 ckx 001545 constant label dcl 949 ref 928 cmpn0_tnz 005532 constant entry internal dcl 2190 ref 1698 cobol_move_gen 000123 constant entry external dcl 47 dec_dec 010175 constant entry internal dcl 3122 ref 2936 2940 4078 4492 dec_dec_fix 014236 constant entry internal dcl 4375 ref 3569 4164 dec_lb 011210 constant entry internal dcl 3490 ref 2950 dec_sb 013157 constant entry internal dcl 4087 ref 2945 dec_source 007665 constant entry internal dcl 2906 ref 247 247 dec_zero 005436 constant entry internal dcl 2159 ref 2199 3162 3180 3555 4150 error 006212 constant entry internal dcl 2397 ref 428 726 1508 2124 es_on_ck_bz 006032 constant entry internal dcl 2310 ref 1834 1915 1988 gen_move_alpha 006323 constant entry internal dcl 2418 ref 544 850 854 980 1549 1721 1785 4540 gen_move_dec_numer 007011 constant entry internal dcl 2545 ref 3157 3164 3172 3182 3211 3234 4423 gen_move_edit 005355 constant entry internal dcl 2137 ref 1522 2129 gen_move_lit 006665 constant entry internal dcl 2515 ref 580 1171 gmx 006664 constant label dcl 2512 ref 2473 lb_sb 012174 constant entry internal dcl 3756 ref 3055 lb_source 010050 constant entry internal dcl 3017 ref 247 load_bin 012441 constant entry internal dcl 3877 ref 3785 3791 3844 3846 3858 3864 max 003432 constant label dcl 1553 ref 1510 mfcx 002553 constant label dcl 1297 ref 1148 1212 1233 mnx 005354 constant label dcl 2134 ref 1725 1754 1787 move_alpha 001546 constant entry internal dcl 967 ref 752 757 761 777 804 943 move_alpha_edit 002554 constant entry internal dcl 1300 ref 807 945 1231 move_done 000305 constant label dcl 434 ref 354 429 move_fig_con 001770 constant entry internal dcl 1134 ref 568 1085 1095 1106 1117 1126 move_fig_con_rw 001610 constant entry internal dcl 1044 ref 425 move_init 000306 constant entry internal dcl 437 ref 319 move_insert_chars 005700 constant entry internal dcl 2244 ref 1475 1847 2047 move_mult_micro_op 005651 constant entry internal dcl 2220 ref 1447 1467 1501 1863 1998 2041 2119 2270 2367 move_numer_ed 003433 constant entry internal dcl 1556 ref 883 1295 move_special 001255 constant entry internal dcl 818 ref 742 810 move_stack 000444 constant entry internal dcl 514 ref 389 move_type2 000702 constant entry internal dcl 619 ref 423 move_type3 000603 constant entry internal dcl 552 ref 420 move_type9 001124 constant entry internal dcl 719 ref 417 589 681 non_opch_to_opch 014323 constant entry internal dcl 4430 ref 2955 3010 3065 num_to_num 007630 constant entry internal dcl 2872 ref 541 880 1293 3354 4660 4693 num_to_udts 010467 constant entry internal dcl 3247 ref 926 1567 4577 opch_source 010140 constant entry internal dcl 3072 ref 247 opch_to_non_opch 014743 constant entry internal dcl 4629 ref 3107 opch_to_opch 014711 constant entry internal dcl 4592 ref 3116 opx 010173 constant label dcl 3119 ref 3114 replicate 007451 constant entry internal dcl 2779 ref 1146 1708 1752 sb_lb 010660 constant entry internal dcl 3363 ref 3005 sb_source 007760 constant entry internal dcl 2962 ref 247 sbx 011207 constant label dcl 3486 ref 3413 set_ips_type5_6 007152 constant entry internal dcl 2594 ref 2149 2204 2447 2533 2566 2791 3557 3652 3730 3967 4060 4152 4243 4355 setx 007265 constant label dcl 2657 ref 2630 start 012446 constant label dcl 3906 start_dec_dec 010202 constant label dcl 3148 start_dec_sb 013161 constant label dcl 4143 suppress 006064 constant entry internal dcl 2345 ref 1914 1950 target_1 000000 constant label array(5) dcl 2936 set ref 2934 target_2 000005 constant label array(5) dcl 2993 ref 2991 target_3 000012 constant label array(5) dcl 3048 ref 3046 target_4 000017 constant label array(5) dcl 3107 ref 3105 tgx 010136 constant label dcl 3068 in procedure "lb_source" ref 3053 3058 3063 tgx 007756 constant label dcl 2958 in procedure "dec_source" ref 2939 2943 2948 2953 tgx 010046 constant label dcl 3013 in procedure "sb_source" ref 2998 3003 3008 type_13_to_9 015404 constant entry internal dcl 4812 ref 377 383 NAMES DECLARED BY CONTEXT OR IMPLICATION. divide builtin function ref 2698 2703 2708 2729 2738 2738 mod builtin function ref 2698 2726 2738 2741 2838 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 16366 16540 15635 16376 Length 17534 15635 152 757 531 50 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_move_gen 1636 external procedure is an external procedure. move_init internal procedure shares stack frame of external procedure cobol_move_gen. move_stack internal procedure shares stack frame of external procedure cobol_move_gen. move_type3 internal procedure shares stack frame of external procedure cobol_move_gen. move_type2 internal procedure shares stack frame of external procedure cobol_move_gen. move_type9 internal procedure shares stack frame of external procedure cobol_move_gen. move_special internal procedure shares stack frame of external procedure cobol_move_gen. ck_n_ne internal procedure shares stack frame of external procedure cobol_move_gen. move_alpha internal procedure shares stack frame of external procedure cobol_move_gen. move_fig_con_rw internal procedure shares stack frame of external procedure cobol_move_gen. move_fig_con internal procedure shares stack frame of external procedure cobol_move_gen. move_alpha_edit internal procedure shares stack frame of external procedure cobol_move_gen. move_numer_ed internal procedure shares stack frame of external procedure cobol_move_gen. gen_move_edit internal procedure shares stack frame of external procedure cobol_move_gen. dec_zero 86 internal procedure is called by several nonquick procedures. cmpn0_tnz internal procedure shares stack frame of external procedure cobol_move_gen. move_mult_micro_op internal procedure shares stack frame of external procedure cobol_move_gen. move_insert_chars internal procedure shares stack frame of external procedure cobol_move_gen. es_on_ck_bz internal procedure shares stack frame of external procedure cobol_move_gen. suppress internal procedure shares stack frame of external procedure cobol_move_gen. error internal procedure shares stack frame of external procedure cobol_move_gen. gen_move_alpha 100 internal procedure is called by several nonquick procedures. gen_move_lit internal procedure shares stack frame of external procedure cobol_move_gen. gen_move_dec_numer 80 internal procedure is called by several nonquick procedures. set_ips_type5_6 65 internal procedure is called by several nonquick procedures. calc_char_offset 68 internal procedure is called by several nonquick procedures. build_litstr internal procedure shares stack frame of external procedure cobol_move_gen. replicate internal procedure shares stack frame of external procedure cobol_move_gen. build_litstr_right_just internal procedure shares stack frame of external procedure cobol_move_gen. num_to_num 80 internal procedure is called by several nonquick procedures. dec_source 250 internal procedure is assigned to an entry variable. sb_source 116 internal procedure is assigned to an entry variable. lb_source 102 internal procedure is assigned to an entry variable. opch_source 128 internal procedure is assigned to an entry variable. dec_dec 76 internal procedure is called by several nonquick procedures. num_to_udts 82 internal procedure is called by several nonquick procedures. sb_lb internal procedure shares stack frame of internal procedure sb_source. dec_lb internal procedure shares stack frame of internal procedure dec_source. lb_sb internal procedure shares stack frame of internal procedure lb_source. bin_same_bin 76 internal procedure is called by several nonquick procedures. load_bin 75 internal procedure is called by several nonquick procedures. bin_move_bin 80 internal procedure is called by several nonquick procedures. any_bin_dec 94 internal procedure is called by several nonquick procedures. dec_sb internal procedure shares stack frame of internal procedure dec_source. dec_dec_fix internal procedure shares stack frame of internal procedure dec_source. non_opch_to_opch 320 internal procedure is called by several nonquick procedures. opch_to_opch internal procedure shares stack frame of internal procedure opch_source. opch_to_non_opch internal procedure shares stack frame of internal procedure opch_source. check_zero_move 92 internal procedure is called by several nonquick procedures. type_13_to_9 internal procedure shares stack frame of external procedure cobol_move_gen. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 MVE cobol_move_gen 000011 MVNE cobol_move_gen 000012 MLR cobol_move_gen 000013 MRL cobol_move_gen 000014 msg_1 cobol_move_gen 000022 msg_2 cobol_move_gen 000030 move_num cobol_move_gen 000031 nc_move_num cobol_move_gen 000032 ival_num cobol_move_gen 000033 control_no cobol_move_gen 000034 stz_inst cobol_move_gen 000035 move_special_bit cobol_move_gen 000036 ne_bit cobol_move_gen 000037 shift_inst sb_lb 000040 long_binary_mask dec_lb 000042 reg_struc load_bin 000053 arl_18_inst dec_sb 000054 short_binary_mask dec_sb 000055 bin_zero check_zero_move 000056 dec_zero check_zero_move STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME any_bin_dec 000100 dec_temp_size any_bin_dec 000101 ret_offset any_bin_dec 000102 dec_tkn_ptr any_bin_dec 000104 temp_result any_bin_dec bin_same_bin 000100 j bin_same_bin calc_char_offset 000100 curr_char_off calc_char_offset 000101 nword calc_char_offset 000102 tlength calc_char_offset check_zero_move 000100 const_ptr check_zero_move 000102 const_offset check_zero_move 000103 const_length check_zero_move 000104 temp_ptr check_zero_move cobol_move_gen 000100 instr cobol_move_gen 000102 save_sf_ptr cobol_move_gen 000104 save_rf_ptr cobol_move_gen 000106 m cobol_move_gen 000107 n cobol_move_gen 000110 n_rf cobol_move_gen 000111 pl cobol_move_gen 000112 pr cobol_move_gen 000113 size cobol_move_gen 000114 delta cobol_move_gen 000115 lin cobol_move_gen 000116 col cobol_move_gen 000117 spl cobol_move_gen 000120 spr cobol_move_gen 000121 rpl cobol_move_gen 000122 rpr cobol_move_gen 000123 fx cobol_move_gen 000124 fl cobol_move_gen 000126 sf_ptr cobol_move_gen 000130 rf_ptr cobol_move_gen 000132 stk_offset cobol_move_gen 000133 cs_offset cobol_move_gen 000134 lit_str cobol_move_gen 000234 lit_ln cobol_move_gen 000235 idx cobol_move_gen 000236 req_ln cobol_move_gen 000237 sf_stack_sw cobol_move_gen 000240 sf_category_sw cobol_move_gen 000241 ecm cobol_move_gen 000342 ecm_ptr cobol_move_gen 000344 ecm_lnth cobol_move_gen 000345 n_ecm cobol_move_gen 000346 mop cobol_move_gen 000446 mop_ptr cobol_move_gen 000450 n_mop cobol_move_gen 000451 bwz cobol_move_gen 000452 awz cobol_move_gen 000453 asterisk cobol_move_gen 000454 sign cobol_move_gen 000455 tag cobol_move_gen 000456 obj_dec_pt_char cobol_move_gen 000457 currency_char cobol_move_gen 000460 start_supp cobol_move_gen 000461 max_supp cobol_move_gen 000462 end_supp cobol_move_gen 000463 supp_char cobol_move_gen 000464 es_status cobol_move_gen 000465 bz_status cobol_move_gen 000466 insert_table_status cobol_move_gen 000470 no_chars cobol_move_gen 000471 no_char1 cobol_move_gen 000472 count cobol_move_gen 000473 insert_char_no cobol_move_gen 000474 micro_op cobol_move_gen 000475 insrt_op cobol_move_gen 000476 end_fix cobol_move_gen 000477 rf_st cobol_move_gen 000500 right_adjust cobol_move_gen 000501 left_adjust cobol_move_gen 000502 overlap cobol_move_gen 000503 sf_places cobol_move_gen 000504 rf_places cobol_move_gen 000505 rf_length cobol_move_gen 000506 rf_temp_sw cobol_move_gen 000507 opnd_ln cobol_move_gen 000510 ecm_limit cobol_move_gen 000511 set_ptr_struc cobol_move_gen 000520 eis_ cobol_move_gen 000524 ips cobol_move_gen 000546 reloc_info cobol_move_gen 000556 new_sf_ptr cobol_move_gen 000560 new_sf_tkn cobol_move_gen 000756 ms_ptr cobol_move_gen 000760 ms_tkn cobol_move_gen 001042 sf_cpy_ptr cobol_move_gen 001044 sf_tkn_cpy cobol_move_gen 001242 rf_cpy_ptr cobol_move_gen 001244 rf_tkn_cpy cobol_move_gen 001442 temp_tkn_ptr cobol_move_gen 001444 temp_tkn cobol_move_gen 001526 numeric_source_proc cobol_move_gen 001552 return_code cobol_move_gen 001554 work_sf_ptr cobol_move_gen 001556 ret_offset cobol_move_gen 001557 only_an cobol_move_gen 001560 temp cobol_move_gen 001561 numeric_lit_flag cobol_move_gen 001562 in_op cobol_move_gen 001563 SF_dn cobol_move_gen 001627 RF_dn cobol_move_gen 001674 rw_ptr cobol_move_gen 001676 nlit_ptr cobol_move_gen 001700 alit_ptr cobol_move_gen 001702 eos_ptr cobol_move_gen 001704 edit_ptr cobol_move_gen 001706 input_ptr cobol_move_gen 001710 inst_ptr cobol_move_gen 001712 reloc_ptr cobol_move_gen 002114 error_info error 002177 ioa_str error 002244 work_string build_litstr_right_just 002256 whole_string_count build_litstr_right_just 002257 remainder_count build_litstr_right_just 002260 curr_char build_litstr_right_just 002261 ix build_litstr_right_just 002272 length type_13_to_9 dec_source 000100 work_sf_ptr dec_source 000102 work_rf_ptr dec_source 000104 rf_code dec_source 000114 bump dec_lb 000115 ret_offset dec_lb 000116 reg_load_struc dec_lb 000127 temp_inst dec_lb 000130 temp_inst_ptr dec_lb 000132 temp_reloc dec_lb 000134 long_bin_limit dec_lb 000136 temp_reloc_ptr dec_lb 000140 mask_ptr dec_lb 000142 const_offset dec_lb 000144 bin_tkn_ptr dec_lb 000154 temp_inst dec_sb 000156 temp_inst_ptr dec_sb 000160 temp_reloc dec_sb 000166 temp_reloc_ptr dec_sb 000170 short_bin_limit dec_sb 000172 shift_inst_ptr dec_sb 000174 reg_load_struc dec_sb 000201 ret_offset dec_sb 000202 const_offset dec_sb 000204 mask_ptr dec_sb 000206 bin_tkn_ptr dec_sb 000210 bump dec_sb 000220 ret_offset dec_dec_fix dec_zero 000100 cs_offset dec_zero gen_move_alpha 000100 len gen_move_alpha lb_source 000100 work_sf_ptr lb_source 000102 work_rf_ptr lb_source 000104 rf_code lb_source 000114 j lb_sb non_opch_to_opch 000100 temp_sf_ptr non_opch_to_opch 000102 return_code non_opch_to_opch 000104 udts_token_ptr non_opch_to_opch 000106 temp_rf_ptr non_opch_to_opch 000110 move_char non_opch_to_opch 000111 temp_len non_opch_to_opch 000112 temp_ptr non_opch_to_opch 000114 temp_space non_opch_to_opch 000213 temp_sign_type non_opch_to_opch 000214 move_digit non_opch_to_opch 000216 an_ptr non_opch_to_opch 000220 al_lit non_opch_to_opch num_to_num 000100 sf_code num_to_num num_to_udts 000100 ret_offset num_to_udts opch_source 000100 work_sf_ptr opch_source 000102 work_rf_ptr opch_source 000104 rf_code opch_source 000114 temp_sf_ptr opch_to_opch 000124 char_offset opch_to_non_opch 000126 temp_sf_ptr opch_to_non_opch 000130 temp_rf_ptr opch_to_non_opch sb_source 000100 work_sf_ptr sb_source 000102 work_rf_ptr sb_source 000104 rf_code sb_source 000114 source_reloc sb_lb 000116 reg_load_struc sb_lb THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_char_temp call_ent_var call_ext_out_desc call_ext_out call_int_this call_int_other return_mac mpfx2 mdfx1 shorten_stack ext_entry int_entry trunc_fx2 verify_eis any_to_any_truncate_divide_fx1 THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_addr cobol_alloc$stack cobol_define_tag cobol_emit cobol_get_num_code cobol_io_util$move cobol_io_util$move_lit cobol_make_bin_const cobol_make_tagref cobol_make_type9$alphanumeric cobol_make_type9$copy cobol_make_type9$copy_sub cobol_make_type9$decimal_9bit cobol_make_type9$long_bin cobol_make_type9$short_bin cobol_make_type9$type2_3 cobol_opch_op_call cobol_pool cobol_pool$search_op cobol_register$load cobol_register$release cobol_set_pr ioa_$rsnnl signal_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. cobol_$compile_count cobol_$main_pcs_ptr cobol_$next_tag cobol_$text_wd_off cobol_ext_$cobol_com_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 47 000120 247 000130 319 000166 322 000167 336 000170 339 000171 342 000174 343 000177 346 000201 349 000203 350 000206 354 000210 372 000213 374 000222 377 000224 383 000234 389 000244 417 000250 420 000256 423 000262 425 000266 428 000272 429 000303 432 000304 434 000305 437 000306 440 000307 443 000313 444 000314 447 000316 449 000317 452 000326 453 000330 454 000332 456 000334 458 000341 461 000342 462 000344 463 000346 464 000350 465 000352 480 000353 481 000360 483 000366 486 000371 487 000373 488 000375 489 000376 491 000377 492 000401 493 000403 494 000405 495 000407 496 000411 497 000413 498 000415 499 000417 500 000421 501 000423 502 000424 503 000425 505 000426 507 000436 509 000440 511 000443 514 000444 517 000445 522 000471 523 000473 525 000475 527 000511 530 000517 531 000521 532 000523 533 000525 535 000527 538 000532 541 000543 543 000553 544 000554 546 000577 549 000602 552 000603 555 000604 557 000606 565 000612 566 000614 568 000617 570 000620 572 000621 578 000636 580 000640 582 000663 585 000664 587 000675 589 000700 595 000701 619 000702 622 000703 627 000705 628 000711 629 000714 631 000717 634 000741 639 000762 640 000764 641 000770 642 000772 643 000774 644 000776 646 001000 648 001002 651 001007 652 001011 654 001013 655 001016 657 001021 660 001027 661 001031 662 001035 663 001036 664 001042 667 001043 668 001045 671 001051 673 001105 675 001115 677 001120 681 001122 685 001123 719 001124 724 001125 726 001133 729 001151 732 001156 735 001161 738 001163 741 001166 742 001170 744 001171 748 001172 749 001174 750 001176 752 001200 755 001201 757 001202 759 001203 761 001204 763 001205 765 001206 768 001211 772 001216 773 001220 777 001222 779 001223 781 001224 788 001230 796 001233 797 001235 798 001237 804 001241 807 001246 810 001253 816 001254 818 001255 822 001256 835 001274 838 001312 840 001314 845 001337 848 001342 850 001343 852 001365 854 001366 856 001410 864 001412 865 001414 866 001417 867 001421 868 001423 870 001425 874 001426 876 001427 880 001430 883 001445 901 001452 905 001460 908 001472 911 001473 912 001474 915 001475 926 001506 928 001520 935 001522 938 001530 939 001531 940 001534 943 001536 945 001544 949 001545 967 001546 971 001547 973 001560 980 001565 984 001607 1044 001610 1055 001611 1056 001613 1058 001615 1065 001621 1069 001632 1070 001634 1071 001636 1072 001637 1073 001641 1074 001643 1076 001645 1078 001664 1080 001705 1084 001706 1085 001710 1088 001711 1090 001712 1093 001714 1095 001716 1097 001717 1099 001720 1102 001722 1104 001735 1106 001737 1108 001740 1110 001741 1113 001743 1115 001756 1117 001760 1119 001761 1123 001762 1126 001766 1132 001767 1134 001770 1139 001771 1143 002007 1146 002012 1148 002013 1152 002014 1156 002016 1160 002022 1161 002036 1163 002042 1164 002043 1166 002044 1168 002045 1171 002054 1173 002057 1176 002060 1178 002113 1179 002116 1180 002117 1182 002120 1184 002133 1186 002141 1188 002143 1189 002161 1190 002165 1191 002167 1192 002171 1193 002175 1194 002177 1197 002201 1199 002217 1200 002221 1202 002224 1204 002231 1206 002235 1208 002237 1212 002256 1215 002257 1218 002267 1220 002271 1222 002272 1224 002326 1226 002334 1228 002336 1230 002353 1231 002355 1233 002356 1236 002357 1237 002361 1239 002363 1242 002366 1245 002370 1248 002372 1249 002374 1250 002375 1251 002376 1253 002400 1255 002401 1258 002402 1259 002404 1261 002407 1264 002410 1267 002412 1269 002417 1271 002421 1273 002422 1274 002423 1275 002424 1279 002434 1281 002472 1283 002500 1285 002502 1287 002521 1288 002523 1289 002526 1290 002530 1291 002532 1293 002535 1295 002552 1297 002553 1300 002554 1304 002555 1305 002557 1306 002561 1307 002565 1308 002570 1309 002572 1311 002575 1312 002600 1313 002602 1315 002604 1319 002611 1321 002613 1323 002627 1326 002635 1327 002636 1328 002637 1329 002642 1330 002644 1331 002646 1334 002650 1338 002657 1341 002665 1344 002666 1347 002671 1348 002672 1349 002674 1351 002702 1353 002703 1355 002720 1358 002725 1360 002735 1361 002740 1363 002741 1367 002745 1369 002747 1371 002764 1374 002771 1375 002774 1377 002775 1379 002777 1382 003001 1383 003002 1384 003012 1387 003017 1388 003022 1390 003023 1393 003026 1394 003027 1395 003030 1399 003031 1402 003035 1403 003036 1404 003041 1408 003042 1409 003045 1412 003046 1415 003051 1418 003063 1419 003066 1420 003067 1421 003070 1429 003071 1430 003072 1431 003074 1433 003075 1434 003100 1435 003102 1437 003105 1439 003113 1441 003114 1444 003116 1445 003117 1447 003121 1451 003122 1452 003126 1454 003135 1456 003152 1458 003160 1459 003162 1461 003164 1464 003170 1465 003171 1467 003173 1469 003174 1473 003175 1475 003177 1479 003200 1480 003204 1482 003206 1484 003210 1485 003213 1486 003214 1489 003217 1490 003222 1491 003223 1493 003224 1495 003226 1498 003230 1499 003231 1501 003233 1505 003234 1508 003237 1510 003245 1514 003246 1516 003301 1518 003304 1520 003324 1522 003326 1524 003343 1527 003345 1529 003355 1532 003360 1534 003370 1535 003372 1539 003373 1541 003374 1544 003377 1545 003402 1546 003403 1547 003405 1549 003407 1553 003432 1556 003433 1560 003434 1565 003454 1567 003456 1569 003470 1572 003472 1573 003475 1574 003477 1575 003502 1577 003504 1578 003506 1580 003510 1583 003512 1584 003515 1585 003520 1586 003522 1587 003524 1588 003526 1589 003530 1590 003532 1591 003535 1595 003536 1596 003541 1598 003545 1601 003547 1602 003551 1603 003553 1604 003557 1605 003560 1609 003561 1611 003565 1614 003567 1615 003571 1616 003572 1617 003576 1618 003577 1621 003600 1622 003601 1623 003602 1626 003603 1628 003607 1629 003612 1630 003615 1633 003617 1637 003625 1639 003630 1642 003631 1643 003632 1644 003635 1648 003642 1652 003643 1656 003651 1658 003654 1661 003655 1662 003656 1663 003663 1668 003666 1670 003677 1673 003704 1674 003707 1677 003710 1679 003712 1680 003721 1683 003726 1684 003731 1686 003732 1688 003735 1689 003742 1690 003746 1691 003752 1695 003756 1698 003761 1701 003764 1703 003776 1706 003777 1708 004001 1710 004002 1713 004003 1714 004006 1716 004011 1718 004041 1720 004044 1721 004063 1725 004106 1729 004110 1731 004112 1732 004131 1734 004140 1735 004143 1737 004144 1744 004163 1747 004165 1750 004170 1752 004172 1754 004173 1757 004174 1760 004176 1762 004204 1764 004206 1767 004217 1769 004222 1771 004224 1776 004233 1778 004270 1780 004276 1782 004300 1784 004302 1785 004317 1787 004342 1793 004343 1794 004344 1795 004345 1796 004347 1797 004351 1801 004352 1804 004355 1805 004357 1806 004361 1809 004362 1812 004365 1815 004370 1816 004372 1817 004374 1818 004375 1820 004377 1821 004401 1822 004403 1825 004404 1828 004406 1834 004410 1836 004411 1838 004421 1840 004435 1842 004442 1844 004444 1845 004446 1847 004450 1849 004451 1850 004455 1852 004457 1857 004461 1860 004463 1861 004464 1863 004466 1867 004467 1871 004474 1872 004501 1873 004502 1874 004504 1877 004505 1880 004510 1881 004515 1882 004516 1887 004517 1890 004523 1891 004530 1892 004535 1893 004537 1898 004541 1901 004543 1904 004546 1905 004550 1906 004552 1910 004553 1911 004555 1914 004557 1915 004560 1916 004561 1919 004562 1921 004563 1924 004565 1927 004570 1928 004575 1929 004602 1930 004604 1932 004606 1933 004610 1937 004611 1940 004613 1941 004620 1942 004625 1943 004627 1945 004631 1948 004633 1950 004635 1952 004636 1956 004643 1958 004654 1960 004661 1961 004662 1962 004664 1965 004665 1968 004667 1970 004700 1972 004705 1973 004706 1977 004710 1982 004713 1988 004714 1992 004715 1995 004717 1996 004720 1998 004722 2005 004723 2007 004732 2009 004742 2011 004744 2013 004753 2014 004770 2016 004776 2018 005000 2020 005002 2023 005006 2026 005011 2028 005031 2032 005036 2033 005043 2034 005050 2035 005052 2039 005054 2041 005056 2042 005057 2045 005060 2047 005062 2050 005063 2051 005067 2055 005071 2059 005100 2060 005105 2061 005112 2062 005114 2064 005116 2067 005120 2068 005122 2069 005123 2075 005125 2078 005130 2079 005135 2080 005137 2081 005144 2083 005146 2084 005155 2085 005162 2086 005170 2087 005172 2090 005174 2093 005177 2094 005204 2097 005205 2100 005210 2103 005213 2104 005220 2107 005221 2108 005226 2113 005227 2116 005231 2117 005232 2119 005234 2124 005235 2127 005246 2128 005302 2129 005325 2131 005342 2134 005354 2137 005355 2146 005357 2147 005360 2149 005365 2151 005404 2153 005417 2157 005434 2159 005435 2171 005443 2173 005472 2175 005500 2176 005502 2177 005510 2178 005512 2179 005514 2180 005516 2181 005520 2182 005522 2183 005524 2184 005525 2185 005527 2188 005531 2190 005532 2199 005533 2201 005541 2202 005542 2204 005546 2206 005566 2208 005603 2209 005606 2210 005607 2212 005612 2214 005630 2218 005650 2220 005651 2228 005652 2230 005654 2232 005661 2234 005666 2235 005670 2236 005675 2238 005676 2242 005677 2244 005700 2255 005701 2258 005704 2261 005711 2262 005716 2263 005723 2264 005726 2268 005730 2270 005732 2272 005733 2276 005734 2278 005746 2282 005753 2283 005760 2284 005765 2285 005767 2286 005771 2290 005773 2292 006003 2293 006010 2294 006015 2296 006016 2299 006020 2300 006026 2303 006027 2308 006031 2310 006032 2320 006033 2324 006040 2325 006045 2326 006046 2327 006050 2331 006051 2334 006053 2335 006060 2336 006061 2343 006063 2345 006064 2357 006065 2359 006075 2361 006112 2363 006123 2365 006125 2367 006127 2372 006134 2374 006145 2376 006155 2377 006162 2378 006167 2380 006170 2383 006172 2384 006200 2387 006201 2390 006203 2391 006207 2395 006211 2397 006212 2406 006223 2410 006226 2412 006231 2414 006271 2416 006321 2418 006322 2444 006330 2445 006332 2447 006340 2449 006361 2451 006375 2455 006420 2466 006464 2473 006531 2480 006532 2482 006535 2487 006553 2491 006557 2493 006573 2495 006604 2497 006607 2501 006616 2502 006627 2503 006631 2504 006633 2505 006635 2509 006641 2512 006664 2515 006665 2531 006676 2533 006677 2535 006721 2537 006736 2543 007006 2545 007010 2563 007016 2564 007020 2566 007024 2568 007046 2570 007062 2573 007073 2576 007106 2579 007114 2582 007120 2583 007124 2584 007130 2585 007132 2588 007133 2592 007150 2594 007151 2613 007157 2616 007163 2617 007166 2618 007171 2620 007172 2621 007175 2622 007177 2623 007200 2625 007201 2626 007204 2627 007207 2628 007210 2630 007211 2633 007212 2636 007214 2637 007217 2638 007222 2640 007223 2641 007226 2642 007230 2643 007231 2645 007245 2646 007251 2647 007253 2648 007254 2650 007255 2651 007260 2652 007263 2653 007264 2657 007265 2660 007266 2695 007274 2698 007302 2700 007312 2703 007315 2704 007320 2705 007324 2708 007325 2709 007333 2711 007335 2713 007336 2718 007341 2720 007344 2726 007350 2729 007355 2735 007360 2738 007363 2741 007402 2742 007406 2744 007412 2746 007413 2750 007415 2752 007416 2762 007417 2765 007422 2767 007431 2769 007436 2771 007441 2777 007450 2779 007451 2789 007452 2791 007453 2793 007474 2795 007511 2796 007517 2797 007521 2798 007525 2800 007530 2804 007546 2806 007547 2834 007550 2838 007557 2840 007562 2842 007564 2845 007566 2847 007576 2851 007600 2854 007602 2856 007611 2857 007616 2859 007620 2865 007622 2869 007626 2872 007627 2895 007635 2899 007646 2903 007663 2906 007664 2929 007672 2930 007676 2932 007701 2934 007711 2936 007713 2939 007724 2940 007725 2943 007736 2945 007737 2948 007741 2950 007742 2953 007744 2955 007745 2958 007756 2962 007757 2982 007765 2983 007771 2987 007774 2991 010004 2993 010006 2998 010017 3000 010020 3003 010031 3005 010032 3008 010034 3010 010035 3013 010046 3017 010047 3037 010055 3038 010061 3042 010064 3046 010074 3048 010076 3053 010107 3055 010110 3058 010112 3060 010113 3063 010124 3065 010125 3068 010136 3072 010137 3097 010145 3098 010151 3102 010154 3105 010164 3107 010166 3114 010170 3116 010171 3119 010173 3122 010174 3148 010202 3150 010210 3151 010212 3152 010216 3154 010220 3157 010222 3162 010236 3164 010245 3168 010260 3172 010261 3177 010275 3180 010300 3182 010307 3184 010322 3189 010323 3192 010330 3194 010332 3197 010347 3200 010360 3201 010362 3203 010366 3205 010370 3206 010372 3211 010374 3213 010405 3219 010413 3222 010423 3226 010424 3228 010440 3229 010446 3231 010450 3234 010454 3244 010465 3247 010466 3291 010474 3295 010476 3301 010525 3306 010536 3307 010540 3308 010542 3309 010544 3310 010546 3314 010552 3315 010554 3316 010556 3320 010560 3323 010563 3324 010565 3325 010566 3326 010570 3328 010571 3331 010574 3332 010576 3333 010577 3334 010601 3336 010602 3340 010606 3347 010621 3349 010637 3350 010644 3354 010646 3360 010657 3363 010660 3409 010662 3412 010674 3413 010706 3419 010707 3420 010711 3422 010712 3423 010714 3424 010717 3425 010720 3426 010721 3428 010723 3432 010740 3433 010742 3434 010744 3436 010745 3440 010756 3442 010767 3444 010774 3446 011013 3452 011022 3454 011033 3456 011040 3462 011060 3464 011071 3466 011076 3471 011116 3473 011124 3476 011141 3478 011152 3480 011157 3484 011176 3486 011207 3490 011210 3549 011212 3550 011217 3552 011221 3555 011223 3557 011232 3559 011255 3561 011271 3563 011276 3565 011313 3569 011314 3575 011341 3596 011342 3598 011352 3600 011354 3603 011356 3607 011363 3608 011365 3611 011404 3615 011415 3617 011422 3619 011433 3621 011437 3624 011450 3628 011452 3633 011456 3635 011475 3638 011500 3640 011502 3643 011517 3645 011522 3648 011523 3652 011527 3654 011551 3656 011565 3658 011572 3660 011607 3664 011614 3668 011617 3671 011645 3674 011650 3675 011652 3676 011654 3677 011657 3678 011661 3679 011664 3680 011666 3683 011670 3686 011703 3687 011705 3688 011706 3690 011707 3693 011720 3695 011724 3699 011741 3701 011751 3703 011754 3705 011756 3708 011771 3710 011776 3713 012013 3715 012017 3718 012034 3720 012040 3724 012055 3725 012060 3726 012062 3727 012064 3728 012071 3730 012073 3732 012114 3734 012130 3736 012137 3740 012153 3741 012160 3747 012162 3753 012173 3756 012174 3782 012176 3785 012203 3787 012216 3789 012230 3791 012232 3793 012243 3796 012244 3802 012256 3805 012257 3834 012265 3837 012305 3838 012316 3841 012317 3844 012322 3846 012335 3848 012351 3851 012352 3854 012356 3856 012365 3858 012367 3860 012400 3862 012412 3864 012414 3866 012425 3869 012426 3874 012437 3877 012440 3906 012446 3908 012451 3909 012454 3910 012455 3911 012461 3913 012463 3915 012475 3917 012505 3920 012514 3922 012523 3925 012526 3927 012537 3930 012554 3932 012572 3935 012573 3938 012605 3940 012622 3946 012633 3948 012634 3960 012642 3961 012647 3962 012651 3963 012655 3967 012657 3971 012700 3976 012714 3980 012723 3983 012737 3984 012744 3985 012746 3986 012752 3990 012754 3993 012755 4026 012763 4031 012764 4033 012775 4035 012777 4039 013005 4043 013023 4045 013025 4050 013051 4052 013056 4054 013060 4056 013061 4060 013062 4064 013104 4068 013120 4072 013125 4078 013142 4084 013156 4087 013157 4143 013161 4145 013166 4147 013170 4150 013172 4152 013201 4154 013224 4156 013240 4158 013245 4160 013262 4164 013263 4168 013303 4189 013304 4191 013314 4193 013316 4197 013320 4200 013325 4202 013327 4205 013346 4209 013357 4211 013364 4213 013375 4215 013401 4218 013412 4223 013414 4229 013420 4233 013436 4235 013440 4237 013455 4239 013456 4243 013462 4245 013504 4247 013520 4249 013525 4252 013542 4257 013547 4259 013552 4261 013577 4263 013605 4267 013607 4269 013611 4273 013630 4274 013632 4276 013634 4277 013637 4278 013641 4279 013642 4280 013645 4281 013647 4284 013651 4288 013664 4289 013666 4290 013667 4292 013670 4296 013701 4298 013711 4300 013715 4304 013732 4305 013737 4307 013741 4309 013754 4311 013765 4313 013772 4318 014007 4320 014017 4322 014023 4326 014040 4328 014043 4330 014053 4332 014057 4336 014075 4338 014105 4340 014111 4346 014126 4348 014131 4349 014133 4350 014135 4352 014137 4353 014144 4355 014146 4357 014167 4359 014203 4361 014212 4363 014226 4364 014233 4372 014235 4375 014236 4405 014240 4409 014261 4414 014272 4415 014274 4416 014277 4417 014300 4418 014304 4419 014306 4423 014310 4427 014321 4430 014322 4479 014330 4483 014334 4486 014345 4487 014346 4488 014347 4489 014351 4490 014355 4492 014357 4494 014370 4496 014372 4499 014375 4506 014416 4510 014417 4518 014440 4520 014452 4522 014465 4524 014471 4525 014473 4526 014475 4527 014477 4528 014501 4529 014503 4530 014505 4531 014507 4532 014511 4533 014513 4535 014515 4537 014526 4538 014531 4540 014533 4542 014557 4545 014562 4549 014575 4553 014602 4555 014606 4557 014623 4558 014626 4559 014630 4560 014632 4562 014637 4568 014640 4570 014651 4573 014656 4577 014660 4579 014673 4581 014674 4583 014676 4589 014710 4592 014711 4614 014713 4619 014716 4622 014730 4626 014742 4629 014743 4656 014745 4658 014750 4660 014762 4665 015001 4672 015013 4675 015033 4677 015035 4683 015067 4685 015074 4687 015075 4690 015076 4693 015110 4700 015126 4703 015127 4744 015135 4748 015150 4751 015160 4753 015162 4755 015167 4757 015171 4760 015224 4762 015233 4764 015235 4766 015237 4770 015263 4772 015300 4774 015303 4778 015304 4780 015306 4782 015333 4784 015341 4788 015343 4790 015345 4795 015374 4796 015401 4804 015403 4812 015404 4821 015406 4823 015416 4825 015422 4827 015427 4828 015432 4829 015434 4830 015436 4832 015440 4833 015442 4834 015443 4836 015444 4837 015446 4838 015450 4839 015452 4841 015454 4842 015456 4844 015460 4846 015462 4847 015463 4849 015466 4851 015467 ----------------------------------------------------------- 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