COMPILATION LISTING OF SEGMENT cobol_binary_check 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 0938.9 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_binary_check.pl1 Reformatted code to new Cobol standard. 19* END HISTORY COMMENTS */ 20 21 22 /* Modified on 9/12/76 by Bob Chang to fix the bug for binary check for addend. */ 23 /*{*/ 24 25 /* format: style3 */ 26 cobol_binary_check: 27 proc (in_token_ptr, binary_ok, target_code, source_code); 28 29 /* 30*This procedure scans the input token for an arithmetic 31*statement, and determines whether the receiving variables 32*(targets) and the operands in the expression to be evaluated 33*are of the proper type and number so that the computation may 34*be done in the hardware registers (A, Q, and index registers) 35*rather than by using EIS instructions. 36* 37*For this implementation, arithmetic computations will be done 38*in the registers only if the following conditions are true: 39* 40* 1. all target variables are fixed binary. (long or 41* short) 42* 2. the number of operands in the expression is less 43* than or equal to 2. 44* 3. all operands in the expression are fixed binary, 45* figurative constant zero, or constants that can be 46* contained in a binary datum. 47* 4. none of the short binary targets or operands 48* appearing in the statement are elements of arrays. 49* 5. none of the receiving variables has the 50* "rounded" bit on. 51* 52*Since the input token for the arithmetic statements is different 53*for each type of statement, there is one entry point in this 54*procedure for each arithmetic statement for which binary 55*arithmetic could be performed. The entry points are listed here: 56* 1. compute 57* 2. add (also subtract) 58* 3. multiply 59* 4. divide 60* 61**/ 62 63 /* DECLARATION OF THE PARAMETERS */ 64 65 /* dcl in_token_ptr ptr; */ 66 /* Declared below in an include file */ 67 dcl binary_ok bit (1); 68 dcl target_code fixed bin; 69 dcl source_code fixed bin; 70 71 /* DESCRIPTION OF THE PARAMETERS */ 72 73 /* 74*PARAMETER DESCRIPTION 75* 76*in_token_ptr Pointer to an input token that contains 77* a description of the statement. (input) 78* See each entry point within this procedure 79* for precise details of the contents of the 80* input token structure. 81*binary_ok A flag that is set to "1"b by this procedure 82* if all of the criteria for performing 83* arithmetic in the registers are met. (output) 84*target_code 85*source_code Codes that indicate the type of the largest 86* target and source variable respectively. 87* (output) Possible values are: 88* 89* value | meaning 90* =================================================== 91* 1 | largest variable is short binary 92* 2 | largest variable is long binary 93* ========================================= 94* 95**/ 96 97 98 /* DECLARATIONS OF EXTERNAL ENTRIES */ 99 100 dcl cobol_bin_const_ck ext entry (ptr, bit (1), fixed bin); 101 102 /* DECLARATIONS OF COMMON INTERNAL VARIABLES */ 103 104 dcl give_up bit (1); 105 dcl divide_flag bit (1); 106 dcl rounded_flag bit (1); 107 dcl temp_target_code fixed bin; 108 dcl temp_source_code fixed bin; 109 110 dcl ix fixed bin; 111 dcl iy fixed bin; 112 113 dcl eos_flag bit (1); 114 dcl source_op_count fixed bin; 115 dcl dn_ptr ptr; 116 117 118 /*************************************************/ 119 /* ENTRY POINT: compute */ 120 /**************************************************/ 121 122 compute: 123 entry (in_token_ptr, binary_ok, target_code, source_code); 124 125 126 /* 127* 128*INPUT 129* 130*The input to this procedure is a structure, which is defined by a 131*declaration of the following format: 132* 133*dcl 1 in_token based (in_token_ptr), 134* 2 n fixed bin, 135* 2 code fixed bin, 136* 2 token_ptr ( 0 refer (in_token.n)) ptr; 137* 138* where: 139* 140* in_token.n contains the number of entries in the 141* token_ptr array. 142* 143* token_ptr(1) contains a pointer to a reserved word token 144* (type 1) for the reserved word COMPUTE. This pointer is 145* not used by this procedure. 146* 147*token_ptr(n) contains a pointer to an EOS (type 19) token. The 148* type 19 token contains some information that is very 149* meaningful to this procedure. 150* 151* 1. end_stmt.verb contains the code for the 152* reserved word COMPUTE. 153* 154* 2. end_stmt.e contains a count of the number 155* of data items that are to receive the result of the 156* computation. 157* 158* 3. end_stmt.b is set to "1"b if the compute 159* statement contained an ON SIZE ERROR 160* clause. 161* 162* token_ptr(2) through token_ptr(n-1) point to tokens 163* that describe: 164* 165* 1. the data items that are to receive the 166* result of the computation. (all are data name 167* (type 9) tokens) 168* 169* 2. the tokens for the operands to be used in 170* evaluating the arithmetic expression. These 171* tokens can be data name (type 9) tokens, numeric 172* literal (type 2) tokens, or the figurative 173* constant ZERO (type 1) token. 174* 175* 3. the tokens that describe the arithmetic 176* operators to be used in evaluating the 177* arithmetic expression. These tokens are EOS 178* tokens (type 19). The contents of the field 179* end_stme.e in these type 19 tokens specifies 180* the operator. 181* 182* 183* end_stmt.e | operator 184* --------------------------------------------- 185* 182 | + (binary plus) 186* 183 | - (binary minus) 187* 184 | * (multiply) 188* 185 | / (divide) 189* 186 | ** (exponentiate) 190* 187 | - (unary minus) 191* 192* 193*The data name tokens, and EOS tokens that specify operators, 194*are arranged in trailing polish notation in the token_ptr 195*array. That is, each operator follows the operand (for unary operators) 196*or the two operands (for binary operators) to which it applies. 197* 198*OUTPUT 199* 200*The second parameter passed to cobol_compute_gen is an output para- 201*meter. A value is returned to the calling program 202*(cobol_gen_driver_) only for those compute statements that have on 203*size error clauses. 204* 205*If an on size error clause is specified, then, in addition to 206*the code that evaluates the arithmetic expression, and assigns 207*it to the receiving data items, cobol_compute_gen must also generate 208*code that checks for size error conditions. If a size error is 209*detected by the execution of the generated code, then the 210*imperative statement in the COMPUTE statement is executed, otherwise 211*the imperative statement is skipped. The cobol_compute_gen 212*generator, however, when generating code to skip over the imperative 213*statmeent to the next statement, does not know anything about 214*the next statement. This situation is handled as follows: 215* 216* 1. cobol_compute_gen reserves a tag for the next Cobol 217* statement. 218* 2. any transfers to the next statement reference 219* the tag reserved by cobol_compute_gen. This tag is not yet 220* defined. (associated with an instruction location in 221* the text segment) 222* 3. after generation of code for a compute statement is 223* completed, cobol_compute_gen passes the next statement tag 224* back to its caller, cobol_gen_driver_, in the second 225* parameter. 226* 4. when cobol_gen_driver_ detects the end of the imperative 227* statement, the tag, reserved by cobol_compute_gen, is 228* defined. 229* 230**/ 231 232 /**************************************************/ 233 /* START OF EXECUTION */ 234 /* ENTRY POINT: compute */ 235 /**************************************************/ 236 237 238 give_up = "0"b; 239 target_code = 0; 240 temp_source_code = 0; 241 temp_target_code = 0; 242 eos_ptr = in_token.token_ptr (in_token.n); 243 divide_flag = "0"b; 244 rounded_flag = "0"b; 245 246 /* Check to see if all receiving variables are long or short binary. */ 247 248 do ix = 1 to end_stmt.e while (give_up = "0"b); /* Check targets */ 249 250 if in_token.token_ptr (1 + ix) -> data_name.rounded 251 then rounded_flag = "1"b; 252 if in_token.token_ptr (1 + ix) -> data_name.bin_36 253 then temp_target_code = 2; 254 else if in_token.token_ptr (1 + ix) -> data_name.bin_18 255 & in_token.token_ptr (1 + ix) -> data_name.subscripted = "0"b 256 then temp_target_code = 1; 257 else give_up = "1"b; /* Target not either long or short binary. */ 258 259 if give_up = "0"b 260 then if temp_target_code > target_code 261 then target_code = temp_target_code; 262 263 end; /* Check targets */ 264 265 /* Now check to see whether: 266* 1. There are two or less operands in the expression. 267* 2. Each operand is a long or short binary, the fig constant aero, or a constant 268* that can be contained in a fixed binary datum. 269* 3. The only operators are unary minus, binary plus, and binary minus (this implementation) 270* */ 271 272 if give_up = "0"b 273 then do; /* All targets are fixed binary, check the expression. */ 274 275 source_code = 0; 276 source_op_count = 0; 277 278 do iy = ix + 1 to in_token.n - 1 while (give_up = "0"b); 279 /* Look at the expression */ 280 281 eos_flag = "0"b; 282 283 284 285 if in_token.token_ptr (iy) -> data_name.type = rtc_resword 286 then temp_source_code = 1; 287 else if in_token.token_ptr (iy) -> data_name.type = rtc_numlit 288 then call cobol_bin_const_ck (in_token.token_ptr (iy), give_up, temp_source_code); 289 else if in_token.token_ptr (iy) -> data_name.type = rtc_eos 290 then do; /* EOS TOKEN, must check the operator */ 291 eos_flag = "1"b; 292 if in_token.token_ptr (iy) -> end_stmt.e = 186 293 /* exponentiate */ 294 then give_up = "1"b; 295 if in_token.token_ptr (iy) -> end_stmt.e = 185 296 then divide_flag = "1"b; 297 end; /* EOS TOKEN, must check the operator */ 298 else if in_token.token_ptr (iy) -> data_name.type = rtc_dataname 299 then do; /* Check to see if fixed binary */ 300 if in_token.token_ptr (iy) -> data_name.bin_36 301 then temp_source_code = 2; 302 else if (in_token.token_ptr (iy) -> data_name.bin_18 303 & in_token.token_ptr (iy) -> data_name.subscripted = "0"b) 304 then temp_source_code = 1; 305 else give_up = "1"b; 306 end; /* Check to see if fixed binary */ 307 308 if (give_up = "0"b & eos_flag = "0"b) 309 then do; /* Current token ok, check operand count. */ 310 311 if source_op_count = 2 312 then give_up = "1"b; /* Two operands already. */ 313 else do; /* Increment operand count */ 314 source_op_count = source_op_count + 1; 315 if temp_source_code > source_code 316 then source_code = temp_source_code; 317 end; /* Increment the sount of the operands in the expression */ 318 319 end; /* Current token OK, Check operand count. */ 320 321 end; /* Look at expression. */ 322 323 /* If the operation was divide, and any of the receiving fields had the 324* rounding bit on, then we don't want to do arithmetic in the hardware registers. 325* Instead we want to do decimal (EIS) arithmetic, with rounding. 326* */ 327 if divide_flag & rounded_flag 328 then give_up = "1"b; 329 330 end; /* All targets fixed binary, check the expression. */ 331 332 binary_ok = ^give_up; 333 334 return; 335 336 337 add: 338 entry (in_token_ptr, binary_ok, target_code, source_code); 339 340 /* 341*This entry point scans the input token for add and subtract 342*statements, and determines whether the add or subtract can be 343*done in the hardware registers, rather than by using EIS 344*instructions. 345**/ 346 347 348 /* 349* 350*INPUT 351* 352*The input to this procedure is a structure, which is defined by a 353*declaration of the following format: 354* 355*dcl 1 in_token based (in_token_ptr), 356* 2 n fixed bin, 357* 2 code fixed bin 358* 2 token_ptr ( 0 refer (in_token.n)) ptr; 359* 360* where: 361* 362* in_token.n contains the number of entries in the 363* token_ptr array. 364* 365* token_ptr(1) contains a pointer to a reserved word token 366* (type 1) for the reserved word ADD. This pointer is 367* not used by this procedure. 368* 369* token_ptr(n) contains a pointer to an EOS (type 19) token. 370* A declaration that describes the contents of the EOS 371* token is given following the executable statements 372* of this procedure in an include file. The type 19 373* token contains the following information that is 374* used by this procedure. 375* 376* 1. end_stmt.verb contians the code for the 377* reserved word ADD. 378* 2. end_stmt.a defines the format of the ADD 379* statement: 380* 381* value of end_stmt.a | Add stmt format 382* ---------------------------------------- 383* "000"b | format 1 384* "001"b | format 2 385* 386* 3. end_stmt.b is "1"b if this ADD statement 387* had an ON SIZE ERROR clause 388* 4. end_stmt.e contans the count of the 389* number of operands to the LEFT of "TO" for 390* format 1 ADD statements, or to the LEFT of 391* "GIVING" for format 2 ADD statements. 392* 5, end_stmt.h contians the count of the number 393* of operands to the RIGHT of "TO" for 394* format 1 ADD statements, or to the RIGHT of 395* "GIVING" for format 2 ADD statements. 396* 6. end_stmt.i contains the composite count 397* of the digits to the left of the decimal 398* pint. (???) 399* 7. end_stmt.j contians the composite count 400* of the digits to the right of the decimal 401* point. (???) 402* 403* token_ptr(2) through token_ptr(n-1) point th tokens 404* that describe: 405* 406* 1. the data items to be added together. 407* These tokens can be data name (type 9) tokens 408* numeric literal (type 2) tokens, or the 409* figurative constant ZERO (type 1) token. 410* 2. the data items to receive the result of 411* the addition. These tokens are always data 412* name (type 9) tokens. 413* 414* 415*OUTPUT 416* 417*The second parameter passed to cobol_add_gen is an output parameter. 418*A value is returned to the calling procedure, cobol_gee_driver_, 419*only for those add astatments that have on size error clauses. 420*If an on size error clause is specified, then, in addition to 421*the code that evaluates the sum, and assigns it to the receiving 422*data items, cobol_add_gen must also generate code that checks for 423*size error conditions. If a size error is detected by the execution 424*of the generated code, then the imperative statement in the ADD 425*statment is executed, otherwise the imperative statement is 426*skipped. The cobol_add_gen generator, however, when generating 427*code to skip over the imperative statement to the next statement, 428*does not know anything about the next statement. This situation 429*is handled as follows: 430* 431* 1. cobol_add_gen reserves a tag for the next COBOL 432* statement. 433* 2. any transfers to the next statement reference the 434* tag reserved by cobol_add_gen. This tag is not yet 435* defined. (associated with an instruction location in 436* the text segment) 437* 3. after generation of code for an add statement is 438* completed, cobol_add_gen passes the next statement tag 439* back to its caller, cobol_gen_driver_, in the second 440* parameter. 441* 4. when cobol_gen_driver_ detects the end of the imperative 442* statement, the tag, reserved by cobol_add_gen, is 443* defined. 444**/ 445 446 /**************************************************/ 447 /* START OF EXECUTION */ 448 /* ENTRY POINT: */ 449 /* add */ 450 /**************************************************/ 451 452 eos_ptr = in_token.token_ptr (in_token.n); 453 give_up = "0"b; 454 455 if end_stmt.a = "000"b 456 then do; /* A format 1 add or subtract statement. */ 457 458 /* Check to see that there is only one addend, and that that addend is 459* either long or short binry, the fig. constant ZERO, or a numeric literal 460* that can be contained in a fixed binary. */ 461 if end_stmt.e ^= 1 462 then give_up = "1"b; 463 else if in_token.token_ptr (2) -> data_name.type = rtc_resword 464 then source_code = 1; 465 else if in_token.token_ptr (2) -> data_name.type = rtc_numlit 466 then call cobol_bin_const_ck (in_token.token_ptr (2), give_up, source_code); 467 else if (in_token.token_ptr (2) -> data_name.bin_18 468 & in_token.token_ptr (2) -> data_name.subscripted = "0"b) 469 then source_code = 1; 470 else if in_token.token_ptr (2) -> data_name.bin_36 471 then source_code = 2; 472 else give_up = "1"b; 473 474 if give_up = "0"b 475 then do; /* Addend ok, check all augends (minuends) */ 476 /* All must be long or short binary. */ 477 target_code = 0; 478 do ix = 3 to in_token.n - 1 while (give_up = "0"b); 479 if (in_token.token_ptr (ix) -> data_name.bin_18 = "0"b) 480 & (in_token.token_ptr (ix) -> data_name.bin_36 = "0"b) 481 then give_up = "1"b; 482 else if in_token.token_ptr (ix) -> data_name.bin_18 483 & (in_token.token_ptr (ix) -> data_name.subscripted) 484 then give_up = "1"b; 485 end; 486 487 end; /* Addend ok, check all augends (minuends) */ 488 end; /* A format 1 add or subtract statement. */ 489 490 491 else do; /* A format 2 add or subtract statement. */ 492 /* In order to do arithmetic in the registers, the follwoing conditions must be true: 493* 1. Exactly 2 operands to be added. 494* 2. All operands to be added or long or short fixed binary, fig. 495* constant ZERO, or a numlit that can be contained in a fixed binary. 496* 3. All receiving fields must be fixed binary. 497* */ 498 499 if (end_stmt.verb = 2 /*add*/ & end_stmt.e ^= 2) | (end_stmt.verb = 11 /*subtract*/ & end_stmt.e ^= 1) 500 then give_up = "1"b; 501 else do; /* 2 operands, check them. */ 502 source_code = 0; 503 do ix = 2, 3 while (give_up = "0"b); 504 505 if in_token.token_ptr (ix) -> data_name.type = rtc_resword 506 then temp_source_code = 1; 507 else if in_token.token_ptr (ix) -> data_name.type = rtc_numlit 508 then call cobol_bin_const_ck (in_token.token_ptr (ix), give_up, temp_source_code); 509 else if (in_token.token_ptr (ix) -> data_name.bin_18 510 & in_token.token_ptr (ix) -> data_name.subscripted = "0"b) 511 then temp_source_code = 1; 512 else if in_token.token_ptr (ix) -> data_name.bin_36 513 then temp_source_code = 2; 514 else give_up = "1"b; 515 516 if give_up = "0"b 517 then if temp_source_code > source_code 518 then source_code = temp_source_code; 519 end; 520 end; /* 2 operands, check them. */ 521 522 if give_up = "0"b 523 then do; /* All addends ok, check the receiving fields. */ 524 /* All receiving fields must be long or short binary cobol data items. */ 525 target_code = 0; 526 527 do ix = 4 to in_token.n - 1 while (give_up = "0"b); 528 529 if in_token.token_ptr (ix) -> data_name.bin_18 530 & in_token.token_ptr (ix) -> data_name.subscripted = "0"b 531 then temp_target_code = 1; 532 else if in_token.token_ptr (ix) -> data_name.bin_36 533 then temp_target_code = 2; 534 else give_up = "1"b; 535 536 if give_up = "0"b 537 then if temp_target_code > target_code 538 then target_code = temp_target_code; 539 540 end; 541 end; /* All addends ok, check the receiving fields. */ 542 543 end; /* A format 2 add or subtract statement. */ 544 545 binary_ok = ^give_up; 546 547 /**************************************************/ 548 /* RETURN POINT */ 549 /* add */ 550 /**************************************************/ 551 552 return; 553 554 /**************************************************/ 555 /* ENTRY POINT: divide */ 556 /**************************************************/ 557 558 divide: 559 entry (in_token_ptr, binary_ok, target_code, source_code); 560 561 562 /* DESCRIPTION OF THE PARAMETERS */ 563 /* 564* 565*PARAMETER DESCRIPTION 566* 567*in_token_ptr Points to the in_token structure, which 568* contains information describing the DIVIDE 569* statement for which code is to be 570* generated. (input) See the description 571* below under INPUT for the exact contents of 572* the input structure. 573* NOTE: This parameter is declared in an include 574* file following the executable statements 575* of this procedure. 576*next_stmt_tag Contains a compiler generated tag number 577* (label) to be associated by the code 578* generator driver with the Cobol statement 579* that follows the DIVIDE statement for which this 580* procedure was called. (output) See 581* the discussion below under OUTPUT 582* for more details. 583**/ 584 /* 585* 586*INPUT 587* 588*The input to this procedure is a structure, which is defined by a 589*declaration of the following format: 590* 591*dcl 1 in_token based (in_token_ptr), 592* 2 n fixed bin, 593* 2 code fixed bin 594* 2 token_ptr ( 0 refer (in_token.n)) ptr; 595* 596* where: 597* 598* in_token.n contains the number of entries in the 599* token_ptr array. 600* 601* token_ptr(1) contains a pointer to a reserved word token 602* (type 1) for the reserved word DIVIDE. This pointer is 603* not used by this procedure. 604* 605* token_ptr(n) contains a pointer to an EOS (type 19) token. 606* A declaration that describes the contents of the EOS 607* token is given following the executable statements 608* of this procedure in an include file. The type 19 609* token contains the following information that is 610* used by this procedure. 611* 612* 1. end_stmt.verb contains the code for the 613* reserved word DIVIDE. 614* 2. end_stmt.a defines the format of the DIVIDE 615* statement: 616* 617* value of end_stmt.a | divide stmt format 618* ---------------------------------------- 619* "000"b | format 1 620* "001"b | format 2 621* "010"b | format 3 622* "011"b | format 4 623* "100"b | format 5 624* 625* 626* 3. end_stmt.b is "1"b if this DIVIDE statement 627* had an ON SIZE ERROR clause 628* 4. end_stmt.e contains the count of the 629* number of operands to the RIGHT of "INTO" for 630* format 1 DIVIDE statements. 631* 5, end_stmt.h contians the count of the number 632* of operands to the RIGHT of "GIVING" for 633* format 2 and format 3 DIVIDE statements. 634* 635* token_ptr(2) through token_ptr(n-1) point to tokens 636* that describe: 637* 638* 1. the data items to be multiplied together. 639* These tokens can be data name (type 9) tokens 640* numeric literal (type 2) tokens. 641* 2. the data items to receive the result of 642* the addition. These tokens are always data 643* name (type 9) tokens. 644* 645*dcl temp_code fixed bin; 646* 647* 648*/**************************************************/ 649 /* START OF EXECUTION */ 650 /* ENTRY POINT: divide */ 651 /**************************************************/ 652 653 give_up = "0"b; 654 target_code = 2; /* divide uses long binary arithmetic (A and Q) always. */ 655 source_code = 2; 656 eos_ptr = in_token.token_ptr (in_token.n); 657 658 if end_stmt.a = "000"b 659 then do; /* Format 1 divide */ 660 call div_operand_check (in_token.token_ptr (2), give_up); 661 if give_up = "0"b 662 then do; /* Divisor ok, check the receiving fields. */ 663 do ix = 3 to in_token.n - 1 while (give_up = "0"b); 664 call div_target_check (in_token.token_ptr (ix), give_up, 2); 665 end; 666 end; /* Divisor ok, check the receiving fields. */ 667 end; /* Format 1 divide. */ 668 669 else if (end_stmt.a = "001"b | end_stmt.a = "010"b) 670 then do; /* Format 2 or Format 3 divide. */ 671 /* Check divisor or dividend first. */ 672 /* Note that it makes no difference whether we check the divisor 673* first (Format 2) or dividend first (Format 3). */ 674 call div_operand_check (in_token.token_ptr (2), give_up); 675 if give_up = "0"b 676 then do; /* Check other operand, and the targets. */ 677 call div_operand_check (in_token.token_ptr (3), give_up); 678 if give_up = "0"b 679 then do; /* Check the targets. */ 680 do ix = 4 to in_token.n - 1 while (give_up = "0"b); 681 call div_target_check (in_token.token_ptr (ix), give_up, 2); 682 end; 683 end; /* Check the targets. */ 684 end; /* Check other operand, and the targets. */ 685 end; /* Format 2 or Format 3 divide. */ 686 687 688 else do; /* Must be a Format 4 or Format 5 divide. */ 689 /* Check the dividend and divisor first. */ 690 /* Note that it makes no difference whether we check divisor or dividend first. */ 691 call div_operand_check (in_token.token_ptr (2), give_up); 692 if give_up = "0"b 693 then call div_operand_check (in_token.token_ptr (3), give_up); 694 /* Now check the receiving field. */ 695 if give_up = "0"b 696 then call div_target_check (in_token.token_ptr (4), give_up, 2); 697 /* Now check the remainder field. */ 698 if give_up = "0"b 699 then call div_target_check (in_token.token_ptr (5), give_up, 2); 700 end; /* Must be Format 4 or Format 5 divide. */ 701 702 binary_ok = ^give_up; 703 704 return; 705 706 /*************************************************/ 707 /* ENTRY POINT: multiply */ 708 /**************************************************/ 709 710 multiply: 711 entry (in_token_ptr, binary_ok, target_code, source_code); 712 713 714 /* DESCRIPTION OF THE PARAMETERS */ 715 /* 716* 717*PARAMETER DESCRIPTION 718* 719*in_token_ptr Points to the in_token structure, which 720* contains information describing the MULTIPLY 721* statement for which code is to be 722* generated. (input) See the description 723* below under INPUT for the exact contents of 724* the input structure. 725* NOTE: This parameter is declared in an include 726* file following the executable statements 727* of this procedure. 728*next_stmt_tag Contains a compiler generated tag number 729* (label) to be associated by the code 730* generator driver with the Cobol statement 731* that follows the MULTIPLY statement for which this 732* procedure was called. (output) See 733* the discussion below under OUTPUT 734* for more details. 735**/ 736 /* 737* 738*INPUT 739* 740*The input to this procedure is a structure, which is defined by a 741*declaration of the following format: 742* 743*dcl 1 in_token based (in_token_ptr), 744* 2 n fixed bin, 745* 2 code fixed bin 746* 2 token_ptr ( 0 refer (in_token.n)) ptr; 747* 748* where: 749* 750* in_token.n contains the number of entries in the 751* token_ptr array. 752* 753* token_ptr(1) contains a pointer to a reserved word token 754* (type 1) for the reserved word MULTIPLY. This pointer is 755* not used by this procedure. 756* 757* token_ptr(n) contains a pointer to an EOS (type 19) token. 758* A declaration that describes the contents of the EOS 759* token is given following the executable statements 760* of this procedure in an include file. The type 19 761* token contains the following information that is 762* used by this procedure. 763* 764* 1. end_stmt.verb contains the code for the 765* reserved word MULTIPLY. 766* 2. end_stmt.a defines the format of the MULTIPLY 767* statement: 768* 769* value of end_stmt.a | Mpy stmt format 770* ---------------------------------------- 771* "000"b | format 1 772* "001"b | format 2 773* 774* 3. end_stmt.b is "1"b if this MULTIPLY statement 775* had an ON SIZE ERROR clause 776* 4. end_stmt.e contains the count of the 777* number of operands to the RIGHT of "BY" for 778* format 1 MULTIPLY statements. 779* 5, end_stmt.h contians the count of the number 780* of operands to the RIGHT of "GIVING" for 781* format 2 MULTIPLY statements. 782* 783* token_ptr(2) through token_ptr(n-1) point to tokens 784* that describe: 785* 786* 1. the data items to be multiplied together. 787* These tokens can be data name (type 9) tokens 788* numeric literal (type 2) tokens. 789* 2. the data items to receive the result of 790* the multiplication. These tokens are always data 791* name (type 9) tokens. 792* 793*/**************************************************/ 794 /* START OF EXECUTION */ 795 /* ENTRY POINT: multiply */ 796 /**************************************************/ 797 798 give_up = "0"b; 799 source_code = 2; /* Multiplication is always done in the A and Q. (long fixed bin operands) */ 800 target_code = 2; 801 eos_ptr = in_token.token_ptr (in_token.n); 802 803 if end_stmt.a = "000"b 804 then do; /* Format 1 multiply. */ 805 /* Check the multiplicand. */ 806 call div_operand_check (in_token.token_ptr (2), give_up); 807 if give_up = "0"b 808 then do; /* Check all targets. */ 809 do ix = 3 to in_token.n - 1 while (give_up = "0"b); 810 call div_target_check (in_token.token_ptr (ix), give_up, 1); 811 end; 812 end; /* Check all targets. */ 813 end; /* Format 1 multiply. */ 814 815 else do; /* Format 2 multiply. */ 816 /* Check multiplicand. */ 817 call div_operand_check (in_token.token_ptr (2), give_up); 818 if give_up = "0"b 819 then do; /* Multiplicand ok, check multiplier and targets. */ 820 /* Check multiplier. */ 821 call div_operand_check (in_token.token_ptr (3), give_up); 822 if give_up = "0"b 823 then do; /* Multiplier ok, check targets. */ 824 do ix = 4 to in_token.n - 1 while (give_up = "0"b); 825 call div_target_check (in_token.token_ptr (ix), give_up, 1); 826 end; 827 end; /* Multiplier ok, check targets. */ 828 end; /* Multiplicand ok, check multiplier and targets. */ 829 end; /* Format 2 multiply. */ 830 831 binary_ok = ^give_up; 832 833 return; 834 835 836 div_operand_check: 837 proc (operand_token_ptr, give_up_flag); 838 839 /* 840*This internal procedure tests an operand of a divide 841*or multiply statement to determine whether the operand is of the 842*proper type and size so that the divide or multiply can be done 843*in the hardware registers. (A and Q) */ 844 845 /* DECLARATION OF THE PARAMETERS */ 846 847 dcl operand_token_ptr ptr; 848 dcl give_up_flag bit (1); 849 850 851 /* DESCRIPTION OF THE PARAMETERS */ 852 853 /* 854*PARAMETER DESCRIPTION 855* 856*operand_token_ptr Pointer to the token that describes the 857* operand to be checked. (input) This token 858* can be a data name token (type 9), a numeric 859* literal token (type 2), or a reserved word 860* token (type 1) for the figurative constant 861* ZERO. 862*give_up_flag A flag that is set to "1"b by this procedure 863* if the operand does not allow code to be 864* generated in the hardware registers. 865* (output) 866* 867**/ 868 869 dcl temp_code fixed bin; 870 871 give_up_flag = "0"b; 872 873 if operand_token_ptr -> data_name.type = rtc_dataname 874 then do; /* Operand token is a data name token. */ 875 /* Operand must be long or short binary. If short binary cannot be an element 876* of an array. */ 877 if (operand_token_ptr -> data_name.bin_36 = "0"b & operand_token_ptr -> data_name.bin_18 = "0"b) 878 then give_up_flag = "1"b; 879 else if (operand_token_ptr -> data_name.bin_18 & operand_token_ptr -> data_name.subscripted) 880 then give_up_flag = "1"b; 881 end; /* Operand token is a data name token. */ 882 883 884 else if operand_token_ptr -> data_name.type = rtc_numlit 885 then call cobol_bin_const_ck (operand_token_ptr, give_up_flag, temp_code); 886 887 /* Note that if the input operand is figurative constant ZERO, we fall thru, 888* and give_up_flag is "0"b, indicating ok. */ 889 890 end div_operand_check; 891 892 893 div_target_check: 894 proc (target_token_ptr, give_up_flag, operation_code); 895 896 /* 897*This internal procedure tests a target (receiving field) of a 898*divide or multiply statement, and determines whether the target 899*is of the size and type so that the operation can be performed in 900*the hardware registers. (A and Q) 901* 902*In order to allow the operation to be performed in the A and Q, 903*the target must satisfy the followint criteria: 904* 1. Target must be long or short binary. 905* 2. Target , if short binary cannot be an element of 906* an array. 907* 3. For divide, the target cannot have the rounded option 908* specified for it. 909* 910**/ 911 912 /* DECLARATION OF THE PARAMETERS> */ 913 914 dcl target_token_ptr ptr; 915 dcl give_up_flag bit (1); 916 dcl operation_code fixed bin; 917 918 919 /* DESCRIPTION OF THE PARAMETERS */ 920 921 /* 922*PARAMETER DESCRIPTION 923* 924*target_token_ptr Pointer to a data name token that describes 925* the target (receiving field) of a divide 926* or multiply. (input) 927*give_up_flag A flag that is set to "1"b by this procedure if 928* the operand does not allow code to be 929* generated in the hardware registers.(output) 930*operation_code A code that indicates whether the target 931* is a target for a divide or multiply 932* statement. (input) This code is defined 933* in the follwoing table: 934* 935* operation code | statement 936* ========================================= 937* 1 | multiply 938* 2 | divide 939* ========================================= 940* 941**/ 942 943 944 945 give_up_flag = "0"b; 946 947 if (operation_code = 2 /*divide*/ & target_token_ptr -> data_name.rounded) 948 then give_up_flag = "1"b; 949 else if (target_token_ptr -> data_name.bin_18 = "0"b & target_token_ptr -> data_name.bin_36 = "0"b) 950 then give_up_flag = "1"b; 951 else if (target_token_ptr -> data_name.bin_18 & target_token_ptr -> data_name.subscripted) 952 then give_up_flag = "1"b; 953 954 end div_target_check; 955 956 /* NEWSTUFF HERE */ 957 958 959 /* INCLUDE FILES USED IN THIS PROCEDURE */ 960 961 962 /***** Declaration for builtin function *****/ 963 964 dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) 965 builtin; 966 967 /***** End of declaration for builtin function *****/ 968 1 1 1 2 /* BEGIN INCLUDE FILE ... cobol_type9.incl.pl1 */ 1 3 /* Last modified on 11/19/76 by ORN */ 1 4 1 5 /* 1 6*A type 9 data name token is entered into the name table by the data 1 7*division syntax phase for each data name described in the data division. 1 8*The replacement phase subsequently replaces type 8 user word references 1 9*to data names in the procedure division minpral file with the corresponding 1 10*type 9 tokens from the name table. 1 11**/ 1 12 1 13 /* dcl dn_ptr ptr; */ 1 14 1 15 /* BEGIN DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 1 16 dcl 1 data_name based (dn_ptr), 2 1 2 2 /* begin include file ... cobol_TYPE9.incl.pl1 */ 2 3 /* Last modified on 06/19/77 by ORN */ 2 4 /* Last modified on 12/28/76 by FCH */ 2 5 2 6 /* header */ 2 7 2 size fixed bin, 2 8 2 line fixed bin, 2 9 2 column fixed bin, 2 10 2 type fixed bin, 2 11 /* body */ 2 12 2 string_ptr ptr, 2 13 2 prev_rec ptr, 2 14 2 searched bit (1), 2 15 2 duplicate bit (1), 2 16 2 saved bit (1), 2 17 2 debug_ind bit (1), 2 18 2 filler2 bit (3), 2 19 2 used_as_sub bit (1), 2 20 2 def_line fixed bin, 2 21 2 level fixed bin, 2 22 2 linkage fixed bin, 2 23 2 file_num fixed bin, 2 24 2 size_rtn fixed bin, 2 25 2 item_length fixed bin(24), 2 26 2 places_left fixed bin, 2 27 2 places_right fixed bin, 2 28 /* description */ 2 29 2 file_section bit (1), 2 30 2 working_storage bit (1), 2 31 2 constant_section bit (1), 2 32 2 linkage_section bit (1), 2 33 2 communication_section bit (1), 2 34 2 report_section bit (1), 2 35 2 level_77 bit (1), 2 36 2 level_01 bit (1), 2 37 2 non_elementary bit (1), 2 38 2 elementary bit (1), 2 39 2 filler_item bit (1), 2 40 2 s_of_rdf bit (1), 2 41 2 o_of_rdf bit (1), 2 42 2 bin_18 bit (1), 2 43 2 bin_36 bit (1), 2 44 2 pic_has_l bit (1), 2 45 2 pic_is_do bit (1), 2 46 2 numeric bit (1), 2 47 2 numeric_edited bit (1), 2 48 2 alphanum bit (1), 2 49 2 alphanum_edited bit (1), 2 50 2 alphabetic bit (1), 2 51 2 alphabetic_edited bit (1), 2 52 2 pic_has_p bit (1), 2 53 2 pic_has_ast bit (1), 2 54 2 item_signed bit(1), 2 55 2 sign_separate bit (1), 2 56 2 display bit (1), 2 57 2 comp bit (1), 2 58 2 ascii_packed_dec_h bit (1), /* as of 8/16/76 this field used for comp8. */ 2 59 2 ascii_packed_dec bit (1), 2 60 2 ebcdic_packed_dec bit (1), 2 61 2 bin_16 bit (1), 2 62 2 bin_32 bit (1), 2 63 2 usage_index bit (1), 2 64 2 just_right bit (1), 2 65 2 compare_argument bit (1), 2 66 2 sync bit (1), 2 67 2 temporary bit (1), 2 68 2 bwz bit (1), 2 69 2 variable_length bit (1), 2 70 2 subscripted bit (1), 2 71 2 occurs_do bit (1), 2 72 2 key_a bit (1), 2 73 2 key_d bit (1), 2 74 2 indexed_by bit (1), 2 75 2 value_numeric bit (1), 2 76 2 value_non_numeric bit (1), 2 77 2 value_signed bit (1), 2 78 2 sign_type bit (3), 2 79 2 pic_integer bit (1), 2 80 2 ast_when_zero bit (1), 2 81 2 label_record bit (1), 2 82 2 sign_clause_occurred bit (1), 2 83 2 okey_dn bit (1), 2 84 2 subject_of_keyis bit (1), 2 85 2 exp_redefining bit (1), 2 86 2 sync_in_rec bit (1), 2 87 2 rounded bit (1), 2 88 2 ad_bit bit (1), 2 89 2 debug_all bit (1), 2 90 2 overlap bit (1), 2 91 2 sum_counter bit (1), 2 92 2 exp_occurs bit (1), 2 93 2 linage_counter bit (1), 2 94 2 rnm_01 bit (1), 2 95 2 aligned bit (1), 2 96 2 not_user_writable bit (1), 2 97 2 database_key bit (1), 2 98 2 database_data_item bit (1), 2 99 2 seg_num fixed bin, 2 100 2 offset fixed bin(24), 2 101 2 initial_ptr fixed bin, 2 102 2 edit_ptr fixed bin, 2 103 2 occurs_ptr fixed bin, 2 104 2 do_rec char(5), 2 105 2 bitt bit (1), 2 106 2 byte bit (1), 2 107 2 half_word bit (1), 2 108 2 word bit (1), 2 109 2 double_word bit (1), 2 110 2 half_byte bit (1), 2 111 2 filler5 bit (1), 2 112 2 bit_offset bit (4), 2 113 2 son_cnt bit (16), 2 114 2 max_red_size fixed bin(24), 2 115 2 name_size fixed bin, 2 116 2 name char(0 refer(data_name.name_size)); 2 117 2 118 2 119 2 120 /* end include file ... cobol_TYPE9.incl.pl1 */ 2 121 1 17 1 18 /* END DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 1 19 1 20 /* END INCLUDE FILE ... cobol_type9.incl.pl1 */ 1 21 969 970 3 1 3 2 /* BEGIN INCLUDE FILE ... cobol_type19.incl.pl1 */ 3 3 /* last modified on 11/19/76 by ORN */ 3 4 3 5 /* 3 6*A type 19 end of statement token is created in the procedure division 3 7*minpral file at the end of each minpral statement generated by the 3 8*procedure division syntax phase. A minpral statement may be a complete or 3 9*partial source language statement. A type 19 token contains information 3 10*describing the statement which it delimits. 3 11**/ 3 12 3 13 dcl eos_ptr ptr; 3 14 3 15 /* BEGIN DECLARATION OF TYPE19 (END STATEMENT) TOKEN */ 3 16 dcl 1 end_stmt based (eos_ptr), 4 1 4 2 /* begin include file ... cobol_TYPE19.incl.pl1 */ 4 3 /* Last modified on 11/17/76 by ORN */ 4 4 4 5 /* header */ 4 6 2 size fixed bin, 4 7 2 line fixed bin, 4 8 2 column fixed bin, 4 9 2 type fixed bin, 4 10 /* body */ 4 11 2 verb fixed bin, 4 12 2 e fixed bin, 4 13 2 h fixed bin, 4 14 2 i fixed bin, 4 15 2 j fixed bin, 4 16 2 a bit (3), 4 17 2 b bit (1), 4 18 2 c bit (1), 4 19 2 d bit (2), 4 20 2 f bit (2), 4 21 2 g bit (2), 4 22 2 k bit (5), 4 23 2 always_an bit (1); 4 24 4 25 /* end include file ... cobol_TYPE19.incl.pl1 */ 4 26 3 17 3 18 /* END DECLARATION OF TYPE19 (END STATEMENT) TOKEN */ 3 19 3 20 /* 3 21*FIELD CONTENTS 3 22* 3 23*size The total size in bytes of this end of statement token. 3 24*line 0 3 25*column 0 3 26*type 19 3 27*verb A value indicating the verb in this statement 3 28* 1 = accept 3 29* 2 = add 3 30* 3 = on size error 3 31* 4 = alter 3 32* 5 = call 3 33* 7 = cancel 3 34* 8 = close 3 35* 9 = divide 3 36* 10 = multiply 3 37* 11 = subtract 3 38* 12 = exit 3 39* 14 = go 3 40* 15 = merge 3 41* 16 = initiate 3 42* 17 = inspect 3 43* 18 = move 3 44* 19 = open 3 45* 20 = perform 3 46* 21 = read 3 47* 23 = receive 3 48* 24 = release 3 49* 25 = return 3 50* 26 = search 3 51* 27 = rewrite 3 52* 29 = seek 3 53* 30 = send 3 54* 31 = set 3 55* 33 = stop 3 56* 34 = string 3 57* 35 = suspend 3 58* 36 = terminate 3 59* 37 = unstring 3 60* 38 = write 3 61* 39 = use 3 62* 40 = compute 3 63* 41 = disable 3 64* 42 = display 3 65* 43 = enable 3 66* 45 = generate 3 67* 46 = hold 3 68* 48 = process 3 69* 49 = sort 3 70* 52 = procedure 3 71* 53 = declaratives 3 72* 54 = section name 3 73* 55 = paragraph name 3 74* 98 = end 3 75*e,h,i,j The significance of these fields differs with each 3 76* statement. These fields are normally used as counters. 3 77*a,b,c,d,f,g,k The significance of these fields differs with each 3 78* statement. These fields are normally used as indicators. 3 79**/ 3 80 3 81 /* END INCLUDE FILE ... cobol_type19.incl.pl1 */ 3 82 971 972 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 973 974 6 1 6 2 /* BEGIN INCLUDE FILE ... cobol_in_token.incl.pl1 */ 6 3 6 4 /* Last modified August 22, 1974 by AEG */ 6 5 6 6 6 7 declare in_token_ptr ptr; 6 8 6 9 declare 1 in_token aligned based(in_token_ptr), 6 10 2 n fixed bin aligned, 6 11 2 code fixed bin aligned, 6 12 2 token_ptr(0 refer(in_token.n)) ptr aligned; 6 13 6 14 6 15 /* END INCLUDE FILE ... cobol_in_token.incl.pl1 */ 6 16 975 976 977 978 /**************************************************/ 979 /* END OF EXTERNAL PROCEDURE */ 980 /**************************************************/ 981 982 end cobol_binary_check; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0830.3 cobol_binary_check.pl1 >spec>install>MR12.3-1048>cobol_binary_check.pl1 969 1 03/27/82 0439.9 cobol_type9.incl.pl1 >ldd>include>cobol_type9.incl.pl1 1-17 2 11/11/82 1712.7 cobol_TYPE9.incl.pl1 >ldd>include>cobol_TYPE9.incl.pl1 971 3 03/27/82 0439.8 cobol_type19.incl.pl1 >ldd>include>cobol_type19.incl.pl1 3-17 4 03/27/82 0439.6 cobol_TYPE19.incl.pl1 >ldd>include>cobol_TYPE19.incl.pl1 973 5 03/27/82 0439.8 cobol_record_types.incl.pl1 >ldd>include>cobol_record_types.incl.pl1 975 6 11/11/82 1712.7 cobol_in_token.incl.pl1 >ldd>include>cobol_in_token.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. a 11 based bit(3) level 2 packed packed unaligned dcl 3-16 ref 455 658 669 669 803 bin_18 21(13) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 254 302 467 479 482 509 529 877 879 949 951 bin_36 21(14) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 252 300 470 479 512 532 877 949 binary_ok parameter bit(1) packed unaligned dcl 67 set ref 26 122 332* 337 545* 558 702* 710 831* cobol_bin_const_ck 000010 constant entry external dcl 100 ref 287 465 507 884 data_name based structure level 1 unaligned dcl 1-16 divide_flag 000101 automatic bit(1) packed unaligned dcl 105 set ref 243* 295* 327 e 5 based fixed bin(17,0) level 2 dcl 3-16 ref 248 292 295 461 499 499 end_stmt based structure level 1 unaligned dcl 3-16 eos_flag 000107 automatic bit(1) packed unaligned dcl 113 set ref 281* 291* 308 eos_ptr 000112 automatic pointer dcl 3-13 set ref 242* 248 452* 455 461 499 499 499 499 656* 658 669 669 801* 803 give_up 000100 automatic bit(1) packed unaligned dcl 104 set ref 238* 248 257* 259 272 278 287* 292* 305* 308 311* 327* 332 453* 461* 465* 472* 474 478 479* 482* 499* 507* 514* 516 519 522 527 534* 536 545 653* 660* 661 663 664* 674* 675 677* 678 680 681* 691* 692 692* 695 695* 698 698* 702 798* 806* 807 809 810* 817* 818 821* 822 824 825* 831 give_up_flag parameter bit(1) packed unaligned dcl 915 in procedure "div_target_check" set ref 893 945* 947* 949* 951* give_up_flag parameter bit(1) packed unaligned dcl 848 in procedure "div_operand_check" set ref 836 871* 877* 879* 884* in_token based structure level 1 dcl 6-9 in_token_ptr parameter pointer dcl 6-7 ref 26 122 242 242 250 252 254 254 278 285 287 287 289 292 295 298 300 302 302 337 452 452 463 465 465 467 467 470 478 479 479 482 482 505 507 507 509 509 512 527 529 529 532 558 656 656 660 663 664 674 677 680 681 691 692 695 698 710 801 801 806 809 810 817 821 824 825 ix 000105 automatic fixed bin(17,0) dcl 110 set ref 248* 250 252 254 254* 278 478* 479 479 482 482* 503* 505 507 507 509 509 512* 527* 529 529 532* 663* 664* 680* 681* 809* 810* 824* 825* iy 000106 automatic fixed bin(17,0) dcl 111 set ref 278* 285 287 287 289 292 295 298 300 302 302* n based fixed bin(17,0) level 2 dcl 6-9 ref 242 278 452 478 527 656 663 680 801 809 824 operand_token_ptr parameter pointer dcl 847 set ref 836 873 877 877 879 879 884 884* operation_code parameter fixed bin(17,0) dcl 916 ref 893 947 rounded 22(24) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 250 947 rounded_flag 000102 automatic bit(1) packed unaligned dcl 106 set ref 244* 250* 327 rtc_dataname constant fixed bin(15,0) initial dcl 5-13 ref 298 873 rtc_eos constant fixed bin(15,0) initial dcl 5-23 ref 289 rtc_numlit constant fixed bin(15,0) initial dcl 5-6 ref 287 465 507 884 rtc_resword constant fixed bin(15,0) initial dcl 5-5 ref 285 463 505 source_code parameter fixed bin(17,0) dcl 69 set ref 26 122 275* 315 315* 337 463* 465* 467* 470* 502* 516 516* 558 655* 710 799* source_op_count 000110 automatic fixed bin(17,0) dcl 114 set ref 276* 311 314* 314 subscripted 22(05) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 254 302 467 482 509 529 879 951 target_code parameter fixed bin(17,0) dcl 68 set ref 26 122 239* 259 259* 337 477* 525* 536 536* 558 654* 710 800* target_token_ptr parameter pointer dcl 914 ref 893 947 949 949 951 951 temp_code 000136 automatic fixed bin(17,0) dcl 869 set ref 884* temp_source_code 000104 automatic fixed bin(17,0) dcl 108 set ref 240* 285* 287* 300* 302* 315 315 505* 507* 509* 512* 516 516 temp_target_code 000103 automatic fixed bin(17,0) dcl 107 set ref 241* 252* 254* 259 259 529* 532* 536 536 token_ptr 2 based pointer array level 2 dcl 6-9 set ref 242 250 252 254 254 285 287 287* 289 292 295 298 300 302 302 452 463 465 465* 467 467 470 479 479 482 482 505 507 507* 509 509 512 529 529 532 656 660* 664* 674* 677* 681* 691* 692* 695* 698* 801 806* 810* 817* 821* 825* type 3 based fixed bin(17,0) level 2 dcl 1-16 ref 285 287 289 298 463 465 505 507 873 884 verb 4 based fixed bin(17,0) level 2 dcl 3-16 ref 499 499 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. addr builtin function dcl 964 addrel builtin function dcl 964 binary builtin function dcl 964 dn_ptr automatic pointer dcl 115 fixed builtin function dcl 964 index builtin function dcl 964 length builtin function dcl 964 mod builtin function dcl 964 null builtin function dcl 964 rel builtin function dcl 964 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_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_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_immed_const internal static fixed bin(15,0) initial dcl 5-38 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_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_register internal static fixed bin(15,0) initial dcl 5-36 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_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 964 substr builtin function dcl 964 unspec builtin function dcl 964 NAMES DECLARED BY EXPLICIT CONTEXT. add 000306 constant entry external dcl 337 cobol_binary_check 000010 constant entry external dcl 26 compute 000020 constant entry external dcl 122 div_operand_check 001412 constant entry internal dcl 836 ref 660 674 677 691 692 806 817 821 div_target_check 001472 constant entry internal dcl 893 ref 664 681 695 698 810 825 divide 000700 constant entry external dcl 558 multiply 001206 constant entry external dcl 710 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1626 1640 1544 1636 Length 2136 1544 12 261 62 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_binary_check 135 external procedure is an external procedure. div_operand_check internal procedure shares stack frame of external procedure cobol_binary_check. div_target_check internal procedure shares stack frame of external procedure cobol_binary_check. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_binary_check 000100 give_up cobol_binary_check 000101 divide_flag cobol_binary_check 000102 rounded_flag cobol_binary_check 000103 temp_target_code cobol_binary_check 000104 temp_source_code cobol_binary_check 000105 ix cobol_binary_check 000106 iy cobol_binary_check 000107 eos_flag cobol_binary_check 000110 source_op_count cobol_binary_check 000112 eos_ptr cobol_binary_check 000136 temp_code div_operand_check THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out return_mac ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_bin_const_ck NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 26 000003 122 000015 238 000025 239 000026 240 000030 241 000031 242 000032 243 000040 244 000041 248 000042 250 000054 252 000067 254 000075 257 000106 259 000110 263 000117 272 000121 275 000124 276 000126 278 000127 281 000144 285 000145 287 000161 289 000200 291 000202 292 000204 295 000211 297 000215 298 000216 300 000220 302 000226 305 000237 308 000241 311 000246 314 000254 315 000255 321 000262 327 000264 332 000272 334 000303 337 000304 452 000313 453 000322 455 000324 461 000327 463 000335 465 000345 467 000363 470 000374 472 000402 474 000404 477 000407 478 000411 479 000426 482 000447 485 000456 488 000460 499 000461 502 000500 503 000501 505 000505 507 000522 509 000541 512 000552 514 000560 516 000562 519 000572 522 000603 525 000606 527 000610 529 000624 532 000643 534 000651 536 000653 540 000662 545 000664 552 000675 558 000676 653 000705 654 000707 655 000712 656 000713 658 000721 660 000725 661 000736 663 000741 664 000756 665 000776 667 001000 669 001001 674 001005 675 001016 677 001021 678 001034 680 001037 681 001054 682 001074 685 001076 691 001077 692 001110 695 001126 698 001150 702 001172 704 001203 710 001204 798 001213 799 001215 800 001220 801 001221 803 001227 806 001232 807 001243 809 001246 810 001264 811 001304 813 001306 817 001307 818 001320 821 001323 822 001336 824 001341 825 001356 826 001376 831 001400 833 001411 836 001412 871 001414 873 001420 877 001425 879 001442 881 001452 884 001453 890 001471 893 001472 945 001474 947 001500 949 001514 951 001532 954 001542 ----------------------------------------------------------- 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