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