(* Copyright (C) 1992, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* File: ReelExpr.m3                                           *)
(* Last modified on Mon Feb 24 14:41:46 PST 1992 by kalsow     *)
(*      modified on Tue Apr 10 22:38:17 1990 by muller         *)

UNSAFE MODULE ReelExpr; (* contains some "safe" LOOPHOLES *)

IMPORT Expr, ExprRep, String, Emit, Error, Temp, Type;
IMPORT MBuf, Fmt, Scan, Reel, LReel, EReel, IntegerExpr, Word;

CONST
  NOVALUE = -1.223456789d+31;

TYPE
  P = Expr.T OBJECT
        pre  : Precision;
        str  : String.T;
	val  : LONGREAL;
        uid  : INTEGER;
        next : P; (* hash chain *)
      OVERRIDES
        typeOf       := ExprRep.NoType;
        check        := ExprRep.NoCheck;
        compile      := Compile;
        evaluate     := ExprRep.Self;
        fprint       := FPrinter;
        write        := Writer;
        isEqual      := EqCheck;
        getBounds    := ExprRep.NoBounds;
        isWritable   := ExprRep.IsNever;
        isDesignator := ExprRep.IsNever;
	isZeroes     := IsZeroes;
	note_write   := ExprRep.NotWritable;
	genLiteral   := GenLiteral;
      END;

CONST
  PoolType = ARRAY Precision OF TEXT { "_REAL ", "_LONGREAL ", "_EXTENDED " };
  Tag      = ARRAY Precision OF TEXT { "_real",  "_longreal",  "_extended" };

CONST
  LitStream = ARRAY Precision OF Emit.Stream { Emit.Stream.RealLiterals,
               Emit.Stream.LongrealLiterals,  Emit.Stream.ExtendedLiterals };

TYPE
  HashTable = ARRAY [0..63] OF P;

VAR nextID  := ARRAY Precision OF INTEGER { 0, .. };
VAR hash: ARRAY Precision OF HashTable;  (* initialized to NIL *)

PROCEDURE Reset () =
  VAR p: P;
  BEGIN
    (* reset the uid counters & empty the hash table *)
    FOR i := FIRST (nextID) TO LAST (nextID) DO nextID[i] := 0 END;
    FOR i := FIRST (hash) TO LAST (hash) DO
      FOR j := FIRST (hash[i]) TO LAST (hash[i]) DO
        p := hash[i,j];
        WHILE (p # NIL) DO p.uid := -1;  p := p.next END;
        hash[i,j] := NIL;
      END;
    END;
  END Reset;

PROCEDURE New (value: String.T;  pre: Precision): Expr.T =
  BEGIN
    RETURN Create (NOVALUE, value, pre);
  END New;

PROCEDURE Create (value: LONGREAL;  str: String.T;  pre: Precision): Expr.T =
  VAR p: P;
  BEGIN
    p := NEW (P);
    ExprRep.Init (p);
    p.pre     := pre;
    p.str     := str;
    p.val     := value;
    p.uid     := -1;
    p.next    := NIL;
    p.checked := TRUE;
    CASE pre OF
    | Precision.Short    => p.type := Reel.T;
    | Precision.Long     => p.type := LReel.T;
    | Precision.Extended => p.type := EReel.T;
    END;
    RETURN p;
  END Create;

PROCEDURE GetUID (p: P) =
  VAR newUID, x: INTEGER;  y: P;  save: Emit.Stream;
  BEGIN
    IF (p.uid >= 0) THEN RETURN END;

    (* compute a hash value for this node *)
    IF (p.str # NIL) THEN
      x := String.Hash (p.str);
    ELSE
      WITH z = LOOPHOLE (p.val, ARRAY [0..1] OF INTEGER) DO
        x := Word.Xor (z[0], z[1]);
      END;
    END;
    x := x MOD NUMBER (HashTable);

    y := hash [p.pre][x];
    WHILE (y # NIL) DO
      IF ((p.str # NIL) AND (p.str = y.str))
        OR ((p.str = NIL) AND (p.val = y.val)) THEN
        (* we found a match *)
        p.uid := y.uid;
        RETURN;
      END;
      y := y.next;
    END;

    (* no match => create a new literal *)

    (* first, put this guy into the hash table & allocate his uid *)
    p.next := hash[p.pre][x];  hash[p.pre][x] := p;
    newUID := nextID[p.pre];   INC (nextID[p.pre]);
    p.uid  := newUID;

    (* switch the to the correct output stream *)
    save := Emit.Switch (LitStream[p.pre]);

    (* make sure the literal pool is started *)
    IF (newUID = 0) THEN
      Emit.RegisterShutDown (LitStream[p.pre], FinishLiteralPool);
      Emit.Op ("_PRIVATE ");
      Emit.Op (PoolType[p.pre]);
      Emit.Op (Tag[p.pre]);
      Emit.Op ("[] = {\n");
    ELSE
      Emit.Op (",\n");
      IF (newUID MOD 10) = 0 THEN Emit.OpI ("/* @ */\n", newUID) END;
    END;

    (* generate the initialized literal *)
    IF (p.str # NIL)
      THEN Emit.OpS ("  @", p.str);
      ELSE Emit.OpR ("  @", p.val);
    END;

    EVAL Emit.Switch (save);
  END GetUID;

PROCEDURE FinishLiteralPool () =
  BEGIN
    Emit.Op ("\n};\n");
  END FinishLiteralPool;

PROCEDURE EqCheck (a: P;  e: Expr.T): BOOLEAN =
  BEGIN
    TYPECASE e OF
    | NULL => RETURN FALSE;
    | P(b) => RETURN (a.pre = b.pre)
                     AND (((a.str = b.str) AND (a.str # NIL)) OR 
                          ((a.val = b.val) AND (a.val # NOVALUE)));
    ELSE      RETURN FALSE;
    END;
  END EqCheck;

PROCEDURE Compile (p: P): Temp.T =
  BEGIN
    GetUID (p);
    RETURN Temp.FromExpr (p);
  END Compile;

PROCEDURE Writer (p: P;  <*UNUSED*> t1, t2: Temp.T) =
  BEGIN
    <*ASSERT p.uid >= 0 *>
    Emit.Op  (Tag[p.pre]);
    Emit.OpI ("[@]", p.uid);
  END Writer;

PROCEDURE Compare (a, b: Expr.T;  VAR sign: INTEGER): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    IF    (pa.val < pb.val) THEN sign := -1
    ELSIF (pa.val > pb.val) THEN sign := +1
    ELSE                         sign :=  0
    END;
    RETURN TRUE;
  END Compare;

PROCEDURE Add (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    c := Create (pa.val + pb.val, NIL, pa.pre);
    RETURN TRUE;
  END Add;

PROCEDURE Subtract (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    c := Create (pa.val - pb.val, NIL, pa.pre);
    RETURN TRUE;
  END Subtract;

PROCEDURE Multiply (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    c := Create (pa.val * pb.val, NIL, pa.pre);
    RETURN TRUE;
  END Multiply;

PROCEDURE Divide (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    IF (pb.val = 0.0d+0) THEN
      Error.Msg ("attempt to divide by zero");
      RETURN FALSE;
    END;
    c := Create (pa.val / pb.val, NIL, pa.pre);
    RETURN TRUE;
  END Divide;

PROCEDURE Mod (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;  div: INTEGER;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    IF (pb.val = 0.0d+0) THEN
      Error.Msg ("attempt to MOD by zero");
      RETURN FALSE;
    END;
    div := FLOOR (pa.val / pb.val);
    c := Create (pa.val - pb.val * FLOAT (div, LONGREAL), NIL, pa.pre);
    RETURN TRUE;
  END Mod;

PROCEDURE Min (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    IF (pa.val < pb.val)
      THEN c := a;
      ELSE c := b;
    END;
    RETURN TRUE;
  END Min;

PROCEDURE Max (a, b: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR pa, pb: P;
  BEGIN
    IF NOT SplitPair (a, b, pa, pb) THEN RETURN FALSE END;
    IF (pa.val > pb.val)
      THEN c := a;
      ELSE c := b;
    END;
    RETURN TRUE;
  END Max;

PROCEDURE Negate (a: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR p: P;
  BEGIN
    IF NOT Split (a, p) THEN RETURN FALSE END;
    c := Create (-p.val, NIL, p.pre);
    RETURN TRUE;
  END Negate;

PROCEDURE Abs (a: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR  p: P;
  BEGIN
    IF NOT Split (a, p) THEN RETURN FALSE END;
    IF (p.val < 0.0d+0)
      THEN c := Create (-p.val, NIL, p.pre);
      ELSE c := a;
    END;
    RETURN TRUE;
  END Abs;

PROCEDURE Floor (a: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR p: P;  i: INTEGER;
  BEGIN
    IF NOT Split (a, p) THEN RETURN FALSE END;
    i := TRUNC (p.val);
    IF (p.val < 0.0d+0) AND (FLOAT (i, LONGREAL) # p.val) THEN DEC (i) END;
    c := IntegerExpr.New (i);
    RETURN TRUE;
  END Floor;

PROCEDURE Ceiling (a: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR p: P;  i: INTEGER;
  BEGIN
    IF NOT Split (a, p) THEN RETURN FALSE END;
    i := TRUNC (p.val);
    IF (p.val > 0.0d+0) AND (FLOAT (i, LONGREAL) # p.val) THEN INC (i) END;
    c := IntegerExpr.New (i);
    RETURN TRUE;
  END Ceiling;

PROCEDURE Trunc (a: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR p: P;
  BEGIN
    IF NOT Split (a, p) THEN RETURN FALSE END;
    c := IntegerExpr.New (TRUNC (p.val));
    RETURN TRUE;
  END Trunc;

PROCEDURE Round (a: Expr.T;  VAR c: Expr.T): BOOLEAN =
  VAR p: P;  x: LONGREAL;
  BEGIN
    IF NOT Split (a, p) THEN RETURN FALSE END;
    x := p.val;
    IF (x >= 0.0d+0) 
      THEN c := IntegerExpr.New (TRUNC (x + 0.5d+0));
      ELSE c := IntegerExpr.New (TRUNC (x - 0.5d+0));
    END;
    RETURN TRUE;
  END Round;

PROCEDURE Float (a: Expr.T;  t: Type.T;  VAR c: Expr.T): BOOLEAN =
  VAR p: P;  i: INTEGER;  x: LONGREAL;
  BEGIN
    t := Type.Base (t);
    IF Split (a, p) THEN
      x := p.val;
      IF    (p.type = t)  THEN  c := a;
      ELSIF (t = Reel.T)  THEN  c := Create (p.val, p.str, Precision.Short);
      ELSIF (t = LReel.T) THEN  c := Create (p.val, p.str, Precision.Long);
      ELSIF (t = EReel.T) THEN  c := Create (p.val, p.str, Precision.Extended);
      ELSE  RETURN FALSE;
      END;
    ELSIF IntegerExpr.Split (a, i) THEN
      x := FLOAT (i, LONGREAL);
      IF    (t = Reel.T)  THEN  c := Create (x, NIL, Precision.Short);
      ELSIF (t = LReel.T) THEN  c := Create (x, NIL, Precision.Long);
      ELSIF (t = EReel.T) THEN  c := Create (x, NIL, Precision.Extended);
      ELSE  RETURN FALSE;
      END;
    ELSE
      RETURN FALSE;
    END;
    RETURN TRUE;
  END Float;

PROCEDURE SplitPair (a, b: Expr.T;  VAR pa, pb: P): BOOLEAN =
  BEGIN
    IF NOT Split (a, pa) THEN RETURN FALSE END;
    IF NOT Split (b, pb) THEN RETURN FALSE END;
    IF (pa.pre # pb.pre) THEN RETURN FALSE END;
    RETURN TRUE;
  END SplitPair;

PROCEDURE Split (e: Expr.T;  VAR pp: P): BOOLEAN =
  BEGIN
    TYPECASE e OF
    | NULL => RETURN FALSE;
    | P(p) => IF (p.val = NOVALUE) THEN p.val := StrToValue (p.str) END;
              pp := p;  RETURN TRUE;
    ELSE      RETURN FALSE;
    END;
  END Split;

PROCEDURE StrToValue (s: String.T): LONGREAL =
  BEGIN
    IF (s = NIL) OR (String.Length (s) = 0) THEN RETURN 0.0d+0 END;
    (* must actually do the conversion *)
    TRY
      RETURN (Scan.LongReal (String.ToText (s)));
    EXCEPT
    | Scan.BadFormat => Error.Str (s, "unable to convert literal to binary!?");
    END;
    RETURN 0.0d+0;
  END StrToValue;

(****
PROCEDURE ValueToStr (r: LONGREAL): String.T =
  BEGIN
    RETURN String.Add (Fmt.LongReal (r, 15, Fmt.Style.Sci));
  END ValueToStr;
****)

PROCEDURE FPrinter (p: P;  <*UNUSED*> map: Type.FPMap;  wr: MBuf.T) =
  CONST mark = ARRAY Precision OF CHAR { 'S', 'L', 'E' };
  BEGIN
    MBuf.PutChar (wr, mark [p.pre]);
    MBuf.PutChar (wr, '#');
    IF (p.str # NIL)
      THEN String.Put (wr, p.str);
      ELSE MBuf.PutText (wr, Fmt.LongReal (p.val, 13, Fmt.Style.Sci));
    END;
    MBuf.PutChar (wr, '#');
  END FPrinter;

PROCEDURE IsZeroes (p: P): BOOLEAN =
  BEGIN
    IF (p.val = NOVALUE) THEN p.val := StrToValue (p.str) END;
    RETURN (p.val = 0.0d+0);
  END IsZeroes;

PROCEDURE GenLiteral (p: P) =
  BEGIN
    IF (p.str # NIL)
      THEN Emit.OpS ("@", p.str);
      ELSE Emit.OpR ("@", p.val);
    END;
  END GenLiteral;

BEGIN
END ReelExpr.