COMPILATION LISTING OF SEGMENT plio2_pve_ Compiled by: Multics PL/I Compiler, Release 28d, of September 14, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 10/03/83 1419.7 mst Mon Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 plio2_pve_:proc(pspp) options(support); 11 put_value_edit_:entry(pspp); 12 13 /* Ref: see AG94 section 12.12 page 12-17 ff format statement 14* section 8.2.12 page 8-11 ff format controlled conversion 15* */ 16 17 dcl (/*p,*/psp,pspp/*,inpicture_p,outpicture_p*/) ptr; 18 19 /* dcl erno fixed bin(15); */ 20 /* dcl (i,ipreciz,code,idn,topdigits) fixed bin(15); */ 21 /* dcl fake_arg bit(1) unaligned based; */ 22 /* dcl based_bits bit(1000) unaligned based; */ 23 /* */ 24 /* dcl decimal_temp char(130) aligned; */ 25 /* dcl decimal char(130) aligned; */ 26 /* */ 27 /* dcl 1 descriptive aligned, */ 28 /* 2 type5 aligned, */ 29 /* 3 ( cr,bd,ff,ls,pack ) char(1) unal, */ 30 /* 2 (prec,scale,bit_length,typex) fixed bin(15); */ 31 /* dcl 1 based_mask aligned based(addr(type5)), */ 32 /* 2 bc2 char(2) unaligned; */ 33 /* dcl 1 xm12 aligned based, */ 34 /* 2 top_24 bit(24) unal, */ 35 /* 2 m_12 bit(12) unal; */ 36 /* dcl 1 xlc aligned based, */ 37 /* 2 c3 char(3) unal, */ 38 /* 2 last_char char(1) unal; */ 39 /* */ 40 /* dcl ( addr,addrel,baseptr,divide,fixed,length,mod,substr,unspec) builtin; */ 41 /* */ 42 /*dcl plio2_fl_$reset_ ext entry(ptr); */ 43 /*dcl plio2_fl_$get_next_ ext entry(ptr); */ 44 /*dcl plio2_put_util_$put_field_ ext entry(ptr,ptr,fixed bin(15)); */ 45 /*dcl plio2_put_util_$put_prep_ ext entry(ptr); */ 46 /*dcl plio2_put_util_$put_page_ ext entry(ptr); */ 47 /*dcl plio2_put_util_$put_line_ ext entry(ptr,fixed bin(15)); */ 48 /*dcl plio2_put_util_$put_skip_ ext entry(ptr,fixed bin(15)); */ 49 /*dcl plio2_put_util_$put_column_ ext entry(ptr,fixed bin(15)); */ 50 /*dcl dnd$with_strings ext entry(bit(36) aligned,ptr,fixed bin(15)); */ 51 dcl plio2_signal_$s_ ext entry(ptr,char(*),char(*), fixed bin(15)); 52 /*dcl plio2_signal_$s_r_ ext entry(ptr,char(*),char(*), fixed bin(15)); */ 53 /* */ 54 /* dcl sign_char char(1) unaligned; */ 55 /* dcl format_bp ptr; */ 56 /* dcl expstr char(5) aligned; */ 57 /* */ 58 /* dcl v_output char(516) varying; */ 59 /* */ 60 /* dcl zeroes char(256) aligned static internal init((256)"0"); */ 61 /* */ 62 /* dcl dgt(0:9) char(1) static internal */ 63 /* init("0","1","2","3","4","5","6","7","8","9"); */ 64 /* */ 65 /* dcl 1 second_part unaligned based, */ 66 /* 2 xxx bit(bit_offset), */ 67 /* 2 next_bit bit(1); */ 68 /* */ 69 /* dcl 1 format_block aligned based(format_bp), */ 70 /* 2 ( type,nval,val(3)) fixed bin(15); */ 71 /* */ 72 /* dcl (exp,ftype,iw,icomplex,is,ip,id,nval) fixed bin(15); */ 73 /* dcl bl24 char(24) aligned init(""); */ 74 /* */ 75 /* dcl ( ddfix,ddflo) bit(36) aligned; */ 76 /* dcl char256 char(256) aligned; */ 77 /* dcl vbit256 bit(256) varying aligned; */ 78 /* dcl efbuf char(264) aligned; */ 79 /* dcl (lzero,ief,dscale,lpref) fixed bin(15); */ 80 /* */ 81 /*dcl buffer char(64) aligned; */ 82 /*dcl space char(128) aligned; */ 83 /* */ 84 /*dcl conversion condition; */ 85 /*dcl plio2_resig_ ext entry(ptr); */ 86 /* */ 87 /*dcl 1 dec_fixed(2) based(addr(space)) unal, */ 88 /* 2 sign_of_mantissa char(1) unal, */ 89 /* 2 mantissa char(outprec) unal, */ 90 /* */ 91 /* 1 dec_float(2) based(addr(space)) unal, */ 92 /* 2 sign_of_mantissa char(1) unal, */ 93 /* 2 mantissa char(outprec) unal, */ 94 /* 2 unused bit(1) unal, */ 95 /* 2 exponent fixed bin(7) unal; */ 96 /* */ 97 /*%include desc_dcls; */ 98 /*%include desc_types; */ 99 /*%include descriptor; */ 100 /*%include picture_desc_; */ 101 /*%include picture_image; */ 102 /*%include picture_util; */ 103 /*%include plio_format_codes; */ 104 /*%include plio2_ps; */ 105 106 /* psp=pspp; */ 107 /* if ps.prep^=0 then call plio2_put_util_$put_prep_(psp); */ 108 /* on conversion call plio2_resig_(psp); */ 109 /* ps.vp=ps.value_p; */ 110 /* ps.descr=ps.descriptor; */ 111 /* call dnd$with_strings(ps.descr,addr(descriptive),code); */ 112 /* if code^=0 then goto err232; */ 113 /* */ 114 /* if type5.cr="s" */ 115 /* then if type5.ff="v" */ 116 /* then ps.vp = addrel(ps.vp,-1); */ 117 /* */ 118 /* icomplex=0; */ 119 /* format_bp=ps.format_area_p; */ 120 /* if ps.new_format^=0 then call plio2_fl_$reset_(psp); */ 121 /* */ 122 /*get_next_format_item: */ 123 /* */ 124 /* call plio2_fl_$get_next_(psp); */ 125 /* */ 126 /*complex_edit_1: */ 127 /* ftype=format_block.type; */ 128 /* nval=format_block.nval; */ 129 /* iw=format_block.val(1); */ 130 /* */ 131 /* if nval>0 then if iw<0 then goto bad_param_values; */ 132 /* */ 133 /* if icomplex>0 then go to ef_prep; */ 134 /* */ 135 /* if ftype24 then is=24; */ 141 /* else is=iw; */ 142 /* iw=iw-is; */ 143 /* call plio2_put_util_$put_field_(psp,addr(bl24),is); */ 144 /* goto more_x; */ 145 /* end; */ 146 /* */ 147 /* if ftype=skip_format then */ 148 /* do; */ 149 /* if nval<1 then iw=1; */ 150 /* call plio2_put_util_$put_skip_(psp,iw); */ 151 /* go to get_next_format_item; */ 152 /* end; */ 153 /* */ 154 /* */ 155 /* if ftype=column_format then */ 156 /* do; */ 157 /* if nval<1 then go to too_few_params; */ 158 /* if iw<1 then iw=1; /* not AG94-0 ........... */ 159 /* call plio2_put_util_$put_column_(psp,iw); */ 160 /* go to get_next_format_item; */ 161 /* end; */ 162 /* */ 163 /* */ 164 /* if ftype=page_format then */ 165 /* do; */ 166 /* call plio2_put_util_$put_page_(psp); */ 167 /* go to get_next_format_item; */ 168 /* end; */ 169 /* */ 170 /* */ 171 /* if ftype=line_format then */ 172 /* do; */ 173 /* if nval<1 then go to too_few_params; */ 174 /* if iw<1 then goto bad_param_values; */ 175 /* call plio2_put_util_$put_line_(psp,iw); */ 176 /* go to get_next_format_item; */ 177 /* end; */ 178 /* */ 179 /*pic_format: */ 180 /* if ftype=picture_format */ 181 /* then do; */ 182 /* outpicture_p = addrel(baseptr(format_block.val(2)),format_block.val(3)); */ 183 /* */ 184 /* call assign_type_p(outpicture_p,outtype,outscale_prec); */ 185 /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ 186 /* */ 187 /* if icomplex=2 */ 188 /* then if outtype^=char_desc*2 */ 189 /* then outtype = outtype+4; */ 190 /* */ 191 /* if ps.descr="0"b */ 192 /* then if outtype=char_desc*2 */ 193 /* then do; */ 194 /* call assign_(addr(buffer),char_desc*2,outscale_prec,ps.vp,intype,inscale_prec); */ 195 /* call pack_picture_(addr(char256)->char1,p->char1,addr(buffer)->char1); */ 196 /* */ 197 /* icomplex = 2; */ 198 /* */ 199 /* goto put_field_edit; */ 200 /* end; */ 201 /* else do; */ 202 /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ 203 /* call assign_(addr(space),outtype,outscale_prec,addr(buffer),intype,inscale_prec); */ 204 /* end; */ 205 /* else call assign_(addr(space),outtype,outscale_prec,ps.vp,intype,inscale_prec); */ 206 /* */ 207 /* if icomplex=2 */ 208 /* then i = 2; */ 209 /* else i = 1; */ 210 /* */ 211 /* if outtype=D_fixed_real_desc*2 */ 212 /* | outtype=D_fixed_cplx_desc*2 */ 213 /* then p = addr(dec_fixed(i)); */ 214 /* else p = addr(dec_float(i)); */ 215 /* */ 216 /* call pack_picture_(addr(decimal)->char1,outpicture_p->char1,p->char1); */ 217 /* */ 218 /* iw = outpicture_p->picture_image.varlength; */ 219 /* */ 220 /* substr(char256,1,iw) = substr(decimal,1,iw); */ 221 /* */ 222 /* goto put_field_edit; */ 223 /* end; */ 224 /* */ 225 /* goto no_such_format_type; */ 226 /* */ 227 /*err232: */ 228 /* erno=232; */ 229 /* /* bad output descriptor */ 230 /* goto sandr; */ 231 /* */ 232 /*too_few_params: */ 233 /* erno=148; */ 234 /* /* too few parameters in format item */ 235 /* goto sandr; */ 236 /* */ 237 /*no_such_format_type: */ 238 /* */ 239 /* erno=260; */ 240 /* /* illegal format code assembled - containt maint-pers */ 241 /* goto sandr; */ 242 /* */ 243 /*bad_string_size: */ 244 /* erno=261; */ 245 /* /* size of field ("w") not in range 0 to 256 */ 246 /* goto sandr; */ 247 /* */ 248 /*bad_param_values: */ 249 /* erno=262; */ 250 /* /* bad parameter value in format item (output) */ 251 /* goto sandr; */ 252 /* */ 253 /*err264: */ 254 /* erno=264; */ 255 /* /* put edit cannot handle a string longer than 256 */ 256 /* goto sandr; */ 257 /* */ 258 /*err265: */ 259 /* erno=265; */ 260 /* /* put edit cannot handle a string of length <0. */ 261 /* possible compiler error. contain maint-pers. */ 262 /* goto sandr; */ 263 /* */ 264 /*sandr: */ 265 /* call plio2_signal_$s_r_(psp,"ERROR","PVE",erno); */ 266 /* */ 267 /*data_format: */ 268 /* if ftype=a_format then */ 269 /* do; */ 270 /* if bc2="sc" then */ 271 /* do; */ 272 /* if type5.ff="v" */ 273 /* then do; */ 274 /* descriptive.prec = ps.vp->based_int; */ 275 /* ps.vp = addrel(ps.vp,1); */ 276 /* end; */ 277 /* */ 278 /* if descriptive.prec>256 then goto err264; */ 279 /* if descriptive.prec<0 then goto err265; */ 280 /* substr(char256,1,descriptive.prec)=substr(ps.vp->based_chars,1,descriptive.prec); */ 281 /* end; */ 282 /* */ 283 /* else do; */ 284 /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ 285 /* */ 286 /* if ps.descr="0"b */ 287 /* then do; */ 288 /* intype = char_desc*2; */ 289 /* inprec = inpicture_p->picture_image.varlength; */ 290 /* inscale = 0; */ 291 /* end; */ 292 /* */ 293 /* call assign_(addr(v_output),v_char_desc*2,256,ps.vp,intype,inscale_prec); */ 294 /* */ 295 /* descriptive.prec = length(v_output); */ 296 /* */ 297 /* if descriptive.prec>256 then goto err264; */ 298 /* if descriptive.prec<0 then goto err265; */ 299 /* substr(char256,1,descriptive.prec) = substr(v_output,1,descriptive.prec); */ 300 /* end; */ 301 /* goto put_field_string; */ 302 /* */ 303 /* end; */ 304 /* */ 305 /* if ftype=b_format then */ 306 /* do; */ 307 /* if bc2="sb" then */ 308 /* do; */ 309 /* if type5.ff="v" */ 310 /* then do; */ 311 /* descriptive.prec = ps.vp->based_int; */ 312 /* ps.vp = addrel(ps.vp,1); */ 313 /* end; */ 314 /* */ 315 /* if descriptive.prec>256 then goto err264; */ 316 /* if descriptive.prec<0 then goto err265; */ 317 /* substr(vbit256,1,descriptive.prec)=substr(vp->based_bits,1,descriptive.prec); */ 318 /* end; */ 319 /* */ 320 /* else do; */ 321 /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ 322 /* */ 323 /* if ps.descr="0"b */ 324 /* then do; */ 325 /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ 326 /* call assign_(addr(vbit256),v_bit_desc*2,256,addr(buffer),intype,inscale_prec); */ 327 /* end; */ 328 /* else call assign_(addr(vbit256),v_bit_desc*2,256,ps.vp,intype,inscale_prec); */ 329 /* */ 330 /* descriptive.prec = length(vbit256); */ 331 /* */ 332 /* if descriptive.prec>256 then goto err264; */ 333 /* if descriptive.prec<0 then goto err265; */ 334 /* end; */ 335 /* */ 336 /* char256=(128)"0"||(128)"0"; */ 337 /* do i= 1 to descriptive.prec; */ 338 /* if substr(vbit256,i,1) then substr(char256,i,1)="1"; */ 339 /* end; */ 340 /* */ 341 /* go to put_field_string; */ 342 /* end; */ 343 /* */ 344 /* if ftype=c_format then */ 345 /* do; */ 346 /* icomplex=1; */ 347 /* format_bp=addrel(format_bp,5); */ 348 /* go to complex_edit_1; */ 349 /* end; */ 350 /* */ 351 /*ef_prep: */ 352 /* if nval<1 then goto too_few_params; */ 353 /* if iw>256 then go to bad_string_size; */ 354 /* if iw<0 then goto bad_param_values; */ 355 /* if iw=0 then goto edit_exit; */ 356 /* */ 357 /* lzero=0; */ 358 /* sign_char="+"; */ 359 /* efbuf=""; */ 360 /* */ 361 /* if ftype=e_format then */ 362 /* do; */ 363 /* */ 364 /* /* E format forms - AG94 preserves the Y33 forms */ 365 /* */ 366 /* zeros nonzeros */ 367 /* */ 368 /* 0e+000 56e-123 s>0,d=0 [s=2,d=0] */ 369 /* 0.000e+000 56.123e-123 s>d>0 [s=5,d=3] */ 370 /* 0.000e+000 0.123e-123 s=d>0 [s,d=3] */ 371 /* */ 372 /* */ 373 /* /* check parameters, make defaults */ 374 /* if nval<2 then id=iw-8; */ 375 /* else do; */ 376 /* id = format_block.val(2); */ 377 /* if id>59 then goto bad_param_values; */ 378 /* end; */ 379 /* if nval<3 then is=id+1; */ 380 /* else do; */ 381 /* is=format_block.val(3); */ 382 /* if id>59 then goto bad_param_values; */ 383 /* end; */ 384 /* */ 385 /* if id<0 | isiw then goto sig_size_for_ef; */ 387 /* */ 388 /* */ 389 /* /* prepare to convert INPUT to decimal float */ 390 /* */ 391 /* /* NB: Technically, according to AG94-0, two */ 392 /* conversions take place. First, INPUT->FLO DEC(n_input) */ 393 /* and then FLO DEC(n_input)->FLO DEC(n_format). */ 394 /* */ 395 /* However, AG94 says elsewhere that precision of */ 396 /* floating point number is the _m_i_n_i_m_u_m number of */ 397 /* digits which must be kept; I may elect to keep */ 398 /* more; and no double rounding may occur (except due to */ 399 /* bin->dec) and so the single conversion done here */ 400 /* is functionally equivalent to the double conversion */ 401 /* specified. */ 402 /* */ 403 /* if icomplex=2 then ddflo="1001100"b; */ 404 /* else ddflo="1001010"b; */ 405 /* if is>59 then */ 406 /* do; */ 407 /* lzero=is-59; */ 408 /* ipreciz=59; */ 409 /* end; */ 410 /* */ 411 /* else ipreciz=is; */ 412 /* */ 413 /* expstr="e+000"; */ 414 /* if id>0 then idn=1; else idn=0; */ 415 /* */ 416 /* addr(ddflo)->m_12=addr(ipreciz)->m_12; */ 417 /* */ 418 /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ 419 /* call assign_type_d(ddflo,psp,outpicture_p,outtype,outscale_prec); */ 420 /* */ 421 /* if ps.descr="0"b */ 422 /* then do; */ 423 /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ 424 /* call assign_round_(addr(decimal),outtype,outscale_prec,addr(buffer),intype,inscale_prec); */ 425 /* end; */ 426 /* else call assign_round_(addr(decimal),outtype,outscale_prec,ps.vp,intype,inscale_prec); */ 427 /* */ 428 /* /* ************************** */ 429 /* /* */ 430 /* /* must contrive that this */ 431 /* /* conversion is ROUNDED */ 432 /* /* */ 433 /* /* ************************** */ 434 /* */ 435 /* if icomplex=2 then substr(decimal,1,ipreciz+2)= */ 436 /* substr(decimal,ipreciz+3,ipreciz+2); */ 437 /* */ 438 /* do i= 2 to ipreciz+1; */ 439 /* if substr(decimal,i,1)^="0" then go to float_signif; */ 440 /* end; */ 441 /* */ 442 /* lzero=id+1+idn; */ 443 /* ief=260-lzero; */ 444 /* goto finish_e_picture; */ 445 /* */ 446 /*float_signif: */ 447 /* exp=0; */ 448 /* addr(exp)->last_char=substr(decimal,ipreciz+2,1); */ 449 /* if exp>=128 then exp=exp-256; */ 450 /* if i>2 then */ 451 /* do; */ 452 /* exp=exp+2-i; */ 453 /* decimal_temp=decimal; */ 454 /* substr(decimal,2,ipreciz)= */ 455 /* substr(decimal_temp,i,ipreciz+2-i)|| */ 456 /* substr(decimal_temp,2,i-2); */ 457 /* end; */ 458 /* sign_char=substr(decimal,1,1); */ 459 /* */ 460 /* /* make up non-trivial expstr */ 461 /* */ 462 /* exp=exp +id +ipreciz -is; */ 463 /* /* shift decimal point to left (ipreciz), */ 464 /* then to far right (is), then to proper */ 465 /* decimal point (id) */ 466 /* */ 467 /* */ 468 /* if exp<0 then */ 469 /* do; */ 470 /* exp=-exp; */ 471 /* substr(expstr,2,1)="-"; */ 472 /* end; */ 473 /* if exp>=100 then */ 474 /* do; */ 475 /* exp=exp-100; */ 476 /* substr(expstr,3,1)="1"; */ 477 /* end; */ 478 /* substr(expstr,4,2)=dgt(divide(exp,10,35,0))||dgt(mod(exp,10)); */ 479 /* */ 480 /* ief=260 - is -idn; /* leaving space for decimal point if necessary */ 481 /* topdigits=is - id; */ 482 /* */ 483 /* if topdigits >= ipreciz then */ 484 /* do; /* -xxxxxx000.00000e+000 */ 485 /* /* if id=0 then topdigits=is */ 486 /* and topdigits >= ipreciz; */ 487 /* thus, id=0 is handled here */ 488 /* substr(efbuf,ief,ipreciz)=substr(decimal,2,ipreciz); */ 489 /* lzero=lzero+idn; */ 490 /* end; */ 491 /* */ 492 /* else do; */ 493 /* /* -xxxxx.xx0000000e+000 */ 494 /* /* id^=0 */ 495 /* substr(efbuf,ief,topdigits)=substr(decimal,2,topdigits); */ 496 /* substr(efbuf,ief+topdigits+1,ipreciz-topdigits)= */ 497 /* substr(decimal,topdigits+2, ipreciz-topdigits); */ 498 /* */ 499 /* if is=id then */ 500 /* do; */ 501 /* /* -0.xxxxxxxx00000000e+000 */ 502 /* ief=ief-1; */ 503 /* substr(efbuf,ief,1)="0"; */ 504 /* end; */ 505 /* */ 506 /* end; */ 507 /* */ 508 /*finish_e_picture: */ 509 /* substr(efbuf,260-lzero,lzero)=substr(zeroes,1,lzero); */ 510 /* if idn=1 then substr(efbuf,259-id,1)="."; */ 511 /* substr(efbuf,260,5)=expstr; */ 512 /* */ 513 /* goto put_field_ef; */ 514 /* */ 515 /* end; */ 516 /* */ 517 /* */ 518 /* if ftype=f_format then */ 519 /* do; */ 520 /* */ 521 /* /* F-format output forms: */ 522 /* zero nonzero */ 523 /* 0 123 d=0 */ 524 /* 0.000 0.012 d>0 */ 525 /* 0.000 345.123 d>0 */ 526 /* */ 527 /* if nval<1 then go to too_few_params; */ 528 /* if nval<2 then id=0; */ 529 /* else id=format_block.val(2); */ 530 /* if nval<3 then ip=0; */ 531 /* else ip=format_block.val(3); */ 532 /* if id<0 then go to bad_param_values; */ 533 /* if id>iw then goto sig_size_for_ef; */ 534 /* */ 535 /* if icomplex=2 then ddfix="100101100000000000000000000000111011"b; */ 536 /* else ddfix="100100100000000000000000000000111011"b; */ 537 /* */ 538 /* /* AG94-0 specifies two conversions: */ 539 /* First, INPUT to DEC (fix/flo according to INPUT) */ 540 /* (prec,scale according to INPUT) */ 541 /* Multiply the result of this by 10**ip. */ 542 /* Second, intermediate-value -> FIX DEC(p,q) where */ 543 /* p and q come from the format: */ 544 /* if d=0, (w-1,0) */ 545 /* else (w-2,d) */ 546 /* I do not do these two conversions at present. */ 547 /* As a result, my CHAR->F-format can preserve */ 548 /* the fractional part of a CHAR like "23.456" */ 549 /* whereas AG94-0 calls for CHAR->FIX DEC(59,0) */ 550 /* which would lose the fractional part. */ 551 /* */ 552 /* */ 553 /* */ 554 /* */ 555 /* dscale=id+ip; */ 556 /* substr(ddfix,13,12)=addr(dscale)->m_12; */ 557 /* */ 558 /* call assign_type_d(ps.descr,psp,inpicture_p,intype,inscale_prec); */ 559 /* call assign_type_d(ddfix,psp,outpicture_p,outtype,outscale_prec); */ 560 /* */ 561 /* if ps.descr="0"b */ 562 /* then do; */ 563 /* call unpack_picture_(addr(buffer)->char1,inpicture_p->char1,ps.vp->char1); */ 564 /* call assign_round_(addr(decimal),outtype,outscale_prec,addr(buffer),intype,inscale_prec); */ 565 /* end; */ 566 /* else call assign_round_(addr(decimal),outtype,outscale_prec,ps.vp,intype,inscale_prec); */ 567 /* */ 568 /* /* ************************** */ 569 /* /* */ 570 /* /* must contrive that this */ 571 /* /* conversion is ROUNDED */ 572 /* /* */ 573 /* /* ************************** */ 574 /* */ 575 /* if icomplex=2 then substr(decimal,1,60)=substr(decimal,61,60); */ 576 /* */ 577 /* */ 578 /* do i=2 to 60; */ 579 /* if substr(decimal,i,1)^="0" then go to fixed_signif; */ 580 /* end; */ 581 /* */ 582 /* ipreciz=1; */ 583 /* go to build_fixed_output; */ 584 /* */ 585 /*fixed_signif: */ 586 /* ipreciz=61-i; */ 587 /* sign_char=substr(decimal,1,1); */ 588 /* */ 589 /*build_fixed_output: */ 590 /* if id=0|id>=ipreciz then */ 591 /* do; */ 592 /* ief=265-ipreciz; */ 593 /* substr(efbuf,ief,ipreciz)=substr(decimal,61-ipreciz,ipreciz); */ 594 /* if id=0 then go to put_field_ef; */ 595 /* */ 596 /* ief=263-id; */ 597 /* lpref=id+2-ipreciz; */ 598 /* substr(efbuf,ief,lpref)=substr(zeroes,2,lpref); */ 599 /* substr(efbuf,ief+1,1)="."; */ 600 /* end; */ 601 /* */ 602 /* else do; */ 603 /* ief=264-ipreciz; */ 604 /* substr(efbuf,ief,ipreciz+1)= */ 605 /* substr(decimal,i,ipreciz-id)||"."|| */ 606 /* substr(decimal,61-id,id); */ 607 /* end; */ 608 /* goto put_field_ef; */ 609 /* end; */ 610 /* */ 611 /* if ftype=picture_format */ 612 /* then goto pic_format; */ 613 /* */ 614 /* go to no_such_format_type; */ 615 /* */ 616 /* */ 617 /* */ 618 /* */ 619 /*put_field_ef: */ 620 /* if sign_char="-" then */ 621 /* do; */ 622 /* ief=ief-1; */ 623 /* substr(efbuf,ief,1)="-"; */ 624 /* end; */ 625 /* if (265-ief)>iw then */ 626 /* sig_size_for_ef: */ 627 /* call plio2_signal_$s_(psp,"SIZE","put_edit",263); */ 628 /* substr(char256,1,iw)=substr(efbuf,265-iw,iw); */ 629 /* go to put_field_edit; */ 630 /* */ 631 /* */ 632 /* */ 633 /*put_field_string: */ 634 /* if nval<1 then iw=descriptive.prec; */ 635 /* if iw>256 then goto bad_string_size; */ 636 /* if iw<0 then goto bad_param_values; */ 637 /* */ 638 /* if iwdescriptive.prec then substr(char256,descriptive.prec+1,iw-descriptive.prec)=" "; */ 640 /* goto put_field_edit; */ 641 /* */ 642 /*put_field_edit: */ 643 /* if iw>256 then goto bad_string_size; */ 644 /* if iw>0 then call plio2_put_util_$put_field_(psp,addr(char256),iw); */ 645 /*edit_exit: */ 646 /* if icomplex=1 then */ 647 /* do; */ 648 /* icomplex=2; */ 649 /* format_bp=addrel(format_bp,5); */ 650 /* go to complex_edit_1; */ 651 /* end; */ 652 /* return; */ 653 /* */ 654 pve_error:entry(pspp); /* entry added for use by pl1_operators when */ 655 /* in checking a f_format finds that the size */ 656 /* has been violated. This way the buffer gets */ 657 /* put out and full processing of the condiition */ 658 /* is possible.*/ 659 660 psp=pspp; 661 call plio2_signal_$s_(psp,"SIZE","put_edit",263); 662 return; 663 664 665 end plio2_pve_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/03/83 1005.5 plio2_pve_.pl1 >spec>on>pl128d>plio2_pve_.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. plio2_signal_$s_ 000010 constant entry external dcl 51 ref 661 psp 000100 automatic pointer dcl 17 set ref 660* 661* pspp parameter pointer dcl 17 ref 10 11 654 660 NAMES DECLARED BY EXPLICIT CONTEXT. plio2_pve_ 000013 constant entry external dcl 10 put_value_edit_ 000024 constant entry external dcl 11 pve_error 000035 constant entry external dcl 654 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 154 166 102 164 Length 332 102 12 130 51 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME plio2_pve_ 88 external procedure is an external procedure. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME plio2_pve_ 000100 psp plio2_pve_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out_desc return ext_entry set_support THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. 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 10 000010 11 000021 654 000032 660 000043 661 000047 662 000101 ----------------------------------------------------------- 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