![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to doprnt.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / lib / libc / vax / stdio|
Return to doprnt.c CVS log | Up to [CSRG BSD Unix] / 43BSD / lib / libc / vax / stdio |
1.1 root 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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.