diff options
Diffstat (limited to 'ipl/procs/printf.icn')
| -rw-r--r-- | ipl/procs/printf.icn | 313 |
1 files changed, 313 insertions, 0 deletions
diff --git a/ipl/procs/printf.icn b/ipl/procs/printf.icn new file mode 100644 index 0000000..b5f99b9 --- /dev/null +++ b/ipl/procs/printf.icn @@ -0,0 +1,313 @@ +############################################################################ +# +# File: printf.icn +# +# Subject: Procedures for printf-style formatting +# +# Author: William H. Mitchell +# +# Date: July 20, 2005 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Cheyenne Wills, Phillip Lee Thomas, Michael Glass +# +############################################################################ +# +# This procedure behaves somewhat like the standard printf. +# Supports d, e, s, o, and x formats like printf. An "r" format +# prints real numbers in a manner similar to that of printf's "f", +# but will produce a result in an exponential format if the number +# is larger than the largest integer plus one. Though "e" differs +# from printf in some details, it always produces exponential format. +# +# Left or right justification and field width control are pro- +# vided as in printf. %s, %r, and %e handle precision specifications. +# +# The %r format is quite a bit of a hack, but it meets the +# author's requirements for accuracy and speed. Code contributions +# for %f, %e, and %g formats that work like printf are welcome. +# +# Possible new formats: +# +# %t -- print a real number as a time in hh:mm +# %R -- roman numerals +# %w -- integers in English +# %b -- binary +# +############################################################################ + +procedure sprintf(format, args[]) + return _doprnt(format, args) +end + +procedure fprintf(file, format, args[]) + writes(file, _doprnt(format, args)) + return +end + +procedure printf(format, args[]) + writes(&output, _doprnt(format, args)) + return +end + +procedure _doprnt(format, args) + local out, v, just, width, conv, prec, pad + + out := "" + format ? repeat { + (out ||:= tab(upto('%'))) | (out ||:= tab(0) & break) + v := get(args) + move(1) + just := right + width := conv := prec := pad := &null + ="-" & just := left + width := tab(many(&digits)) + (\width)[1] == "0" & pad := "0" + ="." & prec := tab(many(&digits)) + conv := move(1) + + ##write("just: ",image(just),", width: ", width, ", prec: ", + ## prec, ", conv: ", conv) + case conv of { + "d": { + v := string(integer(v)) + } + "s": { + v := string(v[1:(\prec+1)|0]) + } + "x": v := hexstr(v) + "o": v := octstr(v) + "i": v := image(v) + "r": v := fixnum(v,prec) + "e": v := eformatstr(v, prec, width) + default: { + push(args, v) + v := conv + } + } + if \width & *v < width then { + v := just(v, width, pad) + } + out ||:= v + } + + return out +end + +procedure hexstr(n) + local h, neg + static BigNeg, hexdigs, hexfix + + initial { + BigNeg := -2147483647-1 + hexdigs := "0123456789abcdef" + hexfix := "89abcdef" + } + + n := integer(n) + if n = BigNeg then + return "80000000" + h := "" + if n < 0 then { + n := -(BigNeg - n) + neg := 1 + } + repeat { + h := hexdigs[n%16+1]||h + if (n /:= 16) = 0 then + break + } + if \neg then { + h := right(h,8,"0") + h[1] := hexfix[h[1]+1] + } + return h +end +procedure octstr(n) + local h, neg + static BigNeg, octdigs, octfix + + initial { + BigNeg := -2147483647-1 + octdigs := "01234567" + octfix := "23" + } + + n := integer(n) + if n = BigNeg then + return "20000000000" + h := "" + if n < 0 then { + n := -(BigNeg - n) + neg := 1 + } + repeat { + h := octdigs[n%8+1]||h + if (n /:= 8) = 0 then + break + } + if \neg then { + h := right(h,11,"0") + h[1] := octfix[h[1]+1] + } + return h +end + +procedure fixnum(x, prec) + local int, frac, f1, f2, p10 + + /prec := 6 + x := real(x) | return image(x) + int := integer(x) | return image(x) + frac := image(x - int) + if find("e", frac) then { + frac ?:= { + f1 := tab(upto('.')) & + move(1) & + f2 := tab(upto('e')) & + move(1) & + p10 := -integer(tab(0)) & + repl("0",p10-1) || f1 || f2 + } + } + else + frac ?:= (tab(upto('.')) & move(1) & tab(0)) + frac := adjustfracprec(frac, prec) + int +:= if int >= 0 then frac[2] else -frac[2] + return int || "." || frac[1] +end + + +# e-format: [-]m.dddddde(+|-)xx +# +# Differs from C and Fortran E formats primarily in the +# details, among them: +# +# - Single-digit exponents are not padded out to two digits. +# +# - The precision (number of digits after the decimal point) +# is reduced if needed to make the number fit in the available +# width, if possible. The precision is never reduced-to-fit +# below 1 digit after the decimal point. +# +procedure eformatstr(x, prec, width) + local signpart, wholepart, fracpart, exppart + local choppart, shiftcount, toowide + local rslt, s + + /prec := 6 + /width := prec + 7 + + # Separate string representation of x into parts + # + s := string(real(x)) | return image(x) + s ? { + signpart := (=("-" | "+") | "") + wholepart := 1(tab(many(&digits)), any('.eE')) | return image(x) + fracpart := ((=".", tab(many(&digits))) | "") + exppart := integer((=("e"|"E"), tab(0)) | 0) + } + + # When the integer part has more than 1 digit, shift it + # right into fractional part and scale the exponent + # + if *wholepart > 1 then { + exppart +:= *wholepart -1 + fracpart := wholepart[2:0] || fracpart + wholepart := wholepart[1] + } + + # If the the number is unnormalized, shift the fraction + # left into the whole part and scale the exponent + # + if wholepart == "0" then { + if shiftcount := upto('123456789', fracpart) then { + exppart -:= shiftcount + wholepart := fracpart[shiftcount] + fracpart := fracpart[shiftcount+1:0] + } + } + + # Adjust the fractional part to the requested precision. + # If the carry causes the whole part to overflow from + # 9 to 10 then renormalize. + # + fracpart := adjustfracprec(fracpart, prec) + wholepart +:= fracpart[2] + fracpart := fracpart[1] + if *wholepart > 1 then { + wholepart := wholepart[1] + exppart +:= 1 + } + + # Assemble the final result. + # - Leading "+" dropped in mantissa + # - Leading "+" obligatory in exponent + # - Decimal "." included iff fractional part is non-empty + # + wholepart := (signpart == "-", "-") || wholepart + exppart := (exppart > 0, "+") || exppart + fracpart := (*fracpart > 0, ".") || fracpart + rslt := wholepart || fracpart || "e" || exppart + + # Return the result. + # -- If too short, pad on the left with blanks (not zeros!). + # -- If too long try to shrink the precision + # -- If shrinking is not possible return a field of stars. + # + return (*rslt <= width, right(rslt, width)) | + (*rslt - width < prec, eformatstr(x, prec + width - *rslt, width)) | + repl("*", width) +end + +# Zero-extend or round the fractional part to 'prec' digits. +# +# Returns a list: +# +# [ fracpart, carry ] +# +# where the fracpart has been adjusted to the requested +# precision, and the carry (result of possible rounding) +# is to be added into the whole number. +# +procedure adjustfracprec(fracpart, prec) + + local choppart, carryout + + # Zero-extend if needed. + if *fracpart < prec then return [left(fracpart, prec, "0"), 0] + + # When the fractional part has more digits than the requested + # precision, chop off the extras and round. + # + carryout := 0 + if *fracpart > prec then { + choppart := fracpart[prec+1:0] + fracpart := fracpart[1+:prec] + + # If rounding up is needed... + # + if choppart[1] >>= "5" then { + + # When the fractional part is .999s or the precision is 0, + # then round up overflows into the whole part. + # + if (prec = 0) | (string(cset(fracpart)) == "9") then { + fracpart := left("0", prec, "0") + carryout := 1 + } + # In the usual case, round up simply increments the + # fractional part. (We put back any trailing + # zeros that got lost.) + else { + fracpart := left(integer(fracpart)+1, prec, "0") + } + } + } + return [fracpart, carryout] +end |