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