base_format.sa


Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
 
---------------------------> Sather 1.1 source file <--------------------------
-- base_format.sa: Formatting a string a la printf
-- Author: Benedict A. Gomes <gomes@icsi.berkeley.edu>
-- Author: Holger Klawitter <holger@icsi.berkeley.edu>
-- Copyright (C) 1996, International Computer Science Institute
-- $Id: base_format.sa,v 1.13 1996/07/25 19:18:18 gomes Exp $
-- For documentation see:
--    format.sa and
--    http://www.icsi.berkeley.edu/~holger/Sather/format.html
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.


abstract class $FLT > FLT, FLTD

abstract class $FLT > FLT, FLTD -- Classes formattable with the floating point algorithm. -- FMT_NUMBERS typecases on them. is flt: FLT; end; -- abstract class $FLT

class BASE_FORMAT

class BASE_FORMAT -- Formats for the Basic types is include FMT_NUMBERS; fmt_flt( f: $FLT, fmt: STR ): STR -- Formatter for FLT and FLTD. is width,prec,exp,anchor,flags,last: INT; dotch: CHAR; case fmt_parse ( fmt, false, out width, out prec, out exp, out anchor, out dotch, out flags, out last ) when parse_success then -- ok when parse_syntax_error then return #FMT_ERROR( "Unable to analyse format string '" + fmt.tail(fmt.length-last) +"'." ).str; when parse_illegal_anchor then return #FMT_ERROR( "Illegal anchor in '"+fmt+"'." ).str; when parse_dot_and_anchor then return #FMT_ERROR("Decimal char and `^' cannot be used together.").str; else return #FMT_ERROR( "Panic! Unknown error in '"+fmt+"'." ).str; end; if flags.band(use_exponent)=0 then if flags.band(use_width)=0 then return flt_free( f, dotch, flags.band(force_sign)/=0 ); else return flt_fixed ( f, width, prec, dotch, flags.band(use_width)/=0, flags.band(force_sign)/=0, flags.band(use_precision)/=0 ); end else if flags.band(use_width)=0 then return flt_free_exp ( f, dotch, flags.band(force_sign)/=0, flags.band(force_exp_sign)/=0, exp ); else return flt_fixed_exp ( f, width, prec, flags.band(force_sign)/=0, flags.band(use_precision)/=0, dotch, flags.band(force_exp_sign)/=0, exp ); end end; end; -- fmt_flt fmt_int( i: INT, fmt: STR ): STR -- Formatter for INT. is width,prec,exp,anchor,flags,last,base: INT; dotch: CHAR; base := 10; if fmt.length>=3 then case fmt.substring(0,3) when "hex" then base := 16; fmt := fmt.substring(3); when "bin" then base := 2; fmt := fmt.substring(3); when "oct" then base := 8; fmt := fmt.substring(3); else end end; case fmt_parse ( fmt, true, out width, out prec, out exp, out anchor, out dotch, out flags, out last ) when parse_success then -- ok when parse_syntax_error then return #FMT_ERROR( "Unable to analyse format string '" + fmt.tail(fmt.length-last) +"'." ).str; when parse_illegal_anchor then return #FMT_ERROR( "Duplicate anchor in '"+fmt+"'." ).str; when parse_dot_and_anchor then return #FMT_ERROR("Decimal char and `^' cannot be used together.").str; else return #FMT_ERROR( "Panic! Unknown error in '"+fmt+"'." ).str; end; if flags.band(use_exponent)/=0 then return #FMT_ERROR( "Exponential integers are not supported yet." ).str; end; if flags.band(use_precision)/=0 then -- => flags.band(use_anchor)=0 ! return int_precision( i, width, prec, base, flags.band(force_sign)/=0 ); else return int_normal( i, width, anchor, base, flags.band(force_sign)/=0, flags.band(use_anchor)/=0 ); end; end; -- fmt_int fmt_char( c: CHAR, fmt: STR ): STR -- Formatter for CHAR. is return fmt_str(c.str,fmt) end; fmt_bool( b: BOOL, fmt: STR ): STR -- Formatter for BOOL. is return fmt_str(b.str,fmt) end; -- fmt_bool fmt_str( s: STR, fmt: STR ): STR -- Formatter for STR. is width, anchor, last: INT; filler: CHAR; use_anchor: BOOL; case fmt_parse_easy( fmt, out filler, out width, out anchor, out use_anchor, out last ) when parse_success then -- ok when parse_syntax_error then return #FMT_ERROR( "Unable to analyse format string '" + fmt.tail(fmt.length-last) +"'." ).str; when parse_illegal_anchor then return #FMT_ERROR( "Illegal anchor in '"+fmt+"'." ).str; when parse_filler_expected then return #FMT_ERROR( "Filler expected in '"+fmt+"'." ).str; else return #FMT_ERROR( "Panic! Unknown error in '"+fmt+"'." ).str; end; if ~ use_anchor then anchor := width end; sl, len: INT; len := s.length; if len>width then return s end; sl := anchor - 1 - len/2; if sl>0 then s := s.right(width.min(sl+len),filler) end; return s.left(width,filler) end; -- fmt_str
-- Parsing the format string -- Possible flag bits: const use_width: INT := 1; -- There was a hash sign in the width part. const use_precision: INT := 2; -- There was a dot in the format string. const use_exponent: INT := 4; -- There was an 'e' in the format string. const force_sign: INT := 8; -- The format expression started with '+'. const force_exp_sign: INT := 16; -- Exponent 'e' was followed by a '+'. const use_anchor: INT := 32; -- There was an anchor in the string. -- Returnstati of num_parse: const parse_success, -- Parse successfully completed. parse_syntax_error, -- Format string could not be parsed completely. parse_illegal_anchor, -- Illegal or duplicate anchor. parse_not_yet, -- Not yet implemented feature requested. parse_dot_and_anchor, -- Dot and anchor dicovered. parse_filler_expected; -- there was no filler behind an `F'. -- Main parser for FLT und INT style number formats: -- Returns `parse_success' when the parse was completely successful. fmt_parse ( s:STR, allow_anchor: BOOL, out width: INT, -- Least number of digits for integer part. out prec: INT, -- Number of digits for fractional part. out exp_width: INT, -- Least number of digits for exponent. out anchor: INT, -- Position of anchor in width field. out dotch: CHAR, -- Character being used as decimal char. out flags: INT, -- Special bit-flags. out pos: INT -- Next character position to read (for error msgs). ): INT is -- Setting parameters to default values. width := 0; prec := 0; exp_width := 0; anchor := 0; dotch := '.'; flags := 0; pos := 0; sz ::= s.length; if sz=0 then return parse_success end; next ::= s[0]; -- Openig anchor if next = '^' then if allow_anchor then width := 1; anchor := 1; flags := flags.bor(use_anchor); allow_anchor := false else return parse_illegal_anchor end; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; -- Sign case next when '-' then width := width + 1; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; when '+' then width := width + 1; flags := flags.bor(force_sign); pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; else -- do nothing end; -- Width padding loop if next = '^' then if allow_anchor then width := width + 1; anchor := width; flags := flags.bor(use_anchor); allow_anchor := false else return parse_illegal_anchor end; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; while!( pos<sz and next = '#' ); flags := flags.bor(use_width); width := width + 1; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; -- Precision if next = '.' or next = ',' then if flags.band(use_anchor)/=0 then return parse_dot_and_anchor end; dotch := next; allow_anchor := false; flags := flags.bor(use_precision); pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; -- Precision padding. loop while!( next = '#' ); prec := prec + 1; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; end; -- Closing anchor if next = '^' then if allow_anchor then width := width + 1; anchor := width; flags := flags.bor(use_anchor); allow_anchor := false else return parse_illegal_anchor end; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; -- Exponent if next = 'e' then flags := flags.bor(use_exponent); pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; -- Exponent sign if next = '+' then exp_width := 1; flags := flags.bor(force_exp_sign); pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; elsif next = '-' then exp_width := 1; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; -- Exponent padding loop while!( next = '#' ); exp_width := exp_width + 1; pos:=pos+1; if pos>=sz then return parse_success end; next := s[pos]; end; end; return parse_syntax_error; end; -- fmt_parse -- Main parser for STR, CHAR and BOOL -- Disallowing dots and signs. -- Returns `parse_success' when the parse was completely successful. fmt_parse_easy( s: STR, out filler: CHAR, -- fill character out width: INT, -- total number of padding chars out anchor: INT, -- position of anchor out use_anchor: BOOL, -- false if not existent out pos: INT -- position at end of parse (for errors) ): INT is width := 0; anchor := 0; pos := 0; use_anchor := false; filler := ' '; sz: INT := s.length; if sz = 0 then return parse_success end; next: CHAR := s[0]; if next = 'F' then if 1>=sz then return parse_filler_expected end; filler := s[1]; pos := 2; if 2>=sz then return parse_success end; next := s[2]; end; -- before anchor loop until!( next /= '#' ); width := width + 1; pos := pos + 1; if pos>=sz then return parse_success end; next := s[pos]; end; if next /= '^' then return parse_syntax_error end; width := width + 1; use_anchor := true; anchor := width; pos := pos + 1; if pos>=sz then return parse_success end; next := s[pos]; -- after anchor loop until!( next /= '#' ); width := width + 1; pos := pos + 1; if pos>=sz then return parse_success end; next := s[pos]; end; if next = '^' then return parse_illegal_anchor end; return parse_syntax_error; end; -- fmt_parse_easy end; -- class BASE_FMT

class FMT_NUMBERS

class FMT_NUMBERS -- Formatting numbers. is -- FORMATTING INT: int_normal( int: INT, width: INT, anchor: INT, base: INT, force_sign: BOOL, use_anchor: BOOL ): STR pre base.is_bet(2,16) and width>=0 and anchor>=0 -- Prints an INT reflecting anchor information. is res: STR; l,sl: INT; if ~ use_anchor then anchor := width; end; if int>=0 and force_sign then res := "+"+int.str_in(#FSTR,0,base,' ').str; else res := int.str_in(#FSTR,0,base,' ').str; end; l := res.length; if l>=width then return res end; -- already big enough to fit sl := anchor - 1 - l/2; if sl>0 then res := res.right(width.min(sl+l)) end; -- add spaces left return res.left(width); end; -- int_normal int_precision( int: INT, width: INT, prec: INT, base: INT, force_sign: BOOL ): STR -- Prints an INT reflecting precision information. is if int>0 and force_sign then -- A little bit of fiddling the `+' to the right place. return ("+"+int.str_in(#FSTR,0,base,' ').str).right(width) + " ".repeat(prec+1); else return int.str_in(#FSTR,width,base,' ').str + " ".repeat(prec+1); end; end; -- int_precision -- FORMATTING FLT: -- Implementation of G. Steele, J. White: -- How to Print Floating Point Numbers Accurately -- Proceedings of the ACM SIGPLAN'90 in White Plains, New York -- Simplifying assumptions: -- b is 2, B is 10, INTs have 32 bits. flt_free( f: $FLT, dotch: CHAR, force_sign: BOOL ): STR -- Prints the number in standard representation as precise as -- possible. Uses at least width digits for the integer part of -- the number and prints a '+' sign if force_sign = true and the -- number positive. is init; s: BOOL; e,maxexp,p: INT; m: INTI; res: STR; flt_data(f, out s, out e, out m, out maxexp, out p ); if e=maxexp then if m/=zero then res := "NaN"; elsif s then res := "-Inf"; elsif force_sign then res := "+Inf"; else res := "Inf"; end; return res end; if force_sign then res := "+"; elsif s then res := "-" else res := "" end; k: INT; first: BOOL := true; loop next ::= dragon4!( e,m,p,co_nrm,0,inout k ); while!( first or (next /= -1 or k>=-1) ); if first and k<0 then res := res + "0" + dotch + "0".repeat(-k-1); end; first := false; res := res + digit(next); if k=0 then res := res + dotch end; end; if k=-1 then res := res + '0' end; -- one zero behind the dot. return res; end; -- flt_free flt_fixed( f: $FLT, w: INT, d: INT, dotch: CHAR, force_zero: BOOL, force_sign: BOOL, use_dot: BOOL ): STR -- Prints 'f' with 'd' digits precision and uses 'w' digits for -- the integer part. -- 'use_dot' => forcing a dot to be printed -- 'force_sign' => prints a sign even when f is positive -- 'force_zero' => numbers smaller than 1 get a leading zero. pre d >= 0 and w >= 0 is init; s: BOOL; e,maxexp,p: INT; m: INTI; res: STR; total: INT := w + d; if use_dot then total := total + 1 end; flt_data( f, out s, out e, out m, out maxexp, out p ); if e=maxexp then if m/=zero then res := "NaN"; elsif s then res := "-Inf"; elsif force_sign then res := "+Inf"; else res := "Inf"; end; return res.right(total); end; if s then res := "-" elsif force_sign then res := "+" else res := "" end; k: INT; first: BOOL := true; loop next ::= dragon4!( e,m,p,co_abs,-d,inout k ); if first then if k<w then -- There is something to padd or no integer part at all if k>=0 then res := res.right(w-k-1); else -- no integer part if w>0 then if force_zero then res := (res+'0').right(w) else res := res.right(w); end; end; if use_dot then res := res + dotch end; -- leading fractional zeros. res := res + "0".repeat( d.min(-k-1) ); end; end; first := false; end; -- if first while!( k >= -d ); res := res + digit(next); if k=0 and use_dot then res := res + dotch end end; return res; end; -- flt_fixed flt_free_exp( f: $FLT, dotch: CHAR, force_sign: BOOL, force_exp_sign: BOOL, exp_width: INT ): STR -- Prints `f' in exponential notation until exhaustion of the precision. -- Uses at least `exp_width' digits for the exponent. Prints a sign -- always if `force_sign' is true. Prints always a sign for exponent, -- if `force_exp_sign' is true. is expt,k,j: INT; res: STR; init; s: BOOL; e,maxexp,p: INT; m: INTI; flt_data(f, out s, out e, out m, out maxexp, out p ); if e=maxexp then if m/=zero then res := "NaN"; elsif s then res := "-Inf"; elsif force_sign then res := "+Inf"; else res := "Inf"; end; return res end; if force_sign then res := "+"; elsif s then res := "-" else res := "" end; first: BOOL := true; loop next ::= dragon4!( e,m,p,co_nrm,0,inout k ); if first then expt := k; res := res + digit(next) + dotch; first := false; else until!( next < 0 ); res := res + digit(next); end; end; if k=expt-1 then res := res + '0'; end; return res + make_exp( expt, force_exp_sign, exp_width ) end; -- flt_free_exp flt_fixed_exp( f: $FLT, w: INT, d: INT, force_sign: BOOL, use_dot: BOOL, dotch: CHAR, force_exp_sign: BOOL, exp_width: INT ): STR -- Combines flt_free_exp and flt_fixed. is init; s: BOOL; e,maxexp,p: INT; m: INTI; res: STR; total: INT := w + d + exp_width; if use_dot then total := total + 1; end; flt_data( f, out s, out e, out m, out maxexp, out p ); if e=maxexp then if m/=zero then res := "NaN"; elsif s then res := "-Inf"; elsif force_sign then res := "+Inf"; else res := "Inf"; end; return res.right(total); end; if s then res := "-" elsif force_sign then res := "+" else res := "" end; k,expt: INT; first: BOOL := true; loop (d+1).times!; next ::= dragon4!( e, m, p, co_rel, -d, inout k ); if first then expt := k; res := res.right(w-1) + digit(next); if use_dot then res := res + dotch; end; first := false; else res := res + digit(next) end; end; return res + make_exp( expt, force_exp_sign, exp_width ); end; -- flt_fixed_exp private make_exp( expt: INT, force_exp_sign: BOOL, exp_width: INT ): STR -- Prints the exponent `expt'. is res: STR; if expt < 0 then res := "-"; expt := -expt elsif force_exp_sign then res := "+"; else res := ""; end; digits,x: INT; digits := 0; -- number of digits in exponent x := 1; -- 10^edigits loop x := x * 10; digits := digits + 1; until!( x > expt ) end; if digits <= exp_width then res := "e" + res.left(exp_width-digits,'0') else res := "e" + res end; loop x := x / 10; res := res + digit(expt/x); expt := expt % x; while!(x>1); end; return res; end; -- make_exp
-- Internal routines and constants private const co_rel, co_nrm, co_abs; -- Rounding modes for formatter. private shared zero,one,two,nine,ten: INTI; -- Predefined infinite integers. private const INTsize := INT::asize; -- Number of bits in an INT. private init -- Initalizing shareds only once. is if ~void(one) then return end; -- zero might be void, so use one. zero := #INTI(0); one := #INTI(1); two := #INTI(2); nine := #INTI(9); ten := #INTI(10); end; -- init private lshift( i: INTI, n: INT ): INTI -- Shift infinte integer 'i' 'n' binary positions to the left. -- Poor implementation as bitshift operations of INTI are not implemented. pre n>=0 is return i * #INTI(n).exp2 end; private flt_data( f: $FLT, out s: BOOL, out e: INT, out m: INTI, out maxexp: INT, out p: INT ) -- Gets the data out of the floating point number and does the unbiasing. is typecase f when FLT then mm: INT; f.get_representation(out s,out e, out mm); maxexp := 255; p := 23; if e=0 then -- subnormal e := e - 126; elsif e<255 then -- normal e := e - 127; mm := mm.bor( 0x00800000 ); end; m := #INTI(mm); assert e>=-126 and (e=255 or e<=127) when FLTD then mhi,mlo: INT; maxexp := 2047; p := 52; f.get_representation( out s, out e, out mlo, out mhi ); if e=0 then -- subnormal e := e - 1022; elsif e/=2047 then -- normal e := e - 1023; mhi := mhi.bor( 0x00100000 ); end; if mlo >= 0 then m := lshift( #INTI(mhi), 32 ) + #INTI( mlo ); else -- Treat negative replo as unsigned. -- Note that mhi will stay positive. m := lshift( #INTI(mhi.lshift(1)+1), 31 ) + #INTI( 0x7fffffff.band(mlo) ) end; assert e>=-1022 and (e<=1023 or e=2047) end; end; -- flt_data private dragon4!(once e: INT,once f: INTI,once p: INT, once cutoff: INT,once cutplace: INT, inout k: INT): INT -- Core iterator of the FLT printout algorithms, gets the -- exponent and the mantissa of the number and emits a stream -- of digits representing the number to print. The out -- parameter 'k' specifies the current position of the digit. pre ~ (cutoff = co_rel) or cutplace <= 0 is U: INT; roundup: BOOL := false; if f = zero then k := 0; yield 0 else -- Getting fractional representation of the floating point number. R ::= lshift( f, 0.max(e-p) ); -- Denominator S ::= lshift( one, 0.max(-(e-p)) ); -- Nominator -- Error threshold for precision exhaustion. Mm ::= lshift( one, 0.max(e-p) ); Mp ::= Mm; -- FIXUP if f = lshift( one, p-1 ) then -- Taking unequal gaps between numbers into account. Mp := Mp * two; R := R * two; S := S * two; end; k := 0; loop -- Subnormal numbers while!( R < (S+nine) / ten ); k := k - 1; R := R * ten; Mm := Mm * ten; Mp := Mp * ten; end; loop loop while!( two * R + Mp >= two * S ); S := S * ten; k := k + 1; end; -- Adjustments to Mm and Mp for formatting requirements case cutoff when co_nrm then cutplace := k; when co_abs then cutoffadj( inout Mm, inout Mp, inout roundup, S, k, cutplace ); when co_rel then cutplace := k + cutplace; cutoffadj( inout Mm, inout Mp, inout roundup, S, k, cutplace ); else raise "dragon4 error" end; while!( two * R + Mp >= two * S ); end; -- END FIXUP low,high: BOOL; loop k := k - 1; U := (( R * ten ) / S).int; R := ( R * ten ) % S; Mm := Mm * ten; Mp := Mp * ten; low := two * R < Mm; if roundup then high := two * R >= ( two * S ) - Mp else high := two * R > ( two * S ) - Mp; end; while!( ~low and ~high and k /= cutplace ); yield U end; if low and ~high then yield U elsif high and ~low then yield U+1 else if two * R <= S then yield U; else yield U+1; end end end; -- if loop k := k - 1; yield -1; end; end; -- dragon4 private cutoffadj( inout Mm: INTI, inout Mp: INTI, inout roundup: BOOL, S: INTI, k: INT, cutplace: INT ) -- Recomputing the accuracy thresholds to ensure correct rounding -- even when not comptuing to maximal floating point accuracy. is a: INT; -- (negated) Number of digits to print. a := cutplace-k; y ::= S; if a >= 0 then loop j ::= 1.upto!(a); y := y * ten; end; else loop j ::= 1.upto!(-a); y := (y+nine) / ten; end; end; Mm := y.max( Mm ); Mp := y.max( Mp ); if Mp = y then roundup := true end; end; -- cutoffadj digit( i: INT ): CHAR -- Print the digit represented be 'i'. Negative digits are considered -- as 'insignificant' digits and printed as zeros. pre i<16 is if i<0 then return '0' end; return "0123456789ABCDEF"[i]; end; -- aschar end; -- class FMT_NUMBERS