COMPILATION LISTING OF SEGMENT unpack_picture_ Compiled by: Multics PL/I Compiler, Release 32f, of October 9, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 11/11/89 1000.1 mst Sat Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Bull Inc., 1987 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1983 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 /* Program to picture unpacking, packing, and validation for PL/I 14* 15* Initial Version: 22 November 1973 by BLW 16* Modified: 27 April 1974 by BLW to fix bugs 1063, 1068, 1071, 1072, 1089 17* Modified: 16 July 1974 by BLW to fix bug 1172 18* Modified: 17 November 1976 by RAB to fix 1550 19* Modified: 7 February 19885 by Steve Herbst to prevent 20* zero-suppressing a decimal point. 21**/ 22 23 unpack_picture_: proc(target_value,picture,source_value); 24 25 dcl (target_value,source_value) char(1) unaligned, 26 picture fixed bin; 27 28 dcl (tp,pp,sp) ptr, 29 (i,j,k,last_non_zero,picture_pos,source_pos,type,prec,scale,dr1,dr2,start, 30 scalefactor,picture_length,source_length,target_pos,exp_sign,exp,code,delta) fixed bin, 31 (had_exponent,zero_surpression,first_z,first_star,negative,no_digit,have_drift) bit(1) aligned, 32 digits char(64) aligned, 33 exponent fixed dec(3), 34 (pc,sc,drift) char(1) aligned, 35 source(source_length) char(1) unaligned based(sp), 36 input char(source_length) unaligned based(sp), 37 target char(64) unaligned based(tp), 38 target_array(0:1) char(1) unaligned based(tp); 39 40 dcl (addr,index,null,substr) builtin; 41 42 dcl ALPHABETIC char(53) int static 43 init(" abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"); 44 45 dcl plio2_signal_$s_ entry(ptr,aligned char(*),aligned char(*),fixed bin), 46 plio2_signal_$conversion_error_ entry(ptr,char(*),fixed bin,ptr,fixed bin,fixed bin,fixed bin), 47 cu_$grow_stack_frame entry(fixed bin,ptr,fixed bin), 48 adjust_float_ entry(ptr,ptr,fixed dec(3)); 49 50 dcl fudge(24:28) fixed bin int static init(0,1,1,2,2); 51 52 dcl 1 float_decimal unaligned based(tp), 53 2 sign char(1), 54 2 mantissa char(prec), 55 2 skip bit(1), 56 2 exponent fixed bin(7); 57 58 dcl decimal_value char(prec + 1) unaligned based(sp); 59 60 dcl 1 info aligned based(pp) like picture_image; 61 1 1 /* BEGIN INCLUDE FILE ... picture_image.incl.pl1 1 2* 1 3* James R. Davis 12 Mar 79 1 4**/ 1 5 1 6 dcl 1 picture_image aligned based, 1 7 2 type fixed bin (8) unal, 1 8 2 prec fixed bin (8) unal, /* precision or length of associated value */ 1 9 2 scale fixed bin (8) unal, /* for both fixed and float pictures, 1 10* =ndigits after "v" - scale_factor */ 1 11 2 piclength fixed bin (8) unal, /* length of picture_constant.chars, <64 1 12* =length of normalized-picture-string */ 1 13 2 varlength fixed bin (8) unal, /* length of pictured variable in chars, <64 1 14* =length of normalized_picture_string - "k" and "v" */ 1 15 2 scalefactor fixed bin (8) unal, /* value of pict-sc-f, -256<=x<256 */ 1 16 2 explength fixed bin (8) unal, /* length of exp field for float */ 1 17 2 drift_character char (1) unal, 1 18 2 chars char (0 refer (picture_image.piclength)) aligned; 1 19 1 20 dcl ( 1 21 picture_char_type init (24), 1 22 picture_realfix_type init (25), 1 23 picture_complexfix_type 1 24 init (26), 1 25 picture_realflo_type init (27), 1 26 picture_complexflo_type 1 27 init (28) 1 28 ) fixed bin (8) unal static internal options (constant); 1 29 1 30 /* END INCLUDE FILE ... picture_image.incl.pl1 */ 62 2 1 dcl ( char_picture init(24), 2 2 real_fixed_picture init(25), 2 3 cplx_fixed_picture init(26), 2 4 real_float_picture init(27), 2 5 cplx_float_picture init(28)) fixed bin int static options(constant); 63 64 65 call open_picture; 66 67 sp = addr(source_value); 68 tp = addr(target_value); 69 70 call unpack; 71 72 if type = cplx_fixed_picture | type = cplx_float_picture 73 then do; 74 sp = addr(source(source_length + 1)); 75 tp = addr(target_array(prec + fudge(type))); 76 call unpack; 77 end; 78 79 return; 80 81 pl1_valid_picture_: entry(picture_value,picture,answer); 82 83 dcl picture_value char(1) unal, 84 answer bit(1) aligned; 85 86 call open_picture; 87 88 sp = addr(picture_value); 89 90 call validate; 91 92 if code = 0 93 then if type = cplx_fixed_picture | type = cplx_float_picture 94 then do; 95 sp = addr(source(source_length + 1)); 96 call validate; 97 end; 98 99 answer = code = 0; 100 return; 101 102 validate_picture_: entry(picture_value,picture,error_code,error_index); 103 104 dcl (error_code,error_index) fixed bin; 105 106 call open_picture; 107 108 sp = addr(picture_value); 109 110 delta = 0; 111 112 call validate; 113 114 if code = 0 115 then if type = cplx_fixed_picture | type = cplx_float_picture 116 then do; 117 delta = source_length; 118 sp = addr(source(source_length + 1)); 119 call validate; 120 end; 121 122 error_code = code; 123 error_index = source_pos + delta; 124 return; 125 126 pack_picture_: entry(target_value,picture,source_value); 127 128 call open_picture; 129 130 sp = addr(source_value); 131 tp = addr(target_value); 132 133 if type = char_picture then call pack_char; 134 else do; 135 call pack; 136 137 if type = cplx_fixed_picture | type = cplx_float_picture 138 then do; 139 sp = addr(addr(source_value) -> source(prec + fudge(type) + 1)); 140 tp = addr(target_array(source_length)); 141 call pack; 142 end; 143 end; 144 145 return; 146 147 open_picture: proc; 148 149 pp = addr(picture); 150 151 type = info.type; 152 prec = info.prec; 153 scale = info.scale; 154 picture_length = info.piclength; 155 source_length = info.varlength; 156 scalefactor = info.scalefactor; 157 158 end; 159 160 pack: proc; 161 162 if fudge(type) = 2 163 then do; 164 165 /* have floating point value, we have to copy because we may have 166* been called with constant value */ 167 168 substr(digits,1,prec+2) = substr(input,1,prec+2); 169 sp = addr(digits); 170 171 /* now adjust the floating decimal value */ 172 173 call adjust_float_(sp,pp,exponent); 174 end; 175 176 negative = source(1) = "-"; 177 source_pos = 2; 178 zero_surpression, have_drift = "0"b; 179 first_z, first_star, no_digit = "1"b; 180 181 start, target_pos = 1; 182 183 do picture_pos = 1 to picture_length; 184 pc = substr(info.chars,picture_pos,1); 185 goto case(index("9y*z$s+-cd/.,bvek",pc)); 186 187 /* 9 */ 188 189 case(1): call put_digit; 190 source_pos = source_pos + 1; 191 goto place; 192 193 /* y */ 194 195 case(2): if source(source_pos) = "0" 196 then pc = " "; 197 else call put_digit; 198 199 zero_surpression = "0"b; 200 source_pos = source_pos + 1; 201 goto place; 202 203 /* * */ 204 205 case(3): if first_star 206 then do; 207 zero_surpression = "1"b; 208 first_star = "0"b; 209 end; 210 211 if zero_surpression & (source(source_pos) = "0") 212 then pc = "*"; 213 else call put_digit; 214 215 source_pos = source_pos + 1; 216 goto place; 217 218 /* z */ 219 220 case(4): if first_z 221 then do; 222 zero_surpression = "1"b; 223 first_z = "0"b; 224 end; 225 226 if zero_surpression & (source(source_pos) = "0") 227 then pc = " "; 228 else call put_digit; 229 230 source_pos = source_pos + 1; 231 goto place; 232 233 /* $ */ 234 235 case(5): if info.drift_character ^= "$" then goto place; 236 237 if ^ no_digit then goto case(1); 238 239 if have_drift then goto case(4); 240 241 drift = "$"; 242 zero_surpression, have_drift = "1"b; 243 pc = " "; 244 goto place; 245 246 /* s */ 247 248 case(6): pc = source(1); 249 call drifting_sign; 250 251 /* + */ 252 253 case(7): if negative then pc = " "; 254 call drifting_sign; 255 256 /* - */ 257 258 case(8): if ^ negative then pc = " "; 259 call drifting_sign; 260 261 /* c */ 262 263 case(9): if negative then substr(target,target_pos,2) = "cr"; 264 else substr(target,target_pos,2) = " "; 265 266 picture_pos = picture_pos + 1; 267 goto step; 268 269 /* d */ 270 271 case(10): if negative then substr(target,target_pos,2) = "db"; 272 else substr(target,target_pos,2) = " "; 273 274 picture_pos = picture_pos + 1; 275 goto step; 276 277 /* / . , */ 278 279 case(11): 280 case(12): 281 case(13): if zero_surpression 282 then if substr(target,target_pos - 1,1) = "*" 283 then pc = "*"; 284 else if pc ^= "." then pc = " "; /* don't want to suppress the decimal point */ 285 286 goto place; 287 288 /* b */ 289 290 case(14): if zero_surpression 291 then if substr(target,target_pos - 1,1) = "*" 292 then pc = "*"; 293 else pc = " "; 294 else pc = " "; 295 296 goto place; 297 298 /* v */ 299 300 case(15): if zero_surpression 301 then if search(decimal_value,"123456789") ^= 0 302 then call force_significance; 303 304 goto step; 305 306 /* e */ 307 308 case(16): call switch_to_exp; 309 goto place; 310 311 /* k */ 312 313 case(17): call switch_to_exp; 314 goto step; 315 316 /* place character pc in target string */ 317 318 place: substr(target,target_pos,1) = pc; 319 target_pos = target_pos + 1; 320 321 step: end; 322 323 if no_digit then substr(target,start,target_pos - start) = " "; 324 325 drifting_sign: proc; 326 327 if start ^= 1 then goto place; 328 329 if info.drift_character ^= substr(info.chars,picture_pos,1) then goto place; 330 331 if ^ no_digit then goto case(1); 332 333 if have_drift then goto case(4); 334 335 drift = pc; 336 have_drift, zero_surpression = "1"b; 337 pc = " "; 338 goto place; 339 end; 340 341 put_digit: proc; 342 343 pc = source(source_pos); 344 345 force_significance: entry; 346 347 if have_drift 348 then do; 349 substr(target,target_pos - 1,1) = drift; 350 have_drift = "0"b; 351 end; 352 353 zero_surpression, no_digit = "0"b; 354 end; 355 356 switch_to_exp: proc; 357 358 if no_digit then substr(target,1,target_pos - 1) = " "; 359 360 start = target_pos; 361 sp = addr(exponent); 362 negative = source(1) = "-"; 363 zero_surpression, have_drift = "0"b; 364 first_z, no_digit = "1"b; 365 source_pos = 2; 366 367 end; 368 369 end; 370 371 pack_char: proc; 372 373 dcl p ptr, 374 (code,errno) fixed bin; 375 376 start: do source_pos = 1 to source_length; 377 sc = source(source_pos); 378 pc = substr(info.chars,source_pos,1); 379 380 if pc = "9" 381 then if index(" 0123456789",sc) = 0 382 then do; 383 errno = 312; 384 goto edit_err; 385 end; 386 else; 387 else if pc = "a" 388 then if index(ALPHABETIC,sc) = 0 389 then do; 390 errno = 313; 391 goto edit_err; 392 end; 393 394 substr(target,source_pos,1) = sc; 395 end; 396 397 return; 398 399 edit_err: if sp = addr(source_value) 400 then do; 401 402 /* copy source for use in signalling conversion */ 403 404 call cu_$grow_stack_frame(4*source_length,p,code); 405 406 p -> source = sp -> source; 407 sp = p; 408 end; 409 410 call plio2_signal_$conversion_error_(null,"pack_picture_",errno,sp,1,source_length,source_pos); 411 goto start; 412 end; 413 414 unpack: proc; 415 416 last_non_zero = 0; 417 source_pos, target_pos = 0; 418 substr(target,1,1) = "+"; 419 had_exponent = "0"b; 420 digits = (64)"0"; 421 422 do picture_pos = 1 to picture_length; 423 k = index("9y*z$s+-cd/.,bvek",substr(info.chars,picture_pos,1)); 424 425 if k >= 16 426 then do; 427 428 /* process exponent field */ 429 430 had_exponent = "1"b; 431 exp = 0; 432 exp_sign = 1; 433 if k = 16 then source_pos = source_pos + 1; 434 435 do while(source_pos < source_length); 436 source_pos = source_pos + 1; 437 438 sc = source(source_pos); 439 j = index(" 0123456789+-",sc); 440 if j > 12 then exp_sign = -1; 441 if j < 12 442 then if j > 1 443 then exp = exp * 10 + j - 2; 444 end; 445 446 goto end_picture; 447 end; 448 449 if k = 15 then goto loop; 450 451 source_pos = source_pos + 1; 452 453 if k > 10 then goto loop; 454 455 sc = source(source_pos); 456 if sc = " " then sc = "0"; 457 j = index("0123456789$+-cd",sc); 458 459 if k > 4 460 then do; 461 462 /* $ or sign */ 463 464 if j > 12 then substr(target,1,1) = "-"; 465 466 if k > 8 467 then do; 468 469 /* skip over cr or db */ 470 471 source_pos = source_pos + 1; 472 picture_pos = picture_pos + 1; 473 goto loop; 474 end; 475 476 if j = 0 then goto loop; 477 if j > 10 then goto loop; 478 end; 479 480 target_pos = target_pos + 1; 481 482 if j > 1 483 then do; 484 last_non_zero = target_pos; 485 substr(digits,target_pos,1) = sc; 486 end; 487 488 loop: end; 489 490 end_picture: i = target_pos - prec; 491 last_non_zero = last_non_zero - i; 492 i = i + 1; 493 494 if had_exponent 495 then do; 496 if last_non_zero < prec then substr(target,2,prec-last_non_zero) = 497 substr((64)"0",1,prec-last_non_zero); 498 499 if last_non_zero > 0 then substr(target,prec-last_non_zero+2,last_non_zero) 500 = substr(digits,i,last_non_zero); 501 502 exp = exp * exp_sign; 503 exp = exp - scale + prec - last_non_zero + scalefactor; 504 505 if exp > 127 then call signal_and_return("overflow",289); 506 if exp < -128 then call signal_and_return("underflow",290); 507 508 float_decimal.exponent = exp; 509 end; 510 else substr(target,2,prec) = substr(digits,i,prec); 511 512 signal_and_return: proc(name,erno); 513 514 dcl name char(9) aligned, 515 erno fixed bin; 516 517 call plio2_signal_$s_(null,name,"pic",erno); 518 goto exit; 519 end; 520 521 end; 522 523 validate: proc; 524 525 if type = char_picture 526 then do; 527 528 do source_pos = 1 to source_length; 529 sc = source(source_pos); 530 pc = substr(info.chars,source_pos,1); 531 532 if pc = "9" 533 then if index(" 0123456789",sc) = 0 534 then goto ve12; 535 else; 536 else if pc = "a" 537 then if index(ALPHABETIC,sc) = 0 538 then goto ve13; 539 540 end; 541 542 code = 0; 543 return; 544 end; 545 546 if input = " " 547 then do; 548 source_pos = index(info.chars,"9"); 549 if source_pos ^= 0 then goto ve14; 550 551 code = 0; 552 return; 553 end; 554 555 zero_surpression = "0"b; 556 first_z, first_star = "1"b; 557 558 if info.drift_character = " " then dr1, dr2 = 0; 559 else do; 560 dr1 = index(info.chars,info.drift_character); 561 562 if info.drift_character = "$" 563 then do; 564 dr2 = index(input,"$"); 565 if dr2 = 0 then goto ve1; 566 end; 567 else do; 568 dr2 = search(input,"+-"); 569 570 if info.drift_character = "s" 571 then if dr2 = 0 572 then goto ve2; 573 else; 574 else if dr2 ^= 0 575 then if substr(input,dr2,1) ^= info.drift_character 576 then goto ve2; 577 end; 578 579 if dr2 = 0 then dr1 = 0; 580 else do; 581 if dr2 > dr1 582 then if substr(input,dr1,dr2-dr1) ^= " " 583 then goto ve3; 584 585 if substr(input,dr2+1,1) = " " then goto ve3; 586 end; 587 end; 588 589 source_pos = 0; 590 591 do picture_pos = 1 to picture_length; 592 pc = substr(info.chars,picture_pos,1); 593 k = index("9yz*$s+-cd/.,bvek",pc); 594 595 if k < 15 596 then do; 597 source_pos = source_pos + 1; 598 599 if source_pos = dr1 then sc = source(dr2); 600 else if source_pos = dr2 then sc = " "; 601 else sc = source(source_pos); 602 603 j = index(" 0123456789*$+-cd/.,",sc); 604 if j = 0 then goto ve5; 605 end; 606 607 if k < 4 608 then if j > 11 609 then goto ve11; 610 611 goto case(k); 612 613 /* 9 */ 614 615 case(1): if sc = " " then goto ve10; 616 zero_surpression = "0"b; 617 goto loop; 618 619 /* y */ 620 621 case(2): if sc = "0" then goto ve10; 622 if j > 2 then zero_surpression = "0"b; 623 goto loop; 624 625 /* z */ 626 627 case(3): if first_z 628 then do; 629 zero_surpression = "1"b; 630 first_z = "0"b; 631 end; 632 633 if sc = " " 634 then if zero_surpression 635 then goto loop; 636 else goto ve9; 637 638 goto valid_star; 639 640 /* * */ 641 642 case(4): if first_star 643 then do; 644 zero_surpression = "1"b; 645 first_star = "0"b; 646 end; 647 648 if sc = "*" 649 then if zero_surpression 650 then goto loop; 651 else goto ve9; 652 653 valid_star: if sc = "0" 654 then if zero_surpression 655 then goto ve9; 656 else goto loop; 657 658 if j > 2 then zero_surpression = "0"b; 659 goto loop; 660 661 /* $ */ 662 663 case(5): if dr1 = 0 | source_pos <= dr1 664 then if sc ^= "$" 665 then goto ve8; 666 else goto loop; 667 668 goto case(3); 669 670 /* s */ 671 672 case(6): if dr1 = 0 | source_pos <= dr1 673 then if search(sc,"+-") = 0 674 then goto ve8; 675 else goto loop; 676 677 goto case(3); 678 679 /* + - */ 680 681 case(7): 682 case(8): if info.drift_character = " " | source_pos <= dr1 683 then if (sc ^= pc) & (sc ^= " ") 684 then goto ve8; 685 else goto loop; 686 687 goto case(3); 688 689 /* c d */ 690 691 case(9): 692 case(10): if substr(input,source_pos,2) = " " 693 then do; 694 picture_pos = picture_pos + 2; 695 source_pos = source_pos + 2; 696 end; 697 else do; 698 if sc ^= pc then goto ve7; 699 700 picture_pos = picture_pos + 1; 701 source_pos = source_pos + 1; 702 703 if source(source_pos) ^= substr(info.chars,picture_pos,1) then goto ve7; 704 end; 705 706 goto loop; 707 708 /* / . , b */ 709 710 case(11): 711 case(12): 712 case(13): 713 case(14): if zero_surpression 714 then do; 715 if source(source_pos - 1) = "*" 716 then if sc ^= "*" 717 then goto ve6; 718 else; 719 else if sc ^= " " 720 then goto ve6; 721 end; 722 else if (j - 17) ^= (k - 10) 723 then if sc ^= " " | pc ^= "b" 724 then goto ve6; 725 726 goto loop; 727 728 /* v */ 729 730 case(15): if search(input,"123456789") ^= 0 then zero_surpression = "0"b; 731 goto loop; 732 733 /* e */ 734 735 case(16): source_pos = source_pos + 1; 736 737 if source(source_pos) ^= "e" 738 then do; 739 if substr(input,source_pos) ^= " " then goto ve4; 740 if index(substr(info.chars,picture_pos+1),"9") ^= 0 then goto ve14; 741 742 code = 0; 743 return; 744 end; 745 746 /* k */ 747 748 case(17): zero_surpression = "0"b; 749 first_z, first_star = "1"b; 750 dr1 = 0; 751 752 loop: end; 753 754 code = 0; 755 return; 756 757 /* "$" not present in picture variable */ 758 759 ve1: code = 301; 760 761 do source_pos = dr1 to source_length while(source(source_pos) = " "); 762 end; 763 764 source_pos = source_pos - 1; 765 return; 766 767 /* "+" or "-" not present in variable */ 768 769 ve2: code = 302; 770 source_pos = dr2; 771 return; 772 773 /* Drifting character not preceded by blank */ 774 775 ve3: code = 303; 776 source_pos = dr2; 777 return; 778 779 /* "e" not present where expected */ 780 781 ve4: code = 304; 782 return; 783 784 /* illegal character in variable */ 785 786 ve5: code = 305; 787 return; 788 789 /* Insertion character error */ 790 791 ve6: code = 306; 792 return; 793 794 /* "cr" or "db" not found where expected */ 795 796 ve7: code = 307; 797 return; 798 799 /* Drifting character not found where expected */ 800 801 ve8: code = 308; 802 return; 803 804 /* Blank or asterisk found instead of digit */ 805 806 ve9: code = 309; 807 return; 808 809 /* "$" not present in variable */ 810 811 /* zero surpression error */ 812 813 ve10: code = 310; 814 return; 815 816 /* non-digit found where digit expected */ 817 818 ve11: code = 311; 819 return; 820 821 /* non-digit found in "9" position in char variable */ 822 823 ve12: code = 312; 824 return; 825 826 /* non-alphabetic found in "a" position in char variable */ 827 828 ve13: code = 313; 829 return; 830 831 /* picture all blank when digit expected */ 832 833 ve14: code = 314; 834 end; 835 836 exit: end; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/11/89 0804.2 unpack_picture_.pl1 >spec>install>1110>unpack_picture_.pl1 62 1 06/28/79 1204.8 picture_image.incl.pl1 >ldd>include>picture_image.incl.pl1 63 2 05/03/76 1320.4 picture_types.incl.pl1 >ldd>include>picture_types.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. ALPHABETIC 000047 constant char(53) initial packed unaligned dcl 42 ref 387 536 addr builtin function dcl 40 ref 67 68 74 75 88 95 108 118 130 131 139 139 140 149 169 361 399 adjust_float_ 000016 constant entry external dcl 45 ref 173 answer parameter bit(1) dcl 83 set ref 81 99* char_picture constant fixed bin(17,0) initial dcl 2-1 ref 133 525 chars 2 based char level 2 dcl 60 ref 184 329 378 423 530 548 560 592 703 740 code 000236 automatic fixed bin(17,0) dcl 373 in procedure "pack_char" set ref 404* code 000130 automatic fixed bin(17,0) dcl 28 in procedure "unpack_picture_" set ref 92 99 114 122 542* 551* 742* 754* 759* 769* 775* 781* 786* 791* 796* 801* 806* 813* 818* 823* 828* 833* cplx_fixed_picture constant fixed bin(17,0) initial dcl 2-1 ref 72 92 114 137 cplx_float_picture constant fixed bin(17,0) initial dcl 2-1 ref 72 92 114 137 cu_$grow_stack_frame 000014 constant entry external dcl 45 ref 404 decimal_value based char packed unaligned dcl 58 ref 300 delta 000131 automatic fixed bin(17,0) dcl 28 set ref 110* 117* 123 digits 000141 automatic char(64) dcl 28 set ref 168* 169 420* 485* 499 510 dr1 000117 automatic fixed bin(17,0) dcl 28 set ref 558* 560* 579* 581 581 581 599 663 663 672 672 681 750* 761 dr2 000120 automatic fixed bin(17,0) dcl 28 set ref 558* 564* 565 568* 570 574 574 579 581 581 585 599 600 770 776 drift 000164 automatic char(1) dcl 28 set ref 241* 335* 349 drift_character 1(27) based char(1) level 2 packed packed unaligned dcl 60 ref 235 329 558 560 562 570 574 681 erno parameter fixed bin(17,0) dcl 514 set ref 512 517* errno 000237 automatic fixed bin(17,0) dcl 373 set ref 383* 390* 410* error_code parameter fixed bin(17,0) dcl 104 set ref 102 122* error_index parameter fixed bin(17,0) dcl 104 set ref 102 123* exp 000127 automatic fixed bin(17,0) dcl 28 set ref 431* 441* 441 502* 502 503* 503 505 506 508 exp_sign 000126 automatic fixed bin(17,0) dcl 28 set ref 432* 440* 502 exponent 000161 automatic fixed dec(3,0) dcl 28 in procedure "unpack_picture_" set ref 173* 361 exponent based fixed bin(7,0) level 2 in structure "float_decimal" packed packed unaligned dcl 52 in procedure "unpack_picture_" set ref 508* first_star 000135 automatic bit(1) dcl 28 set ref 179* 205 208* 556* 642 645* 749* first_z 000134 automatic bit(1) dcl 28 set ref 179* 220 223* 364* 556* 627 630* 749* float_decimal based structure level 1 packed packed unaligned dcl 52 fudge 000042 constant fixed bin(17,0) initial array dcl 50 ref 75 139 162 had_exponent 000132 automatic bit(1) dcl 28 set ref 419* 430* 494 have_drift 000140 automatic bit(1) dcl 28 set ref 178* 239 242* 333 336* 347 350* 363* i 000106 automatic fixed bin(17,0) dcl 28 set ref 490* 491 492* 492 499 510 index builtin function dcl 40 ref 185 380 387 423 439 457 532 536 548 560 564 593 603 740 info based structure level 1 dcl 60 input based char packed unaligned dcl 28 ref 168 546 564 568 574 581 585 691 730 739 j 000107 automatic fixed bin(17,0) dcl 28 set ref 439* 440 441 441 441 457* 464 476 477 482 603* 604 607 622 658 722 k 000110 automatic fixed bin(17,0) dcl 28 set ref 423* 425 433 449 453 459 466 593* 595 607 611 722 last_non_zero 000111 automatic fixed bin(17,0) dcl 28 set ref 416* 484* 491* 491 496 496 496 499 499 499 499 503 name parameter char(9) dcl 514 set ref 512 517* negative 000136 automatic bit(1) dcl 28 set ref 176* 253 258 263 271 362* no_digit 000137 automatic bit(1) dcl 28 set ref 179* 237 323 331 353* 358 364* null builtin function dcl 40 ref 410 410 517 517 p 000234 automatic pointer dcl 373 set ref 404* 406 407 pc 000162 automatic char(1) dcl 28 set ref 184* 185 195* 211* 226* 243* 248* 253* 258* 279* 284 284* 290* 293* 294* 318 335 337* 343* 378* 380 387 530* 532 536 592* 593 681 698 722 piclength 0(27) based fixed bin(8,0) level 2 in structure "info" packed packed unaligned dcl 60 in procedure "unpack_picture_" ref 154 piclength 0(27) based fixed bin(8,0) level 2 in structure "picture_image" packed packed unaligned dcl 1-6 in procedure "unpack_picture_" ref 184 329 378 423 530 548 560 592 703 740 picture parameter fixed bin(17,0) dcl 25 set ref 23 81 102 126 149 picture_image based structure level 1 dcl 1-6 picture_length 000123 automatic fixed bin(17,0) dcl 28 set ref 154* 183 422 591 picture_pos 000112 automatic fixed bin(17,0) dcl 28 set ref 183* 184 266* 266 274* 274* 329 422* 423 472* 472* 591* 592 694* 694 700* 700 703 740* picture_value parameter char(1) packed unaligned dcl 83 set ref 81 88 102 108 plio2_signal_$conversion_error_ 000012 constant entry external dcl 45 ref 410 plio2_signal_$s_ 000010 constant entry external dcl 45 ref 517 pp 000102 automatic pointer dcl 28 set ref 149* 151 152 153 154 155 156 173* 184 235 329 329 378 423 530 548 558 560 560 562 570 574 592 681 703 740 prec 0(09) based fixed bin(8,0) level 2 in structure "info" packed packed unaligned dcl 60 in procedure "unpack_picture_" ref 152 prec 000115 automatic fixed bin(17,0) dcl 28 in procedure "unpack_picture_" set ref 75 139 152* 168 168 300 490 496 496 496 499 503 508 510 510 sc 000163 automatic char(1) dcl 28 set ref 377* 380 387 394 438* 439 455* 456 456* 457 485 529* 532 536 599* 600* 601* 603 615 621 633 648 653 663 672 681 681 698 715 719 722 scale 000116 automatic fixed bin(17,0) dcl 28 in procedure "unpack_picture_" set ref 153* 503 scale 0(18) based fixed bin(8,0) level 2 in structure "info" packed packed unaligned dcl 60 in procedure "unpack_picture_" ref 153 scalefactor 1(09) based fixed bin(8,0) level 2 in structure "info" packed packed unaligned dcl 60 in procedure "unpack_picture_" ref 156 scalefactor 000122 automatic fixed bin(17,0) dcl 28 in procedure "unpack_picture_" set ref 156* 503 source based char(1) array packed unaligned dcl 28 set ref 74 95 118 139 176 195 211 226 248 343 362 377 406* 406 438 455 529 599 601 703 715 737 761 source_length 000124 automatic fixed bin(17,0) dcl 28 set ref 74 95 117 118 140 155* 168 376 404 406 406 406 410* 435 528 546 564 568 574 581 585 691 730 739 761 source_pos 000113 automatic fixed bin(17,0) dcl 28 set ref 123 177* 190* 190 195 200* 200 211 215* 215 226 230* 230 343 365* 376* 377 378 394* 410* 417* 433* 433 435 436* 436 438 451* 451 455 471* 471 528* 529 530* 548* 549 589* 597* 597 599 600 601 663 672 681 691 695* 695 701* 701 703 715 735* 735 737 739 761* 761* 764* 764 770* 776* source_value parameter char(1) packed unaligned dcl 25 set ref 23 67 126 130 139 399 sp 000104 automatic pointer dcl 28 set ref 67* 74* 74 88* 95* 95 108* 118* 118 130* 139* 168 169* 173* 176 195 211 226 248 300 343 361* 362 377 399 406 407* 410* 438 455 529 546 564 568 574 581 585 599 601 691 703 715 730 737 739 761 start 000121 automatic fixed bin(17,0) dcl 28 set ref 181* 323 323 327 360* substr builtin function dcl 40 set ref 168* 168 184 263* 264* 271* 272* 279 290 318* 323* 329 349* 358* 378 394* 418* 423 464* 485* 496* 496 499* 499 510* 510 530 574 581 585 592 691 703 739 740 target based char(64) packed unaligned dcl 28 set ref 263* 264* 271* 272* 279 290 318* 323* 349* 358* 394* 418* 464* 496* 499* 510* target_array based char(1) array packed unaligned dcl 28 set ref 75 140 target_pos 000125 automatic fixed bin(17,0) dcl 28 set ref 181* 263 264 271 272 279 290 318 319* 319 323 349 358 360 417* 480* 480 484 485 490 target_value parameter char(1) packed unaligned dcl 25 set ref 23 68 126 131 tp 000100 automatic pointer dcl 28 set ref 68* 75* 75 131* 140* 140 263 264 271 272 279 290 318 323 349 358 394 418 464 496 499 508 510 type 000114 automatic fixed bin(17,0) dcl 28 in procedure "unpack_picture_" set ref 72 72 75 92 92 114 114 133 137 137 139 151* 162 525 type based fixed bin(8,0) level 2 in structure "info" packed packed unaligned dcl 60 in procedure "unpack_picture_" ref 151 varlength 1 based fixed bin(8,0) level 2 packed packed unaligned dcl 60 ref 155 zero_surpression 000133 automatic bit(1) dcl 28 set ref 178* 199* 207* 211 222* 226 242* 279 290 300 336* 353* 363* 555* 616* 622* 629* 633 644* 648 653 658* 710 730* 748* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. picture_char_type internal static fixed bin(8,0) initial packed unaligned dcl 1-20 picture_complexfix_type internal static fixed bin(8,0) initial packed unaligned dcl 1-20 picture_complexflo_type internal static fixed bin(8,0) initial packed unaligned dcl 1-20 picture_realfix_type internal static fixed bin(8,0) initial packed unaligned dcl 1-20 picture_realflo_type internal static fixed bin(8,0) initial packed unaligned dcl 1-20 real_fixed_picture internal static fixed bin(17,0) initial dcl 2-1 real_float_picture internal static fixed bin(17,0) initial dcl 2-1 NAMES DECLARED BY EXPLICIT CONTEXT. case 000021 constant label array(17) dcl 615 in procedure "validate" ref 611 668 677 687 case 000000 constant label array(17) dcl 189 in procedure "pack" ref 185 237 239 331 333 drifting_sign 001014 constant entry internal dcl 325 ref 249 254 259 edit_err 001211 constant label dcl 399 ref 384 391 end_picture 001537 constant label dcl 490 ref 446 exit 000361 constant label dcl 836 ref 518 force_significance 001052 constant entry internal dcl 345 ref 300 loop 001535 constant label dcl 488 in procedure "unpack" ref 449 453 473 476 477 loop 002530 constant label dcl 752 in procedure "validate" ref 617 623 633 648 656 659 666 675 685 706 726 731 open_picture 000362 constant entry internal dcl 147 ref 65 86 106 128 pack 000415 constant entry internal dcl 160 ref 135 141 pack_char 001120 constant entry internal dcl 371 ref 133 pack_picture_ 000314 constant entry external dcl 126 pl1_valid_picture_ 000213 constant entry external dcl 81 place 000772 constant label dcl 318 ref 191 201 216 231 235 244 286 296 309 327 329 338 put_digit 001042 constant entry internal dcl 341 ref 189 197 213 228 signal_and_return 001653 constant entry internal dcl 512 ref 505 506 start 001121 constant label dcl 376 ref 411 step 001000 constant label dcl 321 ref 267 275 304 314 switch_to_exp 001066 constant entry internal dcl 356 ref 308 313 unpack 001334 constant entry internal dcl 414 ref 70 76 unpack_picture_ 000152 constant entry external dcl 23 valid_star 002300 constant label dcl 653 ref 638 validate 001710 constant entry internal dcl 523 ref 90 96 112 119 validate_picture_ 000253 constant entry external dcl 102 ve1 002534 constant label dcl 759 ref 565 ve10 002613 constant label dcl 813 ref 615 621 ve11 002616 constant label dcl 818 ref 607 ve12 002621 constant label dcl 823 ref 532 ve13 002624 constant label dcl 828 ref 536 ve14 002627 constant label dcl 833 ref 549 740 ve2 002557 constant label dcl 769 ref 570 574 ve3 002564 constant label dcl 775 ref 581 585 ve4 002571 constant label dcl 781 ref 739 ve5 002574 constant label dcl 786 ref 604 ve6 002577 constant label dcl 791 ref 715 719 722 ve7 002602 constant label dcl 796 ref 698 703 ve8 002605 constant label dcl 801 ref 663 672 681 ve9 002610 constant label dcl 806 ref 636 651 653 NAME DECLARED BY CONTEXT OR IMPLICATION. search builtin function ref 300 568 672 730 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 3406 3426 3272 3416 Length 3642 3272 20 177 114 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME unpack_picture_ 270 external procedure is an external procedure. open_picture internal procedure shares stack frame of external procedure unpack_picture_. pack internal procedure shares stack frame of external procedure unpack_picture_. drifting_sign internal procedure shares stack frame of external procedure unpack_picture_. put_digit internal procedure shares stack frame of external procedure unpack_picture_. switch_to_exp internal procedure shares stack frame of external procedure unpack_picture_. pack_char internal procedure shares stack frame of external procedure unpack_picture_. unpack internal procedure shares stack frame of external procedure unpack_picture_. signal_and_return internal procedure shares stack frame of external procedure unpack_picture_. validate internal procedure shares stack frame of external procedure unpack_picture_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME unpack_picture_ 000100 tp unpack_picture_ 000102 pp unpack_picture_ 000104 sp unpack_picture_ 000106 i unpack_picture_ 000107 j unpack_picture_ 000110 k unpack_picture_ 000111 last_non_zero unpack_picture_ 000112 picture_pos unpack_picture_ 000113 source_pos unpack_picture_ 000114 type unpack_picture_ 000115 prec unpack_picture_ 000116 scale unpack_picture_ 000117 dr1 unpack_picture_ 000120 dr2 unpack_picture_ 000121 start unpack_picture_ 000122 scalefactor unpack_picture_ 000123 picture_length unpack_picture_ 000124 source_length unpack_picture_ 000125 target_pos unpack_picture_ 000126 exp_sign unpack_picture_ 000127 exp unpack_picture_ 000130 code unpack_picture_ 000131 delta unpack_picture_ 000132 had_exponent unpack_picture_ 000133 zero_surpression unpack_picture_ 000134 first_z unpack_picture_ 000135 first_star unpack_picture_ 000136 negative unpack_picture_ 000137 no_digit unpack_picture_ 000140 have_drift unpack_picture_ 000141 digits unpack_picture_ 000161 exponent unpack_picture_ 000162 pc unpack_picture_ 000163 sc unpack_picture_ 000164 drift unpack_picture_ 000234 p pack_char 000236 code pack_char 000237 errno pack_char THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_temp call_ext_out_desc call_ext_out return_mac shorten_stack ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. adjust_float_ cu_$grow_stack_frame plio2_signal_$conversion_error_ plio2_signal_$s_ NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 23 000146 65 000157 67 000160 68 000163 70 000165 72 000166 74 000173 75 000177 76 000205 79 000206 81 000207 86 000220 88 000221 90 000224 92 000225 95 000234 96 000240 99 000241 100 000245 102 000246 106 000260 108 000261 110 000264 112 000265 114 000266 117 000275 118 000277 119 000302 122 000303 123 000306 124 000311 126 000312 128 000321 130 000322 131 000325 133 000327 135 000334 137 000335 139 000342 140 000352 141 000356 145 000360 836 000361 147 000362 149 000363 151 000366 152 000371 153 000375 154 000401 155 000405 156 000410 158 000414 160 000415 162 000416 168 000422 169 000433 173 000435 176 000450 177 000456 178 000460 179 000462 181 000466 183 000471 184 000501 185 000506 189 000517 190 000520 191 000521 195 000522 197 000533 199 000534 200 000535 201 000536 205 000537 207 000541 208 000543 211 000544 213 000557 215 000560 216 000561 220 000562 222 000564 223 000566 226 000567 228 000602 230 000603 231 000604 235 000605 237 000611 239 000613 241 000615 242 000617 243 000622 244 000624 248 000625 249 000632 253 000633 254 000637 258 000640 259 000644 263 000645 264 000655 266 000662 267 000663 271 000664 272 000674 274 000701 275 000702 279 000703 284 000716 286 000723 290 000724 293 000737 294 000742 296 000744 300 000745 304 000765 308 000766 309 000767 313 000770 314 000771 318 000772 319 000777 321 001000 323 001002 369 001013 325 001014 327 001015 329 001020 331 001026 333 001030 335 001032 336 001034 337 001037 338 001041 341 001042 343 001043 345 001051 347 001053 349 001055 350 001062 353 001063 354 001065 356 001066 358 001067 360 001077 361 001101 362 001103 363 001110 364 001112 365 001115 367 001117 371 001120 376 001121 377 001131 378 001136 380 001143 383 001157 384 001161 386 001162 387 001163 390 001176 391 001200 394 001201 395 001206 397 001210 399 001211 404 001220 406 001236 407 001262 410 001264 411 001333 414 001334 416 001335 417 001336 418 001340 419 001344 420 001345 422 001350 423 001357 425 001371 430 001373 431 001375 432 001376 433 001400 435 001404 436 001407 438 001410 439 001416 440 001427 441 001433 444 001445 446 001446 449 001447 451 001451 453 001452 455 001454 456 001462 457 001467 459 001500 464 001503 466 001512 471 001515 472 001516 473 001517 476 001520 477 001522 480 001524 482 001525 484 001530 485 001532 488 001535 490 001537 491 001542 492 001544 494 001545 496 001547 499 001560 502 001572 503 001575 505 001602 506 001613 508 001626 509 001643 510 001644 521 001652 512 001653 517 001655 518 001707 523 001710 525 001711 528 001714 529 001723 530 001730 532 001735 535 001751 536 001752 540 001765 542 001767 543 001770 546 001771 548 001777 549 002014 551 002015 552 002016 555 002017 556 002020 558 002023 560 002034 562 002050 564 002053 565 002064 566 002065 568 002066 570 002100 573 002104 574 002105 579 002113 581 002117 585 002127 589 002134 591 002135 592 002145 593 002152 595 002163 597 002165 599 002166 600 002200 601 002205 603 002212 604 002223 607 002224 611 002232 615 002234 616 002237 617 002240 621 002241 622 002244 623 002250 627 002251 629 002253 630 002255 633 002256 636 002263 638 002264 642 002265 644 002267 645 002271 648 002272 651 002277 653 002300 656 002305 658 002306 659 002312 663 002313 666 002322 668 002323 672 002324 675 002340 677 002341 681 002342 685 002356 687 002357 691 002360 694 002366 695 002370 696 002371 698 002372 700 002375 701 002376 703 002377 706 002405 710 002406 715 002410 718 002421 719 002422 721 002425 722 002426 726 002443 730 002444 731 002461 735 002462 737 002463 739 002471 740 002503 742 002521 743 002522 748 002523 749 002524 750 002527 752 002530 754 002532 755 002533 759 002534 761 002536 762 002552 764 002554 765 002556 769 002557 770 002561 771 002563 775 002564 776 002566 777 002570 781 002571 782 002573 786 002574 787 002576 791 002577 792 002601 796 002602 797 002604 801 002605 802 002607 806 002610 807 002612 813 002613 814 002615 818 002616 819 002620 823 002621 824 002623 828 002624 829 002626 833 002627 834 002631 ----------------------------------------------------------- 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