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