COMPILATION LISTING OF SEGMENT cobol_store_binary 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 0953.4 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_store_binary.pl1 Added Trace statements. 19* END HISTORY COMMENTS */ 20 21 22 /* Modified on 11/16/84 by FCH, [5.3...], trace added */ 23 /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ 24 /* Modified on 02/22/77 by Bob Chang to fix the bug for reloc bits. */ 25 /* Modified on 01/17/77 by ORN to call cobol_make_reg_token instead of cobol_make_register_token */ 26 /* Modified since Version 2.0 */ 27 28 29 30 31 32 /* format: style3 */ 33 cobol_store_binary: 34 proc (source_ptr, target_ptr, call_again); /* 35*This procedure generates code to store a fixed vinary datum inot 36*another fixed binary datum, in the arithmetic (as opposed to 37*the Cobol MOVE) sense. 38**/ 39 40 /* DECLARATION OF THE PARAMETERS */ 41 42 dcl source_ptr ptr; 43 dcl target_ptr ptr; 44 dcl call_again bit (1); 45 46 /* DESCRIPTION OF THE PARAMETERS */ 47 48 /* 49*PARAMETER DESCRIPTION 50* 51*source_ptr Pointer to a token that describes the 52* value to be stored. (input) The source 53* can be in one of the following places: 54* a. index register (short binary value) 55* b. A or Q (long binary value) 56* c. A and Q (result of multiplication) 57* d. in a data item (long or short binary) 58* e. in an immediate constant token (type 102) 59* 60*target_ptr Pointer to the data name token of the 61* target. (input) The target is always either 62* a long binary or short binary datum. 63* 64*call_again A flag that is set to "1"b by this procedure 65* if the calling procedure should call this 66* procedure again to store the result into 67* the target. This flag will be set only 68* when the size of the source is greater 69* than the size of the target, and 70* code has been generated to move the source 71* into a temporary, in order to force overflow. 72* Under these circumstances, the input parameter 73* source_ptr is set to a token that describes 74* the temporary, and call_again is set to 75* "1"b. A subsequent call to this procedure, 76* with no additional changes to the input 77* parameters by the calling procedure, will 78* then generate code to move the temporary, 79* (which is now of the same size as the target) 80* into the target. 81* 82**/ 83 84 /* DECLARATION OF EXTERNAL ENTRIES */ 85 86 dcl cobol_addr ext entry (ptr, ptr, ptr); 87 dcl cobol_emit ext entry (ptr, ptr, fixed bin); 88 dcl cobol_make_reg_token 89 ext entry (ptr, bit (4)); 90 dcl cobol_short_to_longbin$register 91 ext entry (ptr, ptr); 92 dcl cobol_register$load ext entry (ptr); 93 dcl cobol_register$release 94 ext entry (ptr); 95 dcl cobol_make_type9$decimal_9bit 96 ext entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin); 97 dcl cobol_make_type9$long_bin 98 ext entry (ptr, fixed bin, fixed bin (24)); 99 dcl cobol_make_type9$short_bin 100 ext entry (ptr, fixed bin, fixed bin (24)); 101 dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin (24)); 102 103 104 105 /* DECLARATION OF INTERNALL STATIC DATA */ 106 107 dcl STA bit (10) int static init ("1111011010"b); 108 /* 755(0) */ 109 dcl STQ bit (10) int static init ("1111011100"b); 110 /* 756(0) */ 111 dcl STX bit (10) int static init ("1111000000"b); 112 /* 740(0) */ 113 dcl SXL bit (10) int static init ("1001000000"b); 114 /* 440(0) */ 115 dcl LDA bit (10) int static init ("0100111010"b); 116 /* 235(0) */ 117 dcl LDQ bit (10) int static init ("0100111100"b); 118 /* 236(0) */ 119 dcl LDX bit (10) int static init ("0100100000"b); 120 /* 220(0) */ 121 dcl LXL bit (10) int static init ("1110100000"b); 122 /* 720(0) */ 123 dcl BTD bit (10) int static init ("0110000011"b); 124 /* 301(1) */ 125 dcl DTB bit (10) int static init ("0110001011"b); 126 /* 305(1) */ 127 dcl STAQ bit (10) int static init ("1111011110"b); 128 /* 757(0) */ 129 130 131 /* DECLARATION OF INTERNAL VARIABLES */ 132 133 dcl source_length fixed bin; 134 dcl target_length fixed bin; 135 dcl temp_source_ptr ptr; 136 dcl temp_ptr ptr; 137 138 dcl 1 input_buff aligned, 139 2 buff (1:10) ptr; 140 dcl 1 inst_buff aligned, 141 2 buff (1:4) fixed bin; 142 dcl 1 reloc_buff aligned, 143 2 buff (1:10) bit (5) aligned; 144 145 dcl temp_op bit (10); 146 147 148 dcl 1 register_struc, 149 2 what_reg fixed bin, 150 2 reg_no bit (4), 151 2 lock fixed bin, 152 2 already_there fixed bin, 153 2 contains fixed bin, 154 2 tok_ptr ptr, 155 2 literal bit (36); 156 dcl dn_ptr ptr; 157 158 159 /**************************************************/ 160 start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(csb);/**/ 161 if source_ptr -> data_name.type = rtc_immed_const 162 then do; /* Source is an immediate constant token */ 163 /* Load the constant into an index register. */ 164 temp_ptr = null (); 165 if target_ptr -> data_name.bin_18 166 then call immed_to_index (source_ptr, temp_ptr); 167 else call immed_to_register (source_ptr, temp_ptr); 168 source_ptr = temp_ptr; 169 end; /* Source is an immediate constant token. */ 170 171 call get_length (source_ptr, source_length); 172 call get_length (target_ptr, target_length); 173 174 if target_length < source_length 175 then call difficult_store (source_ptr, target_ptr, call_again); 176 else call easy_store (source_ptr, target_ptr, call_again); 177 exit: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(csb);/**/ 178 return; 179 180 /***..... dcl csb char(18) init("COBOL_STORE_BINARY");/**/ 181 182 /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ 183 /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ 184 185 /***..... dcl Trace_Bit bit(1) static external;/**/ 186 /***..... dcl Trace_Lev fixed bin static external;/**/ 187 /***..... dcl Trace_Line char(36) static external;/**/ 188 /***..... dcl ioa_ entry options(variable); /**/ 189 190 191 192 /**************************************************/ 193 easy_store: 194 proc (es_source_ptr, es_target_ptr, es_call_again); 195 196 /* 197*This procedure generates code to store a fixed binary datum 198*into another fixed binary datum of length equal to or greater 199*than the source datum. The source may be in an index register, 200*or the A or Q register, or in a cobol data item. The target is 201*always a cobol data item. 202**/ 203 204 /* DECLARATION OF THE PARAMETERS */ 205 206 dcl es_source_ptr ptr; 207 dcl es_target_ptr ptr; 208 dcl es_call_again bit (1); 209 210 start_easy_store: 211 es_call_again = "0"b; 212 213 /* Set up the input structure for calling the addressability utility. */ 214 input_ptr = addr (input_buff); 215 inst_ptr = addr (inst_buff); 216 reloc_ptr = addr (reloc_buff); 217 218 input_struc.type = 2; 219 input_struc.operand_no = 1; 220 input_struc.lock = 0; 221 input_struc.send_receive (1) = 1; /* receiving */ 222 input_struc.operand.size_sw (1) = 0; 223 224 if es_source_ptr -> data_name.type = rtc_register 225 then do; /* Source is in a register. */ 226 227 /* Establish addressability to the target*/ 228 input_struc.operand.token_ptr (1) = es_target_ptr; 229 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 230 231 if (es_source_ptr -> cobol_type100.register = "0001"b /* A */ 232 | es_source_ptr -> cobol_type100.register = "0010"b /* Q */) 233 then do; /* Source is in the A or Q */ 234 235 if es_source_ptr -> cobol_type100.register = "0001"b 236 /* source in A */ 237 then inst_struc_basic.fill1_op = STA; 238 else inst_struc_basic.fill1_op = STQ; 239 240 call cobol_emit (inst_ptr, reloc_ptr, 1); 241 end; /* Source is in the A or Q */ 242 243 else do; /* Source is in an index register */ 244 /* Note that if the source is in an index register, the target must be a short 245* binary, because arithmetic is done in the index registers only if all targets are 246* short binary. */ 247 248 if mod (es_target_ptr -> data_name.offset, 4) = 0 249 then temp_op = STX; /* Target is word aligned */ 250 else temp_op = SXL; /* Target is half-word aligned */ 251 252 substr (temp_op, 7, 3) = substr (es_source_ptr -> cobol_type100.register, 2, 3); 253 inst_struc_basic.fill1_op = temp_op; 254 call cobol_emit (inst_ptr, reloc_ptr, 1); 255 256 end; /* Source is in an index register */ 257 258 end; /* Source is in a register */ 259 260 261 else do; /* Source must be in a cobol data item */ 262 263 if es_source_ptr -> data_name.bin_36 264 then do; /* Source is a long binary. */ 265 266 /* Note that if the source is a long binary, then the target is also a long binary. */ 267 268 /* Establish addressability to the source. */ 269 input_struc.operand.token_ptr (1) = es_source_ptr; 270 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 271 272 /* Get the A or Q register */ 273 register_struc.what_reg = 4; /* A or Q */ 274 register_struc.lock = 1; 275 register_struc.contains = 1; 276 register_struc.tok_ptr = es_source_ptr; 277 call cobol_register$load (addr (register_struc)); 278 279 if register_struc.reg_no = "0001"b 280 /* A */ 281 then inst_struc_basic.fill1_op = LDA; 282 else inst_struc_basic.fill1_op = LDQ; 283 call cobol_emit (inst_ptr, reloc_ptr, 1); 284 285 /* Establish addressability to the target. */ 286 input_struc.operand.token_ptr (1) = es_target_ptr; 287 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 288 289 if register_struc.reg_no = "0001"b 290 /* A */ 291 then inst_struc_basic.fill1_op = STA; 292 else inst_struc_basic.fill1_op = STQ; 293 call cobol_emit (inst_ptr, reloc_ptr, 1); 294 295 /* The source is now in the A or Q */ 296 /* Make a register token for the A or Q, and set the source pointer 297* (es_source_ptr) to point to this register token, so that additional sotres 298* (if any) can be done directly from the A or Q. */ 299 300 es_source_ptr = null (); 301 call cobol_make_reg_token (es_source_ptr, register_struc.reg_no); 302 303 end; /* Source is a long binary */ 304 305 else do; /* Source must be a short binary. */ 306 307 if es_target_ptr -> data_name.bin_18 308 then do; /* Target is a short binary */ 309 310 /* Establish addressability to the source */ 311 input_struc.operand.token_ptr (1) = es_source_ptr; 312 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 313 314 /* Get an index register into which to load the short binary, and lock it */ 315 register_struc.what_reg = 5; 316 register_struc.lock = 1; 317 register_struc.contains = 1; 318 register_struc.tok_ptr = es_source_ptr; 319 call cobol_register$load (addr (register_struc)); 320 321 if mod (es_source_ptr -> data_name.offset, 4) = 0 322 then temp_op = LDX; /* Source is word aligned. */ 323 else temp_op = LXL; /* Source is half_word aligned */ 324 substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3); 325 inst_struc_basic.fill1_op = temp_op; 326 /* Emit the instruction to load the source into an index register. */ 327 call cobol_emit (inst_ptr, reloc_ptr, 1); 328 329 /* Establish addressability to the target. */ 330 input_struc.operand.token_ptr (1) = es_target_ptr; 331 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 332 333 if mod (es_target_ptr -> data_name.offset, 4) = 0 334 then temp_op = STX; /* Target is word aligned. */ 335 else temp_op = SXL; /* Target is holf-word aligned. */ 336 337 substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3); 338 inst_struc_basic.fill1_op = temp_op; 339 340 /* Emit the instruction to store the index register into the target. */ 341 call cobol_emit (inst_ptr, reloc_ptr, 1); 342 343 /* Make a register token for the index register, and set the source pointer 344* to point to the register token, so that additional stores (if any) 345* can be done directly from the index register. */ 346 es_source_ptr = null (); 347 call cobol_make_reg_token (es_source_ptr, register_struc.reg_no); 348 349 end; /* Target is a short binary. */ 350 351 else do; /* Target is a long binary */ 352 353 temp_source_ptr = null (); 354 /* Convert the short binary source to a long binary in the A or Q */ 355 call cobol_short_to_longbin$register (es_source_ptr, temp_source_ptr); 356 357 /* Establish addressabiity to the target. */ 358 input_struc.operand.token_ptr (1) = es_target_ptr; 359 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 360 361 if temp_source_ptr -> cobol_type100.register = "0001"b 362 /* A */ 363 then inst_struc_basic.fill1_op = STA; 364 else inst_struc_basic.fill1_op = STQ; 365 /* Emit the instruction to store the register into the target. */ 366 call cobol_emit (inst_ptr, reloc_ptr, 1); 367 368 /* Set the source pointer to the register token for the long 369* binary, so that additional stores (if any) can be done 370* directly from the register. */ 371 es_source_ptr = temp_source_ptr; 372 end; /* Target is a long binary */ 373 374 end; /* Source must be a short binary. */ 375 376 end; /* Source must be a cobol data item. */ 377 exit_easy_store: 378 return; 379 380 end easy_store; 381 382 383 /**************************************************/ 384 difficult_store: 385 proc (ds_source_ptr, ds_target_ptr, ds_call_again); 386 387 /* DECLARATION OF THE PARAMETERS */ 388 389 dcl ds_source_ptr ptr; 390 dcl ds_target_ptr ptr; 391 dcl ds_call_again bit (1); 392 393 394 395 /* 396*This procedure generates code that attempts to force a fixed 397*point overflow condition because the source (to be stored) 398*is potentially larger than the receiving target. 399**/ 400 401 /* DESCRIPTION OF THE PARAMETERS */ 402 403 /* 404*PARAMETER DESCRIPTION 405* 406*ds_source_ptr Pointer to a token that describes the value 407* to be stored. (input) This token may be 408* a register token for either A,Q, or A-Q, or 409* a data name token (type 9) for a long binary 410* cobol data item. 411*ds_target_ptr Pointer to a token that describes the 412* target of the store.(input) This token 413* is always a data name (type 9) token for 414* either a long binary or short binary 415* data item. 416*ds_call_again A flag that is always set to "1"b by 417* this procedure. 418* 419**/ 420 421 /* DECLARATION OF INTERNAL VARIABLES */ 422 423 dcl temp_length fixed bin; 424 dcl ret_offset fixed bin (24); 425 dcl temp_op bit (10); 426 dcl temp_source_ptr ptr; 427 dcl temp_dec_token_ptr ptr; 428 dcl temp_bin_token_ptr ptr; 429 430 431 /**************************************************/ 432 start_difficult_store: /* Set up for calling the addressability utility. */ 433 input_ptr = addr (input_buff); 434 inst_ptr = addr (inst_buff); 435 reloc_ptr = addr (reloc_buff); 436 437 if ds_source_ptr -> data_name.type = rtc_register 438 then do; /* Source is in a register. */ 439 /* Store the register(s) into temporary storage */ 440 if ds_source_ptr -> cobol_type100.register = "0011"b 441 /* A and Q */ 442 then temp_length = 8; 443 else temp_length = 4; /* Allocate some temporary, aligned on a double word boundary. */ 444 call cobol_alloc$stack (temp_length, 2, ret_offset); 445 446 /* Make a long binary data name token for the temporary. */ 447 temp_source_ptr = null (); 448 call cobol_make_type9$long_bin (temp_source_ptr, 1000 /*stack*/, 4 * ret_offset); 449 /* Modify the item length, because make_type9$long_bin assumes a length of 4 bytes. */ 450 temp_source_ptr -> data_name.item_length = temp_length; 451 452 /* Set up for calling the addressability utility. */ 453 input_struc_basic.type = 1; 454 input_struc_basic.operand_no = 0; 455 input_struc_basic.lock = 0; 456 input_struc_basic.char_offset = ret_offset * 4; 457 input_struc_basic.segno = 1000; /* stack */ 458 459 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 460 461 /* Insert the appropriate opode to store the register(s) into the temporary */ 462 if ds_source_ptr -> cobol_type100.register = "0001"b 463 then temp_op = STA; 464 else if ds_source_ptr -> cobol_type100.register = "0010"b 465 then temp_op = STQ; 466 else temp_op = STAQ; 467 468 /* Emit code to store the source into a temporary */ 469 inst_struc_basic.fill1_op = temp_op; 470 call cobol_emit (inst_ptr, reloc_ptr, 1); 471 472 /* Unlock the register that contained the source. */ 473 register_struc.reg_no = ds_source_ptr -> cobol_type100.register; 474 call cobol_register$release (addr (register_struc)); 475 end; /* Source is in a register. */ 476 477 else temp_source_ptr = ds_source_ptr; 478 479 /* Allocate space in the stack into which the fixed binary will be converted to decimal. */ 480 481 if temp_source_ptr -> data_name.item_length = 4 482 then temp_length = 11; /* source is single-word fixed binary. */ 483 else temp_length = 22; /* source is double-word fixed binary */ 484 call cobol_alloc$stack (temp_length, 0, ret_offset); 485 486 /* Make a data name token for the temporary */ 487 temp_dec_token_ptr = null (); 488 call cobol_make_type9$decimal_9bit (temp_dec_token_ptr, 1000 /*stack*/, ret_offset, temp_length, 0); 489 490 /* Set up to build the BTD instruction. */ 491 input_struc.type = 5; 492 input_struc.operand_no = 2; 493 input_struc.lock = 0; 494 input_struc.operand.token_ptr (1) = temp_source_ptr; 495 input_struc.operand.size_sw (1) = 0; 496 input_struc.operand.token_ptr (2) = temp_dec_token_ptr; 497 input_struc.operand.size_sw (2) = 0; 498 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 499 500 /* Insert the opcode and emit the EIS BTD instruction */ 501 inst_struc_basic.fill1_op = BTD; 502 call cobol_emit (inst_ptr, reloc_ptr, 3); 503 504 /* Allocate work space the size of the target. The decimal number will be converted into this work 505* space, using a DTB instruction. If the decimal number is too long, overflow will occur. */ 506 507 call cobol_alloc$stack (fixed (ds_target_ptr -> data_name.item_length, 17), 0, ret_offset); 508 temp_bin_token_ptr = null (); 509 if ds_target_ptr -> data_name.item_length = 4 510 then call cobol_make_type9$long_bin (temp_bin_token_ptr, 1000, ret_offset); 511 else call cobol_make_type9$short_bin (temp_bin_token_ptr, 1000, ret_offset); 512 513 input_struc.operand.token_ptr (1) = temp_dec_token_ptr; 514 input_struc.operand.token_ptr (2) = temp_bin_token_ptr; 515 call cobol_addr (input_ptr, inst_ptr, reloc_ptr); 516 517 /* Insert the opcode and emit the EIS DTB instruction */ 518 inst_struc_basic.fill1_op = DTB; 519 call cobol_emit (inst_ptr, reloc_ptr, 3); 520 521 /* Set the source pointer to point to the fixed binary temporary */ 522 ds_source_ptr = temp_bin_token_ptr; 523 ds_call_again = "1"b; 524 exit_difficult_store: 525 return; 526 527 end difficult_store; 528 529 530 /**************************************************/ 531 get_length: 532 proc (token_ptr, datum_length); 533 534 /* 535*This procedure determines the number of data bytes required 536*by the datum described by the token pointed at by token_ptr. 537**/ 538 539 /* DECLARATION OF THE PARAMETERS */ 540 541 dcl token_ptr ptr; 542 dcl datum_length fixed bin; 543 544 545 start_get_length: 546 if token_ptr -> data_name.type = rtc_register 547 then do; /* Token describes a register */ 548 549 if (token_ptr -> cobol_type100.register = "0001"b /* A */ 550 | token_ptr -> cobol_type100.register = "0010"b /* Q */) 551 then datum_length = 4; /* 4 bytes = 36 bits = full word */ 552 553 else if token_ptr -> cobol_type100.register = "0011"b 554 /* A and Q */ 555 then datum_length = 8; 556 557 else datum_length = 2; /* Must be an index register. */ 558 end; /* token describes a register. */ 559 560 else datum_length = token_ptr -> data_name.item_length; 561 exit_get_length: 562 return; 563 564 end get_length; 565 566 567 immed_to_index: 568 proc (source_tok_ptr, index_tok_ptr); 569 570 /* 571*This procedure generates code to load an immediate constant 572*into an index register. 573**/ 574 575 /* DECLARATION OF THE PARAMETERS */ 576 577 dcl source_tok_ptr ptr; 578 dcl index_tok_ptr ptr; 579 580 /* DECLARATION OF INTERNAL STATIC DATA */ 581 582 dcl ldx_du_inst bit (36) int static init ("000000000000000000010010000000000011"b); 583 /* LDXn 0,du */ 584 585 /**************************************************/ 586 start_immed_to_index: /* Get an index register and lock it. */ 587 register_struc.what_reg = 5; /* any index register */ 588 register_struc.lock = 1; /* lock it */ 589 register_struc.contains = 0; 590 call cobol_register$load (addr (register_struc)); 591 592 /* Build LDXn const,du instruction */ 593 substr (ldx_du_inst, 25, 3) = substr (register_struc.reg_no, 2, 3); 594 substr (ldx_du_inst, 1, 18) = substr (unspec (source_tok_ptr -> immed_const.const_value), 19, 18); 595 596 call cobol_emit (addr (ldx_du_inst), null (), 1); 597 598 /* Make a register token tor the index that contains the constant. */ 599 call cobol_make_reg_token (index_tok_ptr, register_struc.reg_no); 600 601 exit_immed_to_index: 602 return; 603 end immed_to_index; 604 605 606 immed_to_register: 607 proc (source_tok_ptr, register_tok_ptr); 608 609 /* 610*This procedure generates code to load an immediate constant into the A or Q register. 611**/ 612 613 /* DECLARATION OF THE PARAMETERS */ 614 615 dcl source_tok_ptr ptr; 616 dcl register_tok_ptr ptr; 617 618 /* DECLARATION OF INTERNAL STATIC DATA */ 619 620 dcl direct_lower_inst bit (36) int static init ("000000000000000000000000000000000111"b); 621 /* zero,dl */ 622 623 start_immed_to_register: /* Get a register and lock it. */ 624 register_struc.what_reg = 4; /* A or Q */ 625 register_struc.lock = 1; 626 register_struc.contains = 0; 627 call cobol_register$load (addr (register_struc)); 628 629 /* Build LDA/Q const,dl instruction */ 630 substr (direct_lower_inst, 1, 18) = substr (unspec (source_tok_ptr -> immed_const.const_value), 19, 18); 631 632 if register_struc.reg_no = "0001"b 633 then substr (direct_lower_inst, 19, 10) = LDA; 634 else substr (direct_lower_inst, 19, 10) = LDQ; 635 636 637 call cobol_emit (addr (direct_lower_inst), null (), 1); 638 639 /* Make a register token for the register that contains the constant. */ 640 call cobol_make_reg_token (register_tok_ptr, register_struc.reg_no); 641 exit_immed_to_register: 642 return; 643 644 end immed_to_register; 645 646 647 /* INCLUDE FILES USED BY THIS PROCEDURE */ 648 649 /***** Declaration for builtin function *****/ 650 651 dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) 652 builtin; 653 654 /***** End of declaration for builtin function *****/ 655 1 1 1 2 /* BEGIN INCLUDE FILE ... cobol_type100.incl.pl1 */ 1 3 /* Last modified on 11/19/76 by ORN */ 1 4 1 5 /* 1 6*The internal register token is used only during the code generation phase. 1 7**/ 1 8 1 9 dcl cobol_type100_ptr ptr; 1 10 1 11 /* BEGIN DECLARATION OF TYPE100 (INTERNAL REGISTER) TOKEN */ 1 12 dcl 1 cobol_type100 based (cobol_type100_ptr) aligned, 1 13 /* header */ 1 14 2 size fixed bin (15), 1 15 2 line fixed bin (15), 1 16 2 column fixed bin (7), 1 17 2 type fixed bin (7), 1 18 /* body */ 1 19 2 register bit (4) unaligned; 1 20 /* END DECLARATION OF TYPE100 (INTERNAL REGISTER) TOKEN */ 1 21 1 22 /* 1 23*FIELD CONTENTS 1 24* 1 25*size The total size in bytes of this token. 1 26*line Generated sequence number of source line. 1 27* Always 0. 1 28*column The column number on the source image. 1 29* Always 0. 1 30*type 100 1 31*register The register number in the following form. 1 32* "0001"b - A register. 1 33* "0010"b - Q register. 1 34* "0011"b - A and Q registers. 1 35* "1nnn"b - index register nnn. 1 36**/ 1 37 1 38 /* END INCLUDE FILE ... cobol_type100.incl.pl1 */ 1 39 656 2 1 2 2 /* BEGIN INCLUDE FILE ... cobol_addr_tokens.incl.pl1 */ 2 3 2 4 2 5 /****^ HISTORY COMMENTS: 2 6* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8058), 2 7* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 2 8* MCR8058 cobol_addr_tokens.incl.pl1 Change array extents to refer to 2 9* constants rather than variables. 2 10* END HISTORY COMMENTS */ 2 11 2 12 2 13 /* Last modified on 10/1/74 by tg */ 2 14 2 15 2 16 /* parameter list */ 2 17 2 18 dcl (input_ptr, inst_ptr, reloc_ptr) ptr; 2 19 2 20 2 21 /* input_struc_basic is used for type 1 addressing */ 2 22 2 23 dcl 1 input_struc_basic based (input_ptr), 2 24 2 type fixed bin, 2 25 2 operand_no fixed bin, 2 26 2 lock fixed bin, 2 27 2 segno fixed bin, 2 28 2 char_offset fixed bin (24), 2 29 2 send_receive fixed bin; 2 30 2 31 2 32 dcl 1 input_struc based (input_ptr), 2 33 2 type fixed bin, 2 34 2 operand_no fixed bin, 2 35 2 lock fixed bin, 2 36 2 operand (0 refer (input_struc.operand_no)), 2 37 3 token_ptr ptr, 2 38 3 send_receive fixed bin, 2 39 3 ic_mod fixed bin, 2 40 3 size_sw fixed bin; 2 41 2 42 /* reloc_struc is used for all types of addressing * all types */ 2 43 2 44 dcl 1 reloc_struc (input_struc.operand_no + 1) based (reloc_ptr), 2 45 2 left_wd bit (5) aligned, 2 46 2 right_wd bit (5) aligned; 2 47 2 48 /* Instruction format for 1 word instruction */ 2 49 2 50 2 51 dcl 1 inst_struc_basic based (inst_ptr) aligned, 2 52 2 y unaligned, 2 53 3 pr bit (3) unaligned, 2 54 3 wd_offset bit (15) unaligned, 2 55 2 fill1_op bit (10) unaligned, 2 56 2 zero1 bit (1) unaligned, 2 57 2 pr_spec bit (1) unaligned, 2 58 2 tm bit (2) unaligned, 2 59 2 td bit (4) unaligned; 2 60 2 61 2 62 /* The detailed definitions of the fields in this structure 2 63* can be found in the GMAP manual section 8 */ 2 64 /* EIS instruction format for 2_4 word instructions */ 2 65 2 66 dcl 1 inst_struc based (inst_ptr) aligned, 2 67 2 inst unaligned, 2 68 3 zero1 bit (2) unaligned, 2 69 3 mf3 unaligned, 2 70 4 pr_spec bit (1) unaligned, 2 71 4 reg_or_length bit (1) unaligned, 2 72 4 zero2 bit (1) unaligned, 2 73 4 reg_mod bit (4) unaligned, 2 74 3 zero3 bit (2) unaligned, 2 75 3 mf2 unaligned, 2 76 4 pr_spec bit (1) unaligned, 2 77 4 reg_or_length bit (1) unaligned, 2 78 4 zero4 bit (1) unaligned, 2 79 4 reg_mod bit (4) unaligned, 2 80 3 fill1_op bit (10) unaligned, 2 81 3 zero5 bit (1) unaligned, 2 82 3 mf1 unaligned, 2 83 4 pr_spec bit (1) unaligned, 2 84 4 reg_or_length bit (1) unaligned, 2 85 4 zero6 bit (1) unaligned, 2 86 4 reg_mod bit (4) unaligned, 2 87 2 desc_ext unaligned, 2 88 3 desc (512) unaligned, 2 89 4 desc_od bit (36) unaligned; 2 90 2 91 /* The detailed definitions of the fields in this structure 2 92* can be found in the GMAP manual section 8. 2 93* The desc_ext is the descriptor extension of this eis 2 94* instruction. The number of descriptors associated with 2 95* this instruction is equavalent to the operand number. 2 96* Depending on operand data type, the descriptor 2 97* can be alphanumeric or numeric. The structures of the 2 98* alphanumeric and the numeric descriptors are defined 2 99* below. */ 2 100 2 101 /* alphanumeric descriptor format */ 2 102 2 103 dcl 1 desc_an based (desc_an_ptr) unaligned, 2 104 2 desc_f (512) unaligned, 2 105 3 y unaligned, 2 106 4 pr bit (3) unaligned, 2 107 4 wd_offset bit (15) unaligned, 2 108 3 char_n bit (3) unaligned, 2 109 3 zero1 bit (1) unaligned, 2 110 3 ta bit (2), 2 111 3 n bit (12) unaligned; 2 112 2 113 2 114 /* The detailed definitions of the fields in this structure can 2 115* be found in the GMAP manual section 8. */ 2 116 /* numeric descriptor format */ 2 117 2 118 dcl desc_nn_ptr ptr; 2 119 dcl desc_an_ptr ptr; 2 120 2 121 2 122 dcl 1 desc_nn based (desc_nn_ptr) unaligned, 2 123 2 desc_f (512) unaligned, 2 124 3 y unaligned, 2 125 4 pr bit (3) unaligned, 2 126 4 wd_offset bit (15) unaligned, 2 127 3 digit_n bit (3) unaligned, 2 128 3 tn bit (1) unaligned, 2 129 3 sign_type bit (2) unaligned, 2 130 3 scal bit (6) unaligned, 2 131 3 n bit (6) unaligned; 2 132 2 133 2 134 /* The detailed definitions of fields in this structure can 2 135* be found in the GMAP manual section 8. */ 2 136 /* END INCLUDE FILE ... cobol_addr_tokens.incl.pl1 */ 2 137 657 3 1 3 2 /* BEGIN INCLUDE FILE ... cobol_type9.incl.pl1 */ 3 3 /* Last modified on 11/19/76 by ORN */ 3 4 3 5 /* 3 6*A type 9 data name token is entered into the name table by the data 3 7*division syntax phase for each data name described in the data division. 3 8*The replacement phase subsequently replaces type 8 user word references 3 9*to data names in the procedure division minpral file with the corresponding 3 10*type 9 tokens from the name table. 3 11**/ 3 12 3 13 /* dcl dn_ptr ptr; */ 3 14 3 15 /* BEGIN DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 3 16 dcl 1 data_name based (dn_ptr), 4 1 4 2 /* begin include file ... cobol_TYPE9.incl.pl1 */ 4 3 /* Last modified on 06/19/77 by ORN */ 4 4 /* Last modified on 12/28/76 by FCH */ 4 5 4 6 /* header */ 4 7 2 size fixed bin, 4 8 2 line fixed bin, 4 9 2 column fixed bin, 4 10 2 type fixed bin, 4 11 /* body */ 4 12 2 string_ptr ptr, 4 13 2 prev_rec ptr, 4 14 2 searched bit (1), 4 15 2 duplicate bit (1), 4 16 2 saved bit (1), 4 17 2 debug_ind bit (1), 4 18 2 filler2 bit (3), 4 19 2 used_as_sub bit (1), 4 20 2 def_line fixed bin, 4 21 2 level fixed bin, 4 22 2 linkage fixed bin, 4 23 2 file_num fixed bin, 4 24 2 size_rtn fixed bin, 4 25 2 item_length fixed bin(24), 4 26 2 places_left fixed bin, 4 27 2 places_right fixed bin, 4 28 /* description */ 4 29 2 file_section bit (1), 4 30 2 working_storage bit (1), 4 31 2 constant_section bit (1), 4 32 2 linkage_section bit (1), 4 33 2 communication_section bit (1), 4 34 2 report_section bit (1), 4 35 2 level_77 bit (1), 4 36 2 level_01 bit (1), 4 37 2 non_elementary bit (1), 4 38 2 elementary bit (1), 4 39 2 filler_item bit (1), 4 40 2 s_of_rdf bit (1), 4 41 2 o_of_rdf bit (1), 4 42 2 bin_18 bit (1), 4 43 2 bin_36 bit (1), 4 44 2 pic_has_l bit (1), 4 45 2 pic_is_do bit (1), 4 46 2 numeric bit (1), 4 47 2 numeric_edited bit (1), 4 48 2 alphanum bit (1), 4 49 2 alphanum_edited bit (1), 4 50 2 alphabetic bit (1), 4 51 2 alphabetic_edited bit (1), 4 52 2 pic_has_p bit (1), 4 53 2 pic_has_ast bit (1), 4 54 2 item_signed bit(1), 4 55 2 sign_separate bit (1), 4 56 2 display bit (1), 4 57 2 comp bit (1), 4 58 2 ascii_packed_dec_h bit (1), /* as of 8/16/76 this field used for comp8. */ 4 59 2 ascii_packed_dec bit (1), 4 60 2 ebcdic_packed_dec bit (1), 4 61 2 bin_16 bit (1), 4 62 2 bin_32 bit (1), 4 63 2 usage_index bit (1), 4 64 2 just_right bit (1), 4 65 2 compare_argument bit (1), 4 66 2 sync bit (1), 4 67 2 temporary bit (1), 4 68 2 bwz bit (1), 4 69 2 variable_length bit (1), 4 70 2 subscripted bit (1), 4 71 2 occurs_do bit (1), 4 72 2 key_a bit (1), 4 73 2 key_d bit (1), 4 74 2 indexed_by bit (1), 4 75 2 value_numeric bit (1), 4 76 2 value_non_numeric bit (1), 4 77 2 value_signed bit (1), 4 78 2 sign_type bit (3), 4 79 2 pic_integer bit (1), 4 80 2 ast_when_zero bit (1), 4 81 2 label_record bit (1), 4 82 2 sign_clause_occurred bit (1), 4 83 2 okey_dn bit (1), 4 84 2 subject_of_keyis bit (1), 4 85 2 exp_redefining bit (1), 4 86 2 sync_in_rec bit (1), 4 87 2 rounded bit (1), 4 88 2 ad_bit bit (1), 4 89 2 debug_all bit (1), 4 90 2 overlap bit (1), 4 91 2 sum_counter bit (1), 4 92 2 exp_occurs bit (1), 4 93 2 linage_counter bit (1), 4 94 2 rnm_01 bit (1), 4 95 2 aligned bit (1), 4 96 2 not_user_writable bit (1), 4 97 2 database_key bit (1), 4 98 2 database_data_item bit (1), 4 99 2 seg_num fixed bin, 4 100 2 offset fixed bin(24), 4 101 2 initial_ptr fixed bin, 4 102 2 edit_ptr fixed bin, 4 103 2 occurs_ptr fixed bin, 4 104 2 do_rec char(5), 4 105 2 bitt bit (1), 4 106 2 byte bit (1), 4 107 2 half_word bit (1), 4 108 2 word bit (1), 4 109 2 double_word bit (1), 4 110 2 half_byte bit (1), 4 111 2 filler5 bit (1), 4 112 2 bit_offset bit (4), 4 113 2 son_cnt bit (16), 4 114 2 max_red_size fixed bin(24), 4 115 2 name_size fixed bin, 4 116 2 name char(0 refer(data_name.name_size)); 4 117 4 118 4 119 4 120 /* end include file ... cobol_TYPE9.incl.pl1 */ 4 121 3 17 3 18 /* END DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 3 19 3 20 /* END INCLUDE FILE ... cobol_type9.incl.pl1 */ 3 21 658 5 1 5 2 /* BEGIN INCLUDE FILE ... cobol_record_types.incl.pl1 */ 5 3 /* <<< LAST MODIFIED ON 09-09-75 by tlf >>> */ 5 4 5 5 dcl rtc_resword fixed bin (15) int static init(1); 5 6 dcl rtc_numlit fixed bin (15) int static init(2); 5 7 dcl rtc_alphalit fixed bin (15) int static init(3); 5 8 dcl rtc_picstring fixed bin (15) int static init(4); 5 9 dcl rtc_diag fixed bin (15) int static init(5); 5 10 dcl rtc_source fixed bin (15) int static init(6); 5 11 dcl rtc_procdef fixed bin (15) int static init(7); 5 12 dcl rtc_userwd fixed bin (15) int static init(8); 5 13 dcl rtc_dataname fixed bin (15) int static init(9); 5 14 dcl rtc_indexname fixed bin (15) int static init(10); 5 15 dcl rtc_condname fixed bin (15) int static init(11); 5 16 dcl rtc_filedef fixed bin (15) int static init(12); 5 17 dcl rtc_commdesc fixed bin (15) int static init(13); 5 18 dcl rtc_debugitems fixed bin (15) int static init(14); 5 19 dcl rtc_savedarea fixed bin (15) int static init(15); 5 20 dcl rtc_sortmerge fixed bin (15) int static init(16); 5 21 dcl rtc_mnemonic fixed bin (15) int static init(17); 5 22 dcl rtc_pararef fixed bin (15) int static init(18); 5 23 dcl rtc_eos fixed bin (15) int static init(19); 5 24 dcl rtc_reportname fixed bin (15) int static init(20); 5 25 dcl rtc_groupname fixed bin (15) int static init(21); 5 26 dcl rtc_reportentry fixed bin (15) int static init(22); 5 27 dcl rtc_unknown1 fixed bin (15) int static init(23); 5 28 dcl rtc_debugenable fixed bin (15) int static init(24); 5 29 dcl rtc_unknown2 fixed bin (15) int static init(25); 5 30 dcl rtc_unknown3 fixed bin (15) int static init(26); 5 31 dcl rtc_unknown4 fixed bin (15) int static init(27); 5 32 dcl rtc_unknown5 fixed bin (15) int static init(28); 5 33 dcl rtc_unknown6 fixed bin (15) int static init(29); 5 34 dcl rtc_internal_tag fixed bin (15) int static init(30); 5 35 dcl rtc_equate_tag fixed bin (15) int static init(31); 5 36 dcl rtc_register fixed bin (15) int static init(100); 5 37 dcl rtc_fdec_temp fixed bin (15) int static init(101); 5 38 dcl rtc_immed_const fixed bin (15) int static init(102); 5 39 5 40 /* END INCLUDE FILE ... cobol_record_types.incl.pl1 */ 5 41 659 6 1 6 2 /* BEGIN INCLUDE FILE... cobol_type102.incl.pl1 */ 6 3 /* Last modified on 1/19/76 by ORN */ 6 4 6 5 /* 6 6*An immediate constant token is created during the 6 7*generation of code that performs arithmetic in the hardware 6 8*registers, for any numeric literal token whose value is within 6 9*the range: (-131072,131071). 6 10**/ 6 11 6 12 dcl immed_const_ptr ptr; 6 13 6 14 /* BEGIN DECLARATION OF TYPE102 (IMMEDIATE CONSTANT) TOKEN */ 6 15 dcl 1 immed_const based(immed_const_ptr), 6 16 /* header */ 6 17 2 size fixed bin (15), 6 18 2 line fixed bin (15), 6 19 2 column fixed bin (15), 6 20 2 type fixed bin (15), 6 21 /* body */ 6 22 2 const_value fixed bin (35); 6 23 /* END DECLARATION OF TYPE102 (IMMEDIATE CONSTANT) TOKEN */ 6 24 6 25 /* 6 26*FIELD CONTENTS 6 27* 6 28*size The total size in bytes of this immediate 6 29* constant token. 6 30*line not used 6 31*column not used 6 32*type 102 6 33*const_value The fixed binary value of the immediate constant. 6 34**/ 6 35 6 36 /* END INCLUDE FILE... cobol_type102.incl.pl1 */ 6 37 660 661 662 end cobol_store_binary; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0832.4 cobol_store_binary.pl1 >spec>install>MR12.3-1048>cobol_store_binary.pl1 656 1 03/27/82 0439.8 cobol_type100.incl.pl1 >ldd>include>cobol_type100.incl.pl1 657 2 05/24/89 0811.7 cobol_addr_tokens.incl.pl1 >spec>install>MR12.3-1048>cobol_addr_tokens.incl.pl1 658 3 03/27/82 0439.9 cobol_type9.incl.pl1 >ldd>include>cobol_type9.incl.pl1 3-17 4 11/11/82 1712.7 cobol_TYPE9.incl.pl1 >ldd>include>cobol_TYPE9.incl.pl1 659 5 03/27/82 0439.8 cobol_record_types.incl.pl1 >ldd>include>cobol_record_types.incl.pl1 660 6 03/27/82 0439.8 cobol_type102.incl.pl1 >ldd>include>cobol_type102.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. BTD constant bit(10) initial packed unaligned dcl 123 ref 501 DTB constant bit(10) initial packed unaligned dcl 125 ref 518 LDA constant bit(10) initial packed unaligned dcl 115 ref 279 632 LDQ constant bit(10) initial packed unaligned dcl 117 ref 282 634 LDX constant bit(10) initial packed unaligned dcl 119 ref 321 LXL constant bit(10) initial packed unaligned dcl 121 ref 323 STA constant bit(10) initial packed unaligned dcl 107 ref 235 289 361 462 STAQ constant bit(10) initial packed unaligned dcl 127 ref 466 STQ constant bit(10) initial packed unaligned dcl 109 ref 238 292 364 464 STX constant bit(10) initial packed unaligned dcl 111 ref 248 333 SXL constant bit(10) initial packed unaligned dcl 113 ref 250 335 addr builtin function dcl 651 ref 214 215 216 277 277 319 319 432 434 435 474 474 590 590 596 596 627 627 637 637 bin_18 21(13) based bit(1) level 2 packed packed unaligned dcl 3-16 ref 165 307 bin_36 21(14) based bit(1) level 2 packed packed unaligned dcl 3-16 ref 263 call_again parameter bit(1) packed unaligned dcl 44 set ref 33 174* 176* char_offset 4 based fixed bin(24,0) level 2 dcl 2-23 set ref 456* cobol_addr 000012 constant entry external dcl 86 ref 229 270 287 312 331 359 459 498 515 cobol_alloc$stack 000034 constant entry external dcl 101 ref 444 484 507 cobol_emit 000014 constant entry external dcl 87 ref 240 254 283 293 327 341 366 470 502 519 596 637 cobol_make_reg_token 000016 constant entry external dcl 88 ref 301 347 599 640 cobol_make_type9$decimal_9bit 000026 constant entry external dcl 95 ref 488 cobol_make_type9$long_bin 000030 constant entry external dcl 97 ref 448 509 cobol_make_type9$short_bin 000032 constant entry external dcl 99 ref 511 cobol_register$load 000022 constant entry external dcl 92 ref 277 319 590 627 cobol_register$release 000024 constant entry external dcl 93 ref 474 cobol_short_to_longbin$register 000020 constant entry external dcl 90 ref 355 cobol_type100 based structure level 1 dcl 1-12 const_value 4 based fixed bin(35,0) level 2 dcl 6-15 ref 594 630 contains 4 000152 automatic fixed bin(17,0) level 2 dcl 148 set ref 275* 317* 589* 626* data_name based structure level 1 unaligned dcl 3-16 datum_length parameter fixed bin(17,0) dcl 542 set ref 531 549* 553* 557* 560* direct_lower_inst 000011 internal static bit(36) initial packed unaligned dcl 620 set ref 630* 632* 634* 637 637 ds_call_again parameter bit(1) packed unaligned dcl 391 set ref 384 523* ds_source_ptr parameter pointer dcl 389 set ref 384 437 440 462 464 473 477 522* ds_target_ptr parameter pointer dcl 390 ref 384 507 507 509 es_call_again parameter bit(1) packed unaligned dcl 208 set ref 193 210* es_source_ptr parameter pointer dcl 206 set ref 193 224 231 231 235 252 263 269 276 300* 301* 311 318 321 346* 347* 355* 371* es_target_ptr parameter pointer dcl 207 ref 193 228 248 286 307 330 333 358 fill1_op 0(18) based bit(10) level 2 packed packed unaligned dcl 2-51 set ref 235* 238* 253* 279* 282* 289* 292* 325* 338* 361* 364* 469* 501* 518* fixed builtin function dcl 651 ref 507 507 immed_const based structure level 1 unaligned dcl 6-15 index_tok_ptr parameter pointer dcl 578 set ref 567 599* input_buff 000106 automatic structure level 1 dcl 138 set ref 214 432 input_ptr 000164 automatic pointer dcl 2-18 set ref 214* 218 219 220 221 222 228 229* 269 270* 286 287* 311 312* 330 331* 358 359* 432* 453 454 455 456 457 459* 491 492 493 494 495 496 497 498* 513 514 515* input_struc based structure level 1 unaligned dcl 2-32 input_struc_basic based structure level 1 unaligned dcl 2-23 inst_buff 000132 automatic structure level 1 dcl 140 set ref 215 434 inst_ptr 000166 automatic pointer dcl 2-18 set ref 215* 229* 235 238 240* 253 254* 270* 279 282 283* 287* 289 292 293* 312* 325 327* 331* 338 341* 359* 361 364 366* 434* 459* 469 470* 498* 501 502* 515* 518 519* inst_struc_basic based structure level 1 dcl 2-51 item_length 16 based fixed bin(24,0) level 2 dcl 3-16 set ref 450* 481 507 507 509 560 ldx_du_inst 000010 internal static bit(36) initial packed unaligned dcl 582 set ref 593* 594* 596 596 lock 2 000152 automatic fixed bin(17,0) level 2 in structure "register_struc" dcl 148 in procedure "cobol_store_binary" set ref 274* 316* 588* 625* lock 2 based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 2-23 in procedure "cobol_store_binary" set ref 455* lock 2 based fixed bin(17,0) level 2 in structure "input_struc" dcl 2-32 in procedure "cobol_store_binary" set ref 220* 493* mod builtin function dcl 651 ref 248 321 333 null builtin function dcl 651 ref 164 300 346 353 447 487 508 596 596 637 637 offset 24 based fixed bin(24,0) level 2 dcl 3-16 ref 248 321 333 operand 4 based structure array level 2 unaligned dcl 2-32 operand_no 1 based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 2-23 in procedure "cobol_store_binary" set ref 454* operand_no 1 based fixed bin(17,0) level 2 in structure "input_struc" dcl 2-32 in procedure "cobol_store_binary" set ref 219* 492* reg_no 1 000152 automatic bit(4) level 2 packed packed unaligned dcl 148 set ref 279 289 301* 324 337 347* 473* 593 599* 632 640* register 4 based bit(4) level 2 packed packed unaligned dcl 1-12 ref 231 231 235 252 361 440 462 464 473 549 549 553 register_struc 000152 automatic structure level 1 unaligned dcl 148 set ref 277 277 319 319 474 474 590 590 627 627 register_tok_ptr parameter pointer dcl 616 set ref 606 640* reloc_buff 000136 automatic structure level 1 dcl 142 set ref 216 435 reloc_ptr 000170 automatic pointer dcl 2-18 set ref 216* 229* 240* 254* 270* 283* 287* 293* 312* 327* 331* 341* 359* 366* 435* 459* 470* 498* 502* 515* 519* ret_offset 000207 automatic fixed bin(24,0) dcl 424 set ref 444* 448 456 484* 488* 507* 509* 511* rtc_immed_const constant fixed bin(15,0) initial dcl 5-38 ref 160 rtc_register constant fixed bin(15,0) initial dcl 5-36 ref 224 437 545 segno 3 based fixed bin(17,0) level 2 dcl 2-23 set ref 457* send_receive 6 based fixed bin(17,0) array level 3 dcl 2-32 set ref 221* size_sw 10 based fixed bin(17,0) array level 3 dcl 2-32 set ref 222* 495* 497* source_length 000100 automatic fixed bin(17,0) dcl 133 set ref 171* 174 source_ptr parameter pointer dcl 42 set ref 33 160 165* 167* 168* 171* 174* 176* source_tok_ptr parameter pointer dcl 615 in procedure "immed_to_register" ref 606 630 source_tok_ptr parameter pointer dcl 577 in procedure "immed_to_index" ref 567 594 substr builtin function dcl 651 set ref 252* 252 324* 324 337* 337 593* 593 594* 594 630* 630 632* 634* target_length 000101 automatic fixed bin(17,0) dcl 134 set ref 172* 174 target_ptr parameter pointer dcl 43 set ref 33 165 172* 174* 176* temp_bin_token_ptr 000216 automatic pointer dcl 428 set ref 508* 509* 511* 514 522 temp_dec_token_ptr 000214 automatic pointer dcl 427 set ref 487* 488* 496 513 temp_length 000206 automatic fixed bin(17,0) dcl 423 set ref 440* 443* 444* 450 481* 483* 484* 488* temp_op 000150 automatic bit(10) packed unaligned dcl 145 in procedure "cobol_store_binary" set ref 248* 250* 252* 253 321* 323* 324* 325 333* 335* 337* 338 temp_op 000210 automatic bit(10) packed unaligned dcl 425 in procedure "difficult_store" set ref 462* 464* 466* 469 temp_ptr 000104 automatic pointer dcl 136 set ref 164* 165* 167* 168 temp_source_ptr 000102 automatic pointer dcl 135 in procedure "cobol_store_binary" set ref 353* 355* 361 371 temp_source_ptr 000212 automatic pointer dcl 426 in procedure "difficult_store" set ref 447* 448* 450 477* 481 494 tok_ptr 6 000152 automatic pointer level 2 dcl 148 set ref 276* 318* token_ptr parameter pointer dcl 541 in procedure "get_length" ref 531 545 549 549 553 560 token_ptr 4 based pointer array level 3 in structure "input_struc" dcl 2-32 in procedure "cobol_store_binary" set ref 228* 269* 286* 311* 330* 358* 494* 496* 513* 514* type 3 based fixed bin(17,0) level 2 in structure "data_name" dcl 3-16 in procedure "cobol_store_binary" ref 160 224 437 545 type based fixed bin(17,0) level 2 in structure "input_struc" dcl 2-32 in procedure "cobol_store_binary" set ref 218* 491* type based fixed bin(17,0) level 2 in structure "input_struc_basic" dcl 2-23 in procedure "cobol_store_binary" set ref 453* unspec builtin function dcl 651 ref 594 630 what_reg 000152 automatic fixed bin(17,0) level 2 dcl 148 set ref 273* 315* 586* 623* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. addrel builtin function dcl 651 binary builtin function dcl 651 cobol_type100_ptr automatic pointer dcl 1-9 desc_an based structure level 1 packed packed unaligned dcl 2-103 desc_an_ptr automatic pointer dcl 2-119 desc_nn based structure level 1 packed packed unaligned dcl 2-122 desc_nn_ptr automatic pointer dcl 2-118 dn_ptr automatic pointer dcl 156 immed_const_ptr automatic pointer dcl 6-12 index builtin function dcl 651 inst_struc based structure level 1 dcl 2-66 length builtin function dcl 651 rel builtin function dcl 651 reloc_struc based structure array level 1 unaligned dcl 2-44 rtc_alphalit internal static fixed bin(15,0) initial dcl 5-7 rtc_commdesc internal static fixed bin(15,0) initial dcl 5-17 rtc_condname internal static fixed bin(15,0) initial dcl 5-15 rtc_dataname internal static fixed bin(15,0) initial dcl 5-13 rtc_debugenable internal static fixed bin(15,0) initial dcl 5-28 rtc_debugitems internal static fixed bin(15,0) initial dcl 5-18 rtc_diag internal static fixed bin(15,0) initial dcl 5-9 rtc_eos internal static fixed bin(15,0) initial dcl 5-23 rtc_equate_tag internal static fixed bin(15,0) initial dcl 5-35 rtc_fdec_temp internal static fixed bin(15,0) initial dcl 5-37 rtc_filedef internal static fixed bin(15,0) initial dcl 5-16 rtc_groupname internal static fixed bin(15,0) initial dcl 5-25 rtc_indexname internal static fixed bin(15,0) initial dcl 5-14 rtc_internal_tag internal static fixed bin(15,0) initial dcl 5-34 rtc_mnemonic internal static fixed bin(15,0) initial dcl 5-21 rtc_numlit internal static fixed bin(15,0) initial dcl 5-6 rtc_pararef internal static fixed bin(15,0) initial dcl 5-22 rtc_picstring internal static fixed bin(15,0) initial dcl 5-8 rtc_procdef internal static fixed bin(15,0) initial dcl 5-11 rtc_reportentry internal static fixed bin(15,0) initial dcl 5-26 rtc_reportname internal static fixed bin(15,0) initial dcl 5-24 rtc_resword internal static fixed bin(15,0) initial dcl 5-5 rtc_savedarea internal static fixed bin(15,0) initial dcl 5-19 rtc_sortmerge internal static fixed bin(15,0) initial dcl 5-20 rtc_source internal static fixed bin(15,0) initial dcl 5-10 rtc_unknown1 internal static fixed bin(15,0) initial dcl 5-27 rtc_unknown2 internal static fixed bin(15,0) initial dcl 5-29 rtc_unknown3 internal static fixed bin(15,0) initial dcl 5-30 rtc_unknown4 internal static fixed bin(15,0) initial dcl 5-31 rtc_unknown5 internal static fixed bin(15,0) initial dcl 5-32 rtc_unknown6 internal static fixed bin(15,0) initial dcl 5-33 rtc_userwd internal static fixed bin(15,0) initial dcl 5-12 string builtin function dcl 651 NAMES DECLARED BY EXPLICIT CONTEXT. cobol_store_binary 000012 constant entry external dcl 33 difficult_store 001006 constant entry internal dcl 384 ref 174 easy_store 000135 constant entry internal dcl 193 ref 176 exit 000134 constant label dcl 177 exit_difficult_store 001467 constant label dcl 524 exit_easy_store 001005 constant label dcl 377 exit_get_length 001523 constant label dcl 561 exit_immed_to_index 001612 constant label dcl 601 exit_immed_to_register 001711 constant label dcl 641 get_length 001470 constant entry internal dcl 531 ref 171 172 immed_to_index 001524 constant entry internal dcl 567 ref 165 immed_to_register 001613 constant entry internal dcl 606 ref 167 start 000017 constant label dcl 160 start_difficult_store 001010 constant label dcl 432 start_easy_store 000137 constant label dcl 210 start_get_length 001472 constant label dcl 545 start_immed_to_index 001526 constant label dcl 586 start_immed_to_register 001615 constant label dcl 623 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2060 2116 1713 2070 Length 2450 1713 36 316 145 2 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_store_binary 252 external procedure is an external procedure. easy_store internal procedure shares stack frame of external procedure cobol_store_binary. difficult_store internal procedure shares stack frame of external procedure cobol_store_binary. get_length internal procedure shares stack frame of external procedure cobol_store_binary. immed_to_index internal procedure shares stack frame of external procedure cobol_store_binary. immed_to_register internal procedure shares stack frame of external procedure cobol_store_binary. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 ldx_du_inst immed_to_index 000011 direct_lower_inst immed_to_register STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_store_binary 000100 source_length cobol_store_binary 000101 target_length cobol_store_binary 000102 temp_source_ptr cobol_store_binary 000104 temp_ptr cobol_store_binary 000106 input_buff cobol_store_binary 000132 inst_buff cobol_store_binary 000136 reloc_buff cobol_store_binary 000150 temp_op cobol_store_binary 000152 register_struc cobol_store_binary 000164 input_ptr cobol_store_binary 000166 inst_ptr cobol_store_binary 000170 reloc_ptr cobol_store_binary 000206 temp_length difficult_store 000207 ret_offset difficult_store 000210 temp_op difficult_store 000212 temp_source_ptr difficult_store 000214 temp_dec_token_ptr difficult_store 000216 temp_bin_token_ptr difficult_store THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out return_mac mdfx1 ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_addr cobol_alloc$stack cobol_emit cobol_make_reg_token cobol_make_type9$decimal_9bit cobol_make_type9$long_bin cobol_make_type9$short_bin cobol_register$load cobol_register$release cobol_short_to_longbin$register NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 33 000006 160 000017 164 000025 165 000027 167 000045 168 000055 171 000060 172 000071 174 000102 176 000121 177 000134 193 000135 210 000137 214 000143 215 000145 216 000147 218 000151 219 000153 220 000156 221 000157 222 000160 224 000161 228 000166 229 000171 231 000204 235 000216 238 000225 240 000231 241 000246 248 000247 250 000260 252 000264 253 000271 254 000276 258 000313 263 000314 269 000317 270 000320 273 000333 274 000335 275 000337 276 000340 277 000344 279 000355 282 000366 283 000372 286 000407 287 000414 289 000427 292 000440 293 000444 300 000461 301 000464 303 000475 307 000476 311 000503 312 000504 315 000517 316 000521 317 000523 318 000524 319 000530 321 000541 323 000555 324 000561 325 000566 327 000573 330 000610 331 000615 333 000630 335 000644 337 000650 338 000655 341 000662 346 000677 347 000702 349 000713 353 000714 355 000716 358 000727 359 000734 361 000747 364 000761 366 000765 371 001002 377 001005 384 001006 432 001010 434 001012 435 001014 437 001016 440 001023 443 001032 444 001034 447 001051 448 001053 450 001073 453 001076 454 001100 455 001102 456 001103 457 001106 459 001110 462 001123 464 001136 466 001143 469 001145 470 001151 473 001166 474 001174 475 001205 477 001206 481 001207 483 001216 484 001220 487 001234 488 001236 491 001260 492 001262 493 001265 494 001266 495 001270 496 001272 497 001274 498 001276 501 001311 502 001315 507 001332 508 001353 509 001355 511 001401 513 001416 514 001421 515 001424 518 001437 519 001443 522 001460 523 001463 524 001467 531 001470 545 001472 549 001477 553 001511 557 001516 558 001520 560 001521 561 001523 567 001524 586 001526 588 001530 589 001532 590 001533 593 001544 594 001552 596 001560 599 001600 601 001612 606 001613 623 001615 625 001617 626 001621 627 001622 630 001633 632 001642 634 001653 637 001657 640 001677 641 001711 ----------------------------------------------------------- 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