1 /* @(#)doprnt.c 4.4 (Berkeley) 11/25/81 */ 2 # C library -- conversions 3 4 .globl __doprnt 5 .globl __flsbuf 6 7 #define vbit 1 8 #define flags r10 9 #define ndfnd 0 10 #define prec 1 11 #define zfill 2 12 #define minsgn 3 13 #define plssgn 4 14 #define numsgn 5 15 #define caps 6 16 #define blank 7 17 #define gflag 8 18 #define dpflag 9 19 #define width r9 20 #define ndigit r8 21 #define llafx r7 22 #define lrafx r6 23 #define fdesc -4(fp) 24 #define exp -8(fp) 25 #define sexp -12(fp) 26 #define nchar -16(fp) 27 #define sign -17(fp) 28 .set ch.zer,'0 # cpp doesn't like single appostrophes 29 30 .align 2 31 strtab: # translate table for detecting null and percent 32 .byte 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 33 .byte 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31 34 .byte ' ,'!,'",'#,'$, 0,'&,'','(,'),'*,'+,',,'-,'.,'/ 35 .byte '0,'1,'2,'3,'4,'5,'6,'7,'8,'9,':,';,'<,'=,'>,'? 36 .byte '@,'A,'B,'C,'D,'E,'F,'G,'H,'I,'J,'K,'L,'M,'N,'O 37 .byte 'P,'Q,'R,'S,'T,'U,'V,'W,'X,'Y,'Z,'[,'\,'],'^,'_ 38 .byte '`,'a,'b,'c,'d,'e,'f,'g,'h,'i,'j,'k,'l,'m,'n,'o 39 .byte 'p,'q,'r,'s,'t,'u,'v,'w,'x,'y,'z,'{,'|,'},'~,127 40 .byte 128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143 41 .byte 144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159 42 .byte 160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175 43 .byte 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191 44 .byte 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207 45 .byte 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223 46 .byte 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239 47 .byte 240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255 48 49 .align 1 50 __doprnt: 51 .word 0xfc0 # uses r11-r6 52 jbr doit 53 54 strfoo: 55 clrl r4 # fix interrupt race 56 jbr strok # and try again 57 strmore: 58 movzbl (r1)+,r2 # one char 59 tstb strtab[r2] # translate 60 jeql stresc2 # bad guy in disguise (outbuf is full) 61 strout2: # enter here to force out r2; r0,r1 must be set 62 pushr $3 # save input descriptor 63 pushl fdesc # FILE 64 pushl r2 # the char 65 calls $2,__flsbuf # please empty the buffer and handle 1 char 66 tstl r0 # successful? 67 jgeq strm1 # yes 68 jbcs $31,nchar,strm1 # turn on sign bit of nchar to signify error 69 strm1: 70 incl nchar # count the char 71 popr $3 # get input descriptor back 72 strout: # enter via bsb with (r0,r1)=input descriptor 73 movab strtab,r3 # table address 74 movq *fdesc,r4 # output descriptor 75 jbs $31,r4,strfoo # negative count is a no no 76 strok: 77 addl2 r0,nchar # we intend to move this many chars 78 /******* Start bogus movtuc workaround *****/ 79 clrl r2 80 tstl r0 81 bleq movdon 82 movlp: 83 tstl r4 84 bleq movdon 85 movzbl (r1)+,r3 86 tstb strtab[r3] 87 bneq 1f 88 mnegl $1,r2 89 decl r1 90 brb movdon 91 1: 92 movb r3,(r5)+ 93 decl r4 94 sobgtr r0,movlp 95 /******* End bogus movtuc workaround *** 96 movtuc r0,(r1),$0,(r3),r4,(r5) 97 movpsl r2 /* squirrel away condition codes */ 98 /******* End equally bogus movtuc ****/ 99 movdon: movq r4,*fdesc /* update output descriptor */ 100 subl2 r0,nchar # some chars not moved 101 jbs $vbit,r2,stresc # terminated by escape? 102 sobgeq r0,strmore # no; but out buffer might be full 103 stresc: 104 rsb 105 stresc2: 106 incl r0 # fix the length 107 decl r1 # and the addr 108 movl $1<vbit,r2 # fake condition codes 109 rsb 110 111 errdone: 112 jbcs $31,nchar,prdone # set error bit 113 prdone: 114 movl nchar,r0 115 ret 116 117 doit: 118 movab -256(sp),sp # work space 119 movl 4(ap),r11 # addr of format string 120 movl 12(ap),fdesc # output FILE ptr 121 movl 8(ap),ap # addr of first arg 122 clrl nchar # number of chars transferred 123 loop: 124 movzwl $65535,r0 # pseudo length 125 movl r11,r1 # fmt addr 126 # comet sucks. 127 movq *fdesc,r4 128 subl3 r1,r5,r2 129 jlss lp1 130 cmpl r0,r2 131 jleq lp1 132 movl r2,r0 133 lp1: 134 # 135 bsbw strout # copy to output, stop at null or percent 136 movl r1,r11 # new fmt 137 jbc $vbit,r2,loop # if no escape, then very long fmt 138 tstb (r11)+ # escape; null or percent? 139 jeql prdone # null means end of fmt 140 141 movl sp,r5 # reset output buffer pointer 142 clrq r9 # width; flags 143 clrq r6 # lrafx,llafx 144 longorunsg: # we can ignore both of these distinctions 145 short: 146 L4a: 147 movzbl (r11)+,r0 # so capital letters can tail merge 148 L4: caseb r0,$' ,$'x-' # format char 149 L5: 150 .word space-L5 # space 151 .word fmtbad-L5 # ! 152 .word fmtbad-L5 # " 153 .word sharp-L5 # # 154 .word fmtbad-L5 # $ 155 .word fmtbad-L5 # % 156 .word fmtbad-L5 # & 157 .word fmtbad-L5 # ' 158 .word fmtbad-L5 # ( 159 .word fmtbad-L5 # ) 160 .word indir-L5 # * 161 .word plus-L5 # + 162 .word fmtbad-L5 # , 163 .word minus-L5 # - 164 .word dot-L5 # . 165 .word fmtbad-L5 # / 166 .word gnum0-L5 # 0 167 .word gnum-L5 # 1 168 .word gnum-L5 # 2 169 .word gnum-L5 # 3 170 .word gnum-L5 # 4 171 .word gnum-L5 # 5 172 .word gnum-L5 # 6 173 .word gnum-L5 # 7 174 .word gnum-L5 # 8 175 .word gnum-L5 # 9 176 .word fmtbad-L5 # : 177 .word fmtbad-L5 # ; 178 .word fmtbad-L5 # < 179 .word fmtbad-L5 # = 180 .word fmtbad-L5 # > 181 .word fmtbad-L5 # ? 182 .word fmtbad-L5 # @ 183 .word fmtbad-L5 # A 184 .word fmtbad-L5 # B 185 .word fmtbad-L5 # C 186 .word decimal-L5 # D 187 .word capital-L5 # E 188 .word fmtbad-L5 # F 189 .word capital-L5 # G 190 .word fmtbad-L5 # H 191 .word fmtbad-L5 # I 192 .word fmtbad-L5 # J 193 .word fmtbad-L5 # K 194 .word fmtbad-L5 # L 195 .word fmtbad-L5 # M 196 .word fmtbad-L5 # N 197 .word octal-L5 # O 198 .word fmtbad-L5 # P 199 .word fmtbad-L5 # Q 200 .word fmtbad-L5 # R 201 .word fmtbad-L5 # S 202 .word fmtbad-L5 # T 203 .word unsigned-L5 # U 204 .word fmtbad-L5 # V 205 .word fmtbad-L5 # W 206 .word hex-L5 # X 207 .word fmtbad-L5 # Y 208 .word fmtbad-L5 # Z 209 .word fmtbad-L5 # [ 210 .word fmtbad-L5 # \ 211 .word fmtbad-L5 # ] 212 .word fmtbad-L5 # ^ 213 .word fmtbad-L5 # _ 214 .word fmtbad-L5 # ` 215 .word fmtbad-L5 # a 216 .word fmtbad-L5 # b 217 .word charac-L5 # c 218 .word decimal-L5 # d 219 .word scien-L5 # e 220 .word float-L5 # f 221 .word general-L5 # g 222 .word short-L5 # h 223 .word fmtbad-L5 # i 224 .word fmtbad-L5 # j 225 .word fmtbad-L5 # k 226 .word longorunsg-L5 # l 227 .word fmtbad-L5 # m 228 .word fmtbad-L5 # n 229 .word octal-L5 # o 230 .word fmtbad-L5 # p 231 .word fmtbad-L5 # q 232 .word fmtbad-L5 # r 233 .word string-L5 # s 234 .word fmtbad-L5 # t 235 .word unsigned-L5 # u 236 .word fmtbad-L5 # v 237 .word fmtbad-L5 # w 238 .word hex-L5 # x 239 fmtbad: 240 movb r0,(r5)+ # print the unfound character 241 jeql errdone # dumb users who end the format with a % 242 jbr prbuf 243 capital: 244 bisl2 $1<caps,flags # note that it was capitalized 245 xorb2 $'a^'A,r0 # make it small 246 jbr L4 # and try again 247 248 string: 249 movl ndigit,r0 250 jbs $prec,flags,L20 # max length was specified 251 mnegl $1,r0 # default max length 252 L20: movl (ap)+,r2 # addr first byte 253 locc $0,r0,(r2) # find the zero at the end 254 movl r1,r5 # addr last byte +1 255 movl r2,r1 # addr first byte 256 jbr prstr 257 258 htab: .byte '0,'1,'2,'3,'4,'5,'6,'7,'8,'9,'a,'b,'c,'d,'e,'f 259 Htab: .byte '0,'1,'2,'3,'4,'5,'6,'7,'8,'9,'A,'B,'C,'D,'E,'F 260 261 octal: 262 movl $30,r2 # init position 263 movl $3,r3 # field width 264 movab htab,llafx # translate table 265 jbr L10 266 267 hex: 268 movl $28,r2 # init position 269 movl $4,r3 # field width 270 movab htab,llafx # translate table 271 jbc $caps,flags,L10 272 movab Htab,llafx 273 L10: mnegl r3,r6 # increment 274 clrl r1 275 addl2 $4,r5 # room for left affix (2) and slop [forced sign?] 276 movl (ap)+,r0 # fetch arg 277 L11: extzv r2,r3,r0,r1 # pull out a digit 278 movb (llafx)[r1],(r5)+ # convert to character 279 L12: acbl $0,r6,r2,L11 # continue until done 280 clrq r6 # lrafx, llafx 281 clrb (r5) # flag end 282 skpc $'0,$11,4(sp) # skip over leading zeroes 283 jbc $numsgn,flags,prn3 # easy if no left affix 284 tstl -4(ap) # original value 285 jeql prn3 # no affix on 0, for some reason 286 cmpl r3,$4 # were we doing hex or octal? 287 jneq L12a # octal 288 movb $'x,r0 289 jbc $caps,flags,L12b 290 movb $'X,r0 291 L12b: movb r0,-(r1) 292 movl $2,llafx # leading 0x for hex is an affix 293 L12a: movb $'0,-(r1) # leading zero for octal is a digit, not an affix 294 jbr prn3 # omit sign (plus, blank) massaging 295 296 unsigned: 297 lunsigned: 298 bicl2 $1<plssgn|1<blank,flags # omit sign (plus, blank) massaging 299 extzv $1,$31,(ap),r0 # right shift logical 1 bit 300 cvtlp r0,$10,(sp) # convert [n/2] to packed 301 movp $10,(sp),8(sp) # copy packed 302 addp4 $10,8(sp),$10,(sp) # 2*[n/2] in packed, at (sp) 303 blbc (ap)+,L14 # n was even 304 addp4 $1,pone,$10,(sp) # n was odd 305 jbr L14 306 307 patdec: # editpc pattern for decimal printing 308 .byte 0xAA # eo$float 10 309 .byte 0x01 # eo$end_float 310 .byte 0 # eo$end 311 312 decimal: 313 cvtlp (ap)+,$10,(sp) # 10 digits max 314 jgeq L14 315 incl llafx # minus sign is a left affix 316 L14: editpc $10,(sp),patdec,8(sp) # ascii at 8(sp); r5=end+1 317 skpc $' ,$11,8(sp) # skip leading blanks; r1=first 318 319 prnum: # r1=addr first byte, r5=addr last byte +1, llafx=size of signs 320 # -1(r1) vacant, for forced sign 321 tstl llafx 322 jneq prn3 # already some left affix, dont fuss 323 jbc $plssgn,flags,prn2 324 movb $'+,-(r1) # needs a plus sign 325 jbr prn4 326 prn2: jbc $blank,flags,prn3 327 movb $' ,-(r1) # needs a blank sign 328 prn4: incl llafx 329 prn3: jbs $prec,flags,prn1 330 movl $1,ndigit # default precision is 1 331 prn1: subl3 r1,r5,lrafx # raw width 332 subl2 llafx,lrafx # number of digits 333 subl2 lrafx,ndigit # number of leading zeroes needed 334 jleq prstr # none 335 addl2 llafx,r1 # where current digits start 336 pushl r1 # movcx gobbles registers 337 # check bounds on users who say %.300d 338 movab 32(r5)[ndigit],r2 339 subl2 fp,r2 340 jlss prn5 341 subl2 r2,ndigit 342 prn5: 343 # 344 movc3 lrafx,(r1),(r1)[ndigit] # make room in middle 345 movc5 $0,(r1),$ch.zer,ndigit,*(sp) # '0 fill 346 subl3 llafx,(sp)+,r1 # first byte addr 347 addl3 lrafx,r3,r5 # last byte addr +1 348 349 prstr: # r1=addr first byte; r5=addr last byte +1 350 # width=minimum width; llafx=len. left affix 351 # ndigit=<avail> 352 subl3 r1,r5,ndigit # raw width 353 subl3 ndigit,width,r0 # pad length 354 jleq padlno # in particular, no left padding 355 jbs $minsgn,flags,padlno 356 # extension for %0 flag causing left zero padding to field width 357 jbs $zfill,flags,padlz 358 # this bsbb needed even if %0 flag extension is removed 359 bsbb padb # blank pad on left 360 jbr padnlz 361 padlz: 362 movl llafx,r0 363 jleq padnlx # left zero pad requires left affix first 364 subl2 r0,ndigit # part of total length will be transferred 365 subl2 r0,width # and will account for part of minimum width 366 bsbw strout # left affix 367 padnlx: 368 subl3 ndigit,width,r0 # pad length 369 bsbb padz # zero pad on left 370 padnlz: 371 # end of extension for left zero padding 372 padlno: # remaining: root, possible right padding 373 subl2 ndigit,width # root reduces minimum width 374 movl ndigit,r0 # root length 375 p1: bsbw strout # transfer to output buffer 376 p3: jbc $vbit,r2,padnpct # percent sign (or null byte via %c) ? 377 decl r0 # yes; adjust count 378 movzbl (r1)+,r2 # fetch byte 379 movq *fdesc,r4 # output buffer descriptor 380 sobgeq r4,p2 # room at the out [inn] ? 381 bsbw strout2 # no; force it, then try rest 382 jbr p3 # here we go 'round the mullberry bush, ... 383 p2: movb r2,(r5)+ # hand-deposit the percent or null 384 incl nchar # count it 385 movq r4,*fdesc # store output descriptor 386 jbr p1 # what an expensive hiccup! 387 padnpct: 388 movl width,r0 # size of pad 389 jleq loop 390 bsbb padb 391 jbr loop 392 393 padz: 394 movb $'0,r2 395 jbr pad 396 padb: 397 movb $' ,r2 398 pad: 399 subl2 r0,width # pad width decreases minimum width 400 pushl r1 # save non-pad addr 401 movl r0,llafx # remember width of pad 402 subl2 r0,sp # allocate 403 movc5 $0,(r0),r2,llafx,(sp) # create pad string 404 movl llafx,r0 # length 405 movl sp,r1 # addr 406 bsbw strout 407 addl2 llafx,sp # deallocate 408 movl (sp)+,r1 # recover non-pad addr 409 rsb 410 411 pone: .byte 0x1C # packed 1 412 413 charac: 414 movl (ap)+,r0 # word containing the char 415 movb r0,(r5)+ # one byte, that's all 416 417 prbuf: 418 movl sp,r1 # addr first byte 419 jbr prstr 420 421 space: bisl2 $1<blank,flags # constant width e fmt, no plus sign 422 jbr L4a 423 sharp: bisl2 $1<numsgn,flags # 'self identifying', please 424 jbr L4a 425 plus: bisl2 $1<plssgn,flags # always print sign for floats 426 jbr L4a 427 minus: bisl2 $1<minsgn,flags # left justification, please 428 jbr L4a 429 gnum0: jbs $ndfnd,flags,gnum 430 jbs $prec,flags,gnump # ignore when reading precision 431 bisl2 $1<zfill,flags # leading zero fill, please 432 gnum: jbs $prec,flags,gnump 433 moval (width)[width],width # width *= 5; 434 movaw -ch.zer(r0)[width],width # width = 2*witdh + r0 - '0'; 435 jbr gnumd 436 gnump: moval (ndigit)[ndigit],ndigit # ndigit *= 5; 437 movaw -ch.zer(r0)[ndigit],ndigit # ndigit = 2*ndigit + r0 - '0'; 438 gnumd: bisl2 $1<ndfnd,flags # digit seen 439 jbr L4a 440 dot: clrl ndigit # start on the precision 441 bisl2 $1<prec,flags 442 bicl2 $1<ndfnd,flags 443 jbr L4a 444 indir: 445 jbs $prec,flags,in1 446 movl (ap)+,width # width specified by parameter 447 jgeq gnumd 448 xorl2 $1<minsgn,flags # parameterized left adjustment 449 mnegl width,width 450 jbr gnumd 451 in1: 452 movl (ap)+,ndigit # precision specified by paratmeter 453 jgeq gnumd 454 mnegl ndigit,ndigit 455 jbr gnumd 456 457 float: 458 jbs $prec,flags,float1 459 movl $6,ndigit # default # digits to right of decpt. 460 float1: bsbw fltcvt 461 addl3 exp,ndigit,r7 462 movl r7,r6 # for later "underflow" checking 463 bgeq fxplrd 464 clrl r7 # poor programmer planning 465 fxplrd: cmpl r7,$31 # expressible in packed decimal? 466 bleq fnarro # yes 467 movl $31,r7 468 fnarro: subl3 $17,r7,r0 # where to round 469 ashp r0,$17,(sp),$5,r7,16(sp) # do it 470 bvc fnovfl 471 # band-aid for microcode error (spurious overflow) 472 # clrl r0 # assume even length result 473 # jlbc r7,fleven # right 474 # movl $4,r0 # odd length result 475 #fleven: cmpv r0,$4,16(sp),$0 # top digit zero iff true overflow 476 # bneq fnovfl 477 # end band-aid 478 aobleq $0,r6,fnovfl # if "underflow" then jump 479 movl r7,r0 480 incl exp 481 incl r7 482 ashp r0,$1,pone,$0,r7,16(sp) 483 ashl $-1,r7,r0 # displ to last byte 484 bisb2 sign,16(sp)[r0] # insert sign 485 fnovfl: 486 movab 16(sp),r1 # packed source 487 movl r7,r6 # packed length 488 pushab prnum # goto prnum after fall-through call to fedit 489 490 491 # enter via bsb 492 # r1=addr of packed source 493 # 16(r1) used to unpack source 494 # 48(r1) used to construct pattern to unpack source 495 # 48(r1) used to hold result 496 # r6=length of packed source (destroyed) 497 # exp=# digits to left of decimal point (destroyed) 498 # ndigit=# digits to right of decimal point (destroyed) 499 # sign=1 if negative, 0 otherwise 500 # stack will be used for work space for pattern and unpacked source 501 # exits with 502 # r1=addr of punctuated result 503 # r5=addr of last byte +1 504 # llafx=1 if minus sign inserted, 0 otherwise 505 fedit: 506 pushab 48(r1) # save result addr 507 movab 48(r1),r3 # pattern addr 508 movb $0x03,(r3)+ # eo$set_signif 509 movc5 $0,(r1),$0x91,r6,(r3) # eo$move 1 510 clrb (r3) # eo$end 511 editpc r6,(r1),48(r1),16(r1) # unpack 'em all 512 subl3 r6,r5,r1 # addr unpacked source 513 movl (sp),r3 # punctuated output placed here 514 clrl llafx 515 jlbc sign,f1 516 movb $'-,(r3)+ # negative 517 incl llafx 518 f1: movl exp,r0 519 jgtr f2 520 movb $'0,(r3)+ # must have digit before decimal point 521 jbr f3 522 f2: cmpl r0,r6 # limit on packed length 523 jleq f4 524 movl r6,r0 525 f4: subl2 r0,r6 # eat some digits 526 subl2 r0,exp # from the exponent 527 movc3 r0,(r1),(r3) # (most of the) digits to left of decimal point 528 movl exp,r0 # need any more? 529 jleq f3 530 movc5 $0,(r1),$'0,r0,(r3) # '0 fill 531 f3: movl ndigit,r0 # # digits to right of decimal point 532 jgtr f5 533 jbs $numsgn,flags,f5 # no decimal point unless forced 534 jbcs $dpflag,flags,f6 # no decimal point 535 f5: movb $'.,(r3)+ # the decimal point 536 f6: mnegl exp,r0 # "leading" zeroes to right of decimal point 537 jleq f9 538 cmpl r0,ndigit # cant exceed this many 539 jleq fa 540 movl ndigit,r0 541 fa: subl2 r0,ndigit 542 movc5 $0,(r1),$'0,r0,(r3) 543 f9: movl ndigit,r0 544 cmpl r0,r6 # limit on packed length 545 jleq f7 546 movl r6,r0 547 f7: subl2 r0,ndigit # eat some digits from the fraction 548 movc3 r0,(r1),(r3) # (most of the) digits to right of decimal point 549 movl ndigit,r0 # need any more? 550 jleq f8 551 # check bounds on users who say %.300f 552 movab 32(r3)[r0],r2 553 subl2 fp,r2 554 jlss fb 555 subl2 r2,r0 # truncate, willy-nilly 556 movl r0,ndigit # and no more digits later, either 557 fb: 558 # 559 subl2 r0,ndigit # eat some digits from the fraction 560 movc5 $0,(r1),$'0,r0,(r3) # '0 fill 561 f8: movl r3,r5 # addr last byte +1 562 popr $1<1 # [movl (sp)+,r1] addr first byte 563 rsb 564 565 patexp: .byte 0x03 # eo$set_signif 566 .byte 0x44,'e # eo$insert 'e 567 .byte 0x42,'+ # eo$load_plus '+ 568 .byte 0x04 # eo$store_sign 569 .byte 0x92 # eo$move 2 570 .byte 0 # eo$end 571 572 scien: 573 incl ndigit 574 jbs $prec,flags,L23 575 movl $7,ndigit 576 L23: bsbw fltcvt # get packed digits 577 movl ndigit,r7 578 cmpl r7,$31 # expressible in packed decimal? 579 jleq snarro # yes 580 movl $31,r7 581 snarro: subl3 $17,r7,r0 # rounding position 582 ashp r0,$17,(sp),$5,r7,16(sp) # shift and round 583 bvc snovfl 584 # band-aid for microcode error (spurious overflow) 585 # clrl r0 # assume even length result 586 # jlbc ndigit,sceven # right 587 # movl $4,r0 # odd length result 588 #sceven: cmpv r0,$4,16(sp),$0 # top digit zero iff true overflow 589 # bneq snovfl 590 # end band-aid 591 incl exp # rounding overflowed to 100... 592 subl3 $1,r7,r0 593 ashp r0,$1,pone,$0,r7,16(sp) 594 ashl $-1,r7,r0 # displ to last byte 595 bisb2 sign,16(sp)[r0] # insert sign 596 snovfl: 597 jbs $gflag,flags,gfmt # %g format 598 movab 16(sp),r1 599 bsbb eedit 600 eexp: 601 movl r1,r6 # save fwa from destruction by cvtlp 602 subl3 $1,sexp,r0 # 1P exponent 603 cvtlp r0,$2,(sp) # packed 604 editpc $2,(sp),patexp,(r5) 605 movl r6,r1 # fwa 606 jbc $caps,flags,prnum 607 xorb2 $'e^'E,-4(r5) 608 jbr prnum 609 610 eedit: 611 movl r7,r6 # packed length 612 decl ndigit # 1 digit before decimal point 613 movl exp,sexp # save from destruction 614 movl $1,exp # and pretend 615 jbr fedit 616 617 gfmt: 618 addl3 $3,exp,r0 # exp is 1 more than e 619 jlss gfmte # (e+1)+3<0, e+4<=-1, e<=-5 620 subl2 $3,r0 # exp [==(e+1)] 621 cmpl r0,ndigit 622 jgtr gfmte # e+1>n, e>=n 623 gfmtf: 624 movl r7,r6 625 subl2 r0,ndigit # n-e-1 626 movab 16(sp),r1 627 bsbw fedit 628 g1: jbs $numsgn,flags,g2 629 jbs $dpflag,flags,g2 # dont strip if no decimal point 630 g3: cmpb -(r5),$'0 # strip trailing zeroes 631 jeql g3 632 cmpb (r5),$'. # and trailing decimal point 633 jeql g2 634 incl r5 635 g2: jbc $gflag,flags,eexp 636 jbr prnum 637 gfmte: 638 movab 16(sp),r1 # packed source 639 bsbw eedit 640 jbsc $gflag,flags,g1 # gflag now means "use %f" [hence no exponent] 641 642 general: 643 jbs $prec,flags,gn1 644 movl $6,ndigit # default precision is 6 significant digits 645 gn1: tstl ndigit # cannot allow precision of 0 646 jgtr gn2 647 movl $1,ndigit # change 0 to 1, willy-nilly 648 gn2: jbcs $gflag,flags,L23 649 jbr L23 # safety net 650 651 # convert double-floating at (ap) to 17-digit packed at (sp), 652 # set 'sign' and 'exp', advance ap. 653 fltcvt: 654 clrb sign 655 movd (ap)+,r5 656 jeql fzero 657 bgtr fpos 658 mnegd r5,r5 659 incb sign 660 fpos: 661 extzv $7,$8,r5,r2 # exponent of 2 662 movab -0200(r2),r2 # unbias 663 mull2 $59,r2 # 59/196: 3rd convergent continued frac of log10(2) 664 jlss eneg 665 movab 196(r2),r2 666 eneg: 667 movab -98(r2),r2 668 divl2 $196,r2 669 bsbw expten 670 cmpd r0,r5 671 bgtr ceil 672 incl r2 673 ceil: movl r2,exp 674 mnegl r2,r2 675 cmpl r2,$29 # 10^(29+9) is all we can handle 676 bleq getman 677 muld2 ten16,r5 678 subl2 $16,r2 679 getman: addl2 $9,r2 # -ceil(log10(x)) + 9 680 jsb expten 681 emodd r0,r4,r5,r0,r5 # (r0+r4)*r5; r0=int, r5=frac 682 fz1: cvtlp r0,$9,16(sp) # leading 9 digits 683 ashp $8,$9,16(sp),$0,$17,4(sp) # as top 9 of 17 684 emodd ten8,$0,r5,r0,r5 685 cvtlp r0,$8,16(sp) # trailing 8 digits 686 # if precision >= 17, must round here 687 movl ndigit,r7 # so figure out what precision is 688 pushab scien 689 cmpl (sp)+,(sp) 690 jleq gm1 # who called us? 691 addl2 exp,r7 # float; adjust for exponent 692 gm1: cmpl r7,$17 693 jlss gm2 694 cmpd r5,$0d0.5 # must round here; check fraction 695 jlss gm2 696 bisb2 $0x10,8+4(sp) # increment l.s. digit 697 gm2: # end of "round here" code 698 addp4 $8,16(sp),$17,4(sp) # combine leading and trailing 699 bisb2 sign,12(sp) # and insert sign 700 rsb 701 fzero: clrl r0 702 movl $1,exp # 0.000e+00 and 0.000 rather than 0.000e-01 and .000 703 jbr fz1 704 705 .align 2 706 lsb: .long 0x00010000 # lsb in the crazy floating-point format 707 708 # return 10^r2 as a double float in r0||r1 and 8 extra bits of precision in r4 709 # preserve r2, r5||r6 710 expten: 711 movd $0d1.0,r0 # begin computing 10^exp10 712 clrl r4 # bit counter 713 movad ten1,r3 # table address 714 tstl r2 715 bgeq e10lp 716 mnegl r2,r2 # get absolute value 717 jbss $6,r2,e10lp # flag as negative 718 e10lp: jbc r4,r2,el1 # want this power? 719 muld2 (r3),r0 # yes 720 el1: addl2 $8,r3 # advance to next power 721 aobleq $5,r4,e10lp # through 10^32 722 jbcc $6,r2,el2 # correct for negative exponent 723 divd3 r0,$0d1.0,r0 # by taking reciprocal 724 cmpl $28,r2 725 jneq enm28 726 addl2 lsb,r1 # 10**-28 needs lsb incremented 727 enm28: mnegl r2,r2 # original exponent of 10 728 el2: addl3 $5*8,r2,r3 # negative bit positions are illegal? 729 jbc r3,xlsbh-5,eoklsb 730 subl2 lsb,r1 # lsb was too high 731 eoklsb: 732 movzbl xprec[r2],r4 # 8 extra bits 733 rsb 734 735 # powers of ten 736 .align 2 737 ten1: .word 0x4220,0,0,0 738 ten2: .word 0x43c8,0,0,0 739 ten4: .word 0x471c,0x4000,0,0 740 ten8: .word 0x4dbe,0xbc20,0,0 741 ten16: .word 0x5b0e,0x1bc9,0xbf04,0 742 ten32: .word 0x759d,0xc5ad,0xa82b,0x70b6 743 744 # whether lsb is too high or not 745 .byte 1:0,1:0,1:0,1:0,1:1,1:0,1:1,1:0 # -40 thru -33 746 .byte 1:0,1:1,1:0,1:0,1:0,1:0,1:1,1:0 # -32 thru -25 747 .byte 1:0,1:0,1:1,1:1,1:1,1:1,1:0,1:0 # -24 thru -17 748 .byte 1:0,1:1,1:0,1:0,1:1,1:1,1:1,1:1 # -16 thru -9 749 .byte 1:1,1:1,1:1,1:0,1:0,1:0,1:0,1:1 # -8 thru -1 750 xlsbh: 751 .byte 1:0,1:0,1:0,1:0,1:0,1:0,1:0,1:0 # 0 thru 7 752 .byte 1:0,1:0,1:0,1:0,1:0,1:0,1:0,1:0 # 8 thru 15 753 .byte 1:0,1:0,1:0,1:0,1:0,1:0,1:0,1:0 # 16 thru 23 754 .byte 1:0,1:1,1:1,1:0,1:1,1:1,1:1,1:1 # 24 thru 31 755 .byte 1:1,1:1,1:1,1:1,1:1,1:1,1:1 # 32 thru 38 756 757 # bytes of extra precision 758 .byte 0x56,0x76,0xd3,0x88,0xb5,0x62 # -38 thru -33 759 .byte 0xba,0xf5,0x32,0x3e,0x0e,0x48,0xdb,0x51 # -32 thru -25 760 .byte 0x53,0x27,0xb1,0xef,0xeb,0xa5,0x07,0x49 # -24 thru -17 761 .byte 0x5b,0xd9,0x0f,0x13,0xcd,0xff,0xbf,0x97 # -16 thru -9 762 .byte 0xfd,0xbc,0xb6,0x23,0x2c,0x3b,0x0a,0xcd # -8 thru -1 763 xprec: 764 .byte 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 # 0 thru 7 765 .byte 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 # 8 thru 15 766 .byte 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 # 16 thru 23 767 .byte 0x00,0xa0,0xc8,0x3a,0x84,0xe4,0xdc,0x92 # 24 thru 31 768 .byte 0x9b,0x00,0xc0,0x58,0xae,0x18,0xef # 32 thru 38 769