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