-- (C) Copyright International Business Machines Corporation 16 November, 
-- 1990.  All Rights Reserved. 
--  
-- See the file USERAGREEMENT distributed with this software for full 
-- terms and conditions of use. 
-- File: cgator.pp
-- Author: William Silverman
-- SCCS Info: @(#)cgator.pp	1.2 12/6/90

-- This process accepts a string which represents an integer, optionally
-- followed by a proper fraction, optionally followed by an exponent -
-- and converts it into a real.  An initial sign is allowed in the integer.

#include "typemark.h"
#include "codegen.h"

cgator: using (cgInternal, interpform)

process (Q: atorQ)
  
declare
  args: ator;

  scopy: charstring;
  c: char;

  sign: real;
  low: integer; mid: integer; high: integer;
  fractional: boolean;
  exponent: integer;

  zcode: integer;
  zero: integer; one: integer; ten: integer;
  ip2: integer;
  pof2: integer;
  rpof2: real;

  excess: integer;

begin
  receive args from Q;

  block begin

    scopy := args.s;
    low <- I(0); mid <- I(0); high <- I(0);
    fractional <- B('false');
    exponent <- I(0);

    zcode <- I(convert of C('0'));
    zero <- I(0); one <- I(1); ten <- I(10);

-- the following values are chosen for machines with 32 bit integers
-- and 64 bit (double) reals with maximum real bounded by 2^1023.
-- Adjustment may be necessary for machines which difer substantially
-- from these assumptions.

    ip2 <- I(24);
    pof2 <- I(16777216);			-- 2^24

  -- handle first character of real-literal - may be sign or digit
    remove c from AREF(xc,scopy,ZERO);			--scopy[0];
    sign <- R(convert of one);
    select c
      where (C('+'))
        remove c from AREF(xc,scopy,ZERO);		--scopy[0];
      where (C('-'))
        sign <- R(-sign);
        remove c from AREF(xc,scopy,ZERO);		--scopy[0];
      otherwise
    end select;

    excess <- I(0);
    block declare
      ic: integer;
    begin

      while B('true') repeat
	select c

	  where(C('.'))
	    if fractional then
	      exit formaterror;
	    end if;
	    fractional <- B('true');		-- start fraction part

	  where(C('e'))
	    block declare
	      esign: integer;
	      ecum: integer;
	    begin

	   -- handle first character of exponent - may be sign or digit
              remove c from AREF(xc,scopy,ZERO);	--scopy[0];
	      esign <- I(1);
	      select c
		where (C('+'))
		  remove c from AREF(xc,scopy,ZERO);	--scopy[0];
		where (C('-'))
		  esign <- I(-esign);
		  remove c from AREF(xc,scopy,ZERO);	--scopy[0];
		otherwise
	      end select;

	      ecum <- I(0);
	      while B('true') repeat
		ic <- I(I(convert of c) - zcode);
		if B(B(ic < zero) or B(ic >= ten)) then
		  exit formaterror;
		end if; 
		ecum <- I(I(ten*ecum) + ic);
		if B(I(size of scopy) = zero) then
		  exponent <- I(exponent + I(esign*ecum));
		  exit scaling;
		end if;
		remove c from AREF(xc,scopy,ZERO);	--scopy[0];
	      end while;
	      
	    on (Depletion)
	      exit formaterr;

	    end block;

	    
	  otherwise				-- digit
	    ic <- I(I(convert of c) - zcode);
	    if B(B(zero <= ic) and B(ic <= ten)) then
	      if B(excess = zero)  then
		low <- I(I(ten*low) + ic);
		if B(low >= pof2) then		-- start extended cumulation
		  mid <- I(low / pof2);
		  low <- I(low mod pof2);
		  excess <- I(1);
		end if;
	      else				-- continue extended cumulation
		if B(excess = I(3)) then
		  exponent <- I(exponent + one);
		else
		  low <- I(I(ten*low) + ic);
		  ic <- I(low / pof2);
		  low <- I(low mod pof2);
		  mid <- I(I(ten*mid) + ic);
		  if B(excess = one) then
		    if B(mid >= pof2) then
		      high <- I(mid / pof2);
		      mid <- I(mid mod pof2);
		      excess <- I(2);
		    end if;
		  else
		    ic <- I(mid / pof2);
		    mid <- I(mid mod pof2);
		    high <- I(I(ten*high) + ic);
		    if B(high >= pof2) then
		      high <- I(high/I(10));
		      exponent <- I(exponent + one);
		      excess <- I(3);
		    end if;
		  end if;
		end if;
	      end if;
	      if fractional then			-- in fraction-part
		exponent <- I(exponent - one);
	      end if;
	    else					-- not a digit
	      if B(c = C('E')) then
		insert C('e') into scopy at ZERO;	-- 'E' equivalent 'e'
	      else
		exit formaterror;
	      end if;
	    end if;

	end select;

	if B(I(size of scopy) = zero) then
	  exit scaling;
	end if;
	remove c from AREF(xc,scopy,ZERO);		--scopy[0];

      end while;

    on (NotFound)
      exit formaterror;

    on exit (scaling)
    end block;

    rpof2 <- R(convert of pof2);

  -- scale by resultant exponent of ten
    if B(exponent = zero) then
      args.r <- R(R(rpof2*R(R(rpof2*R(convert of high)) +
			    R(convert of mid))
		   ) +
		  R(convert of low)
		 );
    else

      block declare

	expof2: integer;

	two: integer;
	hip10: integer;
	mip10: integer;
	lop10: integer;
	exp2ofp10: integer;
	pof2s2: integer;
	value: real;
	rp2scale: real;
	rp16scale: real;
	rhigh: real;
	rmid: real;
	rlow: real;
	rtwo: real;
	rhip10: real;
	rmip10: real;
	rlop10: real;
	kluge: real;

      begin

	two <- I(2);
	select excess
	  where(I(0))
	    expof2 <- I(-I(two*ip2));
	    high <- low;
	    low <- I(0);
	  where(I(1))
	    expof2 <- I(-ip2);
	    high <- mid;
	    mid <- low;
	    low <- I(0);
	  otherwise
	    expof2 <- I(0);
	end select;

	if B(high = zero) then
	  args.r <- R(convert of zero);
	else
	  if B(exponent > zero) then
--	    hip10 <- I(ten*I(pof2/I(16)));
	    hip10 <- I(10485760);
	    mip10 <- I(0);
	    lop10 <- I(0);
	    exp2ofp10 <- I(4);
	  else
	    exponent <- I(-exponent);
--	    hip10 <- I(I(I(8)*pof2)/ten);
--	    lop10 <- I(pof2*I(I(I(8)*pof2) - I(ten*hip10)));
--	    mip10 <- I(lop10/ten);
--	    lop10 <- I(I(pof2*I(lop10 - I(ten*mip10)))/ten);
	    hip10 <- I(13421772);
	    mip10 <- I(13421772);
	    lop10 <- I(13421772);
	    exp2ofp10 <- I(-3);
	  end if;

	  rtwo <- R(convert of two);
	  pof2s2 <- I(pof2/two);
	  while B(exponent <> zero) repeat
	
	    rhip10 <- R(convert of hip10);
	    rmip10 <- R(convert of mip10);
	    rlop10 <- R(convert of lop10);

	    if B(I(exponent mod two) <> zero) then -- multiply by power of 10
	      while B(high < pof2s2) repeat	-- first normalize term
		low <- I(two*low);
		mid <- I(I(two*mid) + I(low/pof2));
		high <- I(I(two*high) + I(mid/pof2));
		mid <- I(mid mod pof2);
		low <- I(low mod pof2);
		expof2 <- I(expof2 - one);
	      end while;
	      rhigh <- R(convert of high);
	      rmid <- R(convert of mid);
	      rlow <- R(convert of low);
	      low <- I(convert of R(R(R(rhip10*rlow) +
				      R(R(rmip10*rmid) +
				        R(rlop10*rhigh)
				       )
				     )/rpof2
				    )
		      );
	      value <- R(R(R(R(rhip10*rmid) +
			     R(rmip10*rhigh)
			    ) +
			   R(convert of low)
			  )/rpof2
			);
	      mid <- I(convert of value);
	      low <- I(convert of R(R(value - R(convert of mid))*rpof2));
	      value <- R(R(R(rhip10*rhigh) + R(convert of mid))/rpof2);
	      high <- I(convert of value);
	      mid <- I(convert of R(R(value - R(convert of high))*rpof2));
	      expof2 <- I(expof2 + exp2ofp10);
	    end if;

	    exponent <- I(exponent/two);
	    if B(exponent <> zero) then		-- square power of 10
	      kluge := rmip10;
	      lop10 <- I(convert of R(R(R(rmip10*kluge) +
				        R(rtwo*R(rhip10*rlop10))
				       )/rpof2
				     )
			);
	      value <- R(R(R(rtwo*R(rhip10*rmip10)) +
			   R(convert of lop10)

			  )/rpof2
			);
	      mip10 <- I(convert of value);
	      lop10 <- I(convert of R(R(value - R(convert of mip10))*rpof2));
	      kluge := rhip10;
	      value <- R(R(R(kluge*rhip10) + R(convert of mip10))/rpof2);
	      hip10 <- I(convert of value);
	      mip10 <- I(convert of R(R(value - R(convert of hip10))*rpof2));
	      exp2ofp10 <- I(two*exp2ofp10);
	      if B(hip10 < pof2s2) then
		lop10 <- I(two*lop10);
		mip10 <- I(I(two*mip10) + I(lop10/pof2));
		hip10 <- I(I(two*hip10) + I(mip10/pof2));
		mip10 <- I(mip10 mod pof2);
		lop10 <- I(lop10 mod pof2);
		exp2ofp10 <- I(exp2ofp10 - one);
	      end if;
	    end if;
	  end while;
	  rp2scale <- R(convert of two);
	  rp16scale <- R(convert of I(16));
	  if B(expof2 < zero) then
	    expof2 <- I(-expof2);
	    rp16scale <- R(R(convert of one)/rp16scale);
	    rp2scale <-  R(R(convert of one)/rp2scale);
	  end if;
	  select I(expof2 mod I(4))
	    where(I(0))
	      rp2scale <- R(convert of one);
	    where(I(2))
	      kluge := rp2scale;
	      rp2scale <- R(kluge*rp2scale);
	    where(I(3))
	      kluge := rp2scale;
	      rp2scale <- R(R(kluge*rp2scale)*rp2scale);
	    otherwise
	  end select;
	  expof2 <- I(expof2/I(4));
	  value <- R(sign * R(R(rpof2*R(R(rpof2*R(convert of high)) +
					R(convert of mid)
				       )
			       ) +
			      R(convert of low)
			     )
		    );
	  if B(expof2 = zero) then
	    args.r <- R(rp2scale*value);
	  else
	    while B(expof2 <> one) repeat
	      if B(I(expof2 mod two) = one) then
		rp2scale <- R(rp2scale*rp16scale);
	      end if;
	      expof2 <- I(expof2/two);
	      kluge := rp16scale;
	      rp16scale <- R(kluge*rp16scale);
	    end while;
	    args.r <- R(R(value*rp16scale)*rp2scale);
	  end if;

	end if;

      on (Depletion)
	exit formaterror;		-- might be due to storage exhaustion!?
      end block;

    end if;

    return args;

  on exit (formaterror)
--  return args exception badFormat;
    args.r <- R(convert of I(0));	-- faut de mieux
    return args;
  end block;

end process
