------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1996 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- base_format.sa: Formatting a string a la printf
-- Author: Benedict A. Gomes <gomes@icsi.berkeley.edu>
-- Author: Holger Klawitter <holger@icsi.berkeley.edu>
-- For documentation see:
--    format.sa and
--    http://www.icsi.berkeley.edu/~holger/Sather/format.html

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
-- 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
-- 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
