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

(* File: ESet.m3                                               *)
(* Last modified on Wed May  6 08:13:48 PDT 1992 by kalsow     *)

MODULE ESet;

IMPORT M3, Value, Token, Scope, Type, Scanner;
IMPORT String, Error, MBuf, Word, Emit;
FROM Scanner IMPORT Match, Match1, MatchID, GetToken, cur;

REVEAL
  M3.ExSet = M3.Node BRANDED "ESet.T" OBJECT
    any      : BOOLEAN := FALSE;
    elts     : Elt     := NIL;
    env      : Scope.T := NIL;
    next     : T       := NIL;
    resolved : BOOLEAN := FALSE;
    stop     : BOOLEAN := FALSE;
    hash     : INTEGER := 0;
    uid      : INTEGER := 0;
    age      : INTEGER := 0;
  END;

TYPE
  Elt = UNTRACED BRANDED "ESet.Elt" REF RECORD
    name   : String.QID;
    except : Value.T;
    next   : Elt;
  END;

VAR DefaultSet := NEW (T);

CONST RaisesAnyID  = 1;
CONST RaisesNoneID = 2;
CONST FirstUserID  = 3;

TYPE HashTable = REF ARRAY OF T;

VAR nextID  : INTEGER := FirstUserID;
VAR thisAge : INTEGER := 1;
VAR hashTbl : HashTable;

PROCEDURE Reset () =
  BEGIN
    INC (thisAge);
  END Reset;

PROCEDURE ParseRaises (READONLY fail: Token.Set): T =
  TYPE  TK = Token.T;
  VAR t := NEW (T);  elt: Elt;
  BEGIN
    t.origin := Scanner.offset;
    Match (TK.tRAISES, fail, Token.Set {TK.tLBRACE, TK.tRBRACE});
    IF cur.token = TK.tANY THEN
      GetToken (); (* ANY *)
      t.any  := TRUE;
    ELSE
      t.env := Scope.Top ();
      Match (TK.tLBRACE, fail, Token.Set {TK.tRBRACE});
      WHILE (cur.token = TK.tIDENT) DO
        elt := NEW (Elt, next := t.elts);  t.elts := elt;
        elt.name.module := NIL;
        elt.name.item   := MatchID (fail, Token.Set {TK.tRBRACE, TK.tCOMMA});
        elt.except      := NIL;
        IF (cur.token = TK.tDOT) THEN
          GetToken (); (* . *)
          elt.name.module := elt.name.item;
          elt.name.item   := MatchID (fail, Token.Set {TK.tRBRACE});
        END;
        IF (cur.token # TK.tCOMMA) THEN EXIT END;
        GetToken (); (* , *)
      END;
      Match1 (TK.tRBRACE, fail);
    END;
    RETURN t;
  END ParseRaises;

PROCEDURE ParseFails  (READONLY fail: Token.Set;  existing: T): T =
  TYPE  TK = Token.T;
  VAR t: T := existing;  elt: Elt;
  BEGIN
    IF (t = NIL) THEN  t := NEW (T);  t.origin := Scanner.offset;  END;
    Match (TK.tFATAL, fail, Token.Set {TK.tENDPRAGMA});
    LOOP
      IF (cur.token = TK.tANY) THEN
        GetToken (); (* ANY *)
        t.any := TRUE;
      ELSIF (cur.token = TK.tIDENT) THEN
        IF (t.env = NIL) THEN t.env := Scope.Top () END;
        elt := NEW (Elt, next := t.elts);  t.elts := elt;
        elt.name.module := NIL;
        elt.name.item   := MatchID (fail, Token.Set{TK.tENDPRAGMA, TK.tCOMMA});
        elt.except      := NIL;
        IF (cur.token = TK.tDOT) THEN
          GetToken (); (* . *)
          elt.name.module := elt.name.item;
          elt.name.item   := MatchID (fail,Token.Set{TK.tENDPRAGMA,TK.tCOMMA});
        END;
      ELSE
        EXIT;
      END;
      IF (cur.token # TK.tCOMMA) THEN EXIT END;
      GetToken (); (* , *)
    END;
    Match1 (TK.tENDPRAGMA, fail);
    RETURN t;
  END ParseFails;

PROCEDURE Hash (t: T): INTEGER =
  VAR hash := 691;  e: Elt;  o: Value.T;  oname: String.T;
  BEGIN
    IF (t # NIL) THEN
      IF (t.hash = 0) THEN
        e := t.elts;
        WHILE (e # NIL) DO
          o := e.except;
          IF (o # NIL) THEN
            oname := Value.CName (o);
            hash := Word.Plus (Word.Times (hash, 89), String.Hash (oname));
          END;
          e := e.next;
        END;
        t.hash := hash;
      END;
    END;
    RETURN hash;
  END Hash;

PROCEDURE UID (t: T): INTEGER =
  BEGIN
    IF (t = NIL) THEN RETURN RaisesNoneID END;
    IF (t.uid = 0) THEN
      IF (t.any) THEN
        t.uid := RaisesAnyID;
      ELSIF (t.elts = NIL) THEN
        t.uid := RaisesNoneID;
      ELSE
        t.uid := LookUp(t).uid;
      END;
    END;
    RETURN t.uid;
  END UID;

PROCEDURE Declare (t: T) =
  VAR e: Elt;
  BEGIN
    IF (UID (t) < FirstUserID) THEN RETURN END;
    t := LookUp (t);
    IF (t.age >= thisAge) THEN RETURN END;
    e := t.elts;
    WHILE (e # NIL) DO Value.Declare0 (e.except); e := e.next; END;
    Emit.OpI ("_PRIVATE _EXCEPTION _raises_@ [] = {\n\001", t.uid);
    e := t.elts;
    WHILE (e # NIL) DO
      IF (e.except # NIL) THEN Emit.OpN ("& @, ", e.except)  END;
      e := e.next;
    END;
    Emit.Op ("(_EXCEPTION) _NIL\002};\n");
    t.age := thisAge;
  END Declare;

PROCEDURE LookUp (t: T): T =
  VAR hx := Hash (t);   i: INTEGER;   x: T;
  BEGIN
    IF (hashTbl = NIL) THEN hashTbl := NEW (HashTable, 100) END;
    i := hx MOD NUMBER (hashTbl^);
    LOOP
      x := hashTbl[i];
      IF (x = NIL) THEN (* a new entry! *)
        hashTbl[i] := t;
        IF (t.uid < FirstUserID) THEN
          t.uid := nextID;  INC (nextID);
          IF (2 * nextID > NUMBER (hashTbl^)) THEN ExpandHashTable () END;
        END;
        RETURN t;
      END;
      IF (x = t) OR IsEqual (x, t) THEN RETURN x END;
      INC (i);
      IF (i > LAST (hashTbl^)) THEN i := 0 END;
    END;
  END LookUp;

PROCEDURE ExpandHashTable () =
  VAR old := hashTbl;  t: T;
  BEGIN
    hashTbl := NEW (HashTable, 2 * NUMBER (old^));
    FOR i := FIRST (old^) TO LAST (old^) DO
      t := old[i];
      IF (t # NIL) THEN EVAL LookUp (t) END;
    END;
  END ExpandHashTable;

PROCEDURE RaisesAny (t: T): BOOLEAN =
  BEGIN
    RETURN (t # NIL) AND (t.any);
  END RaisesAny;

PROCEDURE RaisesNone (t: T): BOOLEAN =
  BEGIN
    RETURN (t = NIL) OR (t.elts = NIL);
  END RaisesNone;

PROCEDURE NewAny (): T =
  BEGIN
    RETURN NEW (T, any := TRUE);
  END NewAny;

PROCEDURE NewEmpty (): T =
  BEGIN
    RETURN NEW (T);
  END NewEmpty;

PROCEDURE Add (t: T;  READONLY name: String.QID;   ex: Value.T) =
  BEGIN
    ex := Value.Base (ex);
    t.elts := NEW (Elt, next := t.elts, name := name, except := ex);
  END Add;

PROCEDURE IsEqual (a, b: T): BOOLEAN =
  BEGIN
    IF (a = NIL) THEN a := DefaultSet END;
    IF (b = NIL) THEN b := DefaultSet END;
    IF (a.any # b.any) THEN RETURN FALSE END;
    Resolve (a);
    Resolve (b);
    RETURN EltSubset (a.elts, b.elts) AND EltSubset (b.elts, a.elts);
  END IsEqual;

PROCEDURE IsSubset (a, b: T): BOOLEAN =
(* TRUE iff a is a subset of b *)
  BEGIN
    IF (a = NIL) THEN a := DefaultSet END;
    IF (b = NIL) THEN b := DefaultSet END;
    IF (b.any) THEN RETURN TRUE END;
    IF (a.any) THEN RETURN FALSE END;
    Resolve (a);
    Resolve (b);
    RETURN EltSubset (a.elts, b.elts);
  END IsSubset;

PROCEDURE TypeCheck (t: T) =
  BEGIN
    IF (t # NIL) THEN Resolve (t) END;
  END TypeCheck;

PROCEDURE Push (VAR cs: M3.CheckState;  ok_to_raise, no_error: T;
                                                               stop: BOOLEAN) =
  VAR t: T;
  BEGIN
    IF (stop) THEN
      (* this is a nested procedure => truncate the "ok_to_raise" list *)
      t := NEW (T, stop := TRUE);
      t.next := cs.ok_to_raise;
      cs.ok_to_raise := t;
    END;

    IF (ok_to_raise # NIL) THEN
      <*ASSERT ok_to_raise.next = NIL *>
      ok_to_raise.next := cs.ok_to_raise;
      cs.ok_to_raise := ok_to_raise;
    END;
    IF (no_error # NIL) THEN
      <*ASSERT no_error.next = NIL *>
      no_error.next := cs.no_error;
      cs.no_error := no_error;
    END;
  END Push;

PROCEDURE Pop (VAR cs: M3.CheckState;  ok_to_raise, no_error: T;
                                                               stop: BOOLEAN) =
  VAR t: T;
  BEGIN
    IF (ok_to_raise # NIL) THEN
      <*ASSERT ok_to_raise = cs.ok_to_raise *>
      cs.ok_to_raise := cs.ok_to_raise.next;
      ok_to_raise.next := NIL;
    END;
    IF (no_error # NIL) THEN
      <*ASSERT no_error = cs.no_error *>
      cs.no_error := cs.no_error.next;
      no_error.next := NIL;
    END;
    IF (stop) THEN
      t := cs.ok_to_raise;
      cs.ok_to_raise := t.next;
      <* ASSERT t.stop *>
    END;
  END Pop;

PROCEDURE NoteExceptions (VAR cs: M3.CheckState;  t: T) =
  VAR u: T;  e: Elt;
  BEGIN
    IF (t = NIL) THEN RETURN END;

    IF (t.any) THEN
      u := cs.ok_to_raise;
      WHILE (u # NIL) AND (NOT u.stop) DO
        IF (u.any) THEN RETURN END;
        u := u.next;
      END;
      cs.raises_others := TRUE;
      u := cs.no_error;
      WHILE (u # NIL) DO
        IF (u.any) THEN RETURN END;
        u := u.next;
      END;
      Error.Warn (1, "potentially unhandled exception (<ANY>)");
      RETURN;
    END;

    e := t.elts;
    WHILE (e # NIL) DO
      NoteException (cs, e.except);
      e := e.next;
    END;
  END NoteExceptions;

PROCEDURE NoteException (VAR cs: M3.CheckState;  v: Value.T) =
  VAR t: T;  e: Elt;  ss: String.Stack;  name: String.T;
  BEGIN
    IF (v = NIL) THEN (* there's already been an error *) RETURN END;
    v := Value.Base (v);

    t := cs.ok_to_raise;
    WHILE (t # NIL) AND (NOT t.stop) DO
      IF (t.any) THEN RETURN END;
      e := t.elts;
      WHILE (e # NIL) DO
        IF (e.except = v) THEN RETURN END;
        e := e.next;
      END;
      t := t.next;
    END;

    cs.raises_others := TRUE;

    t := cs.no_error;
    WHILE (t # NIL) DO
      IF (t.any) THEN RETURN END;
      e := t.elts;
      WHILE (e # NIL) DO
        IF (e.except = v) THEN RETURN END;
        e := e.next;
      END;
      t := t.next;
    END;

    ss.top := 0;
    Scope.NameToPrefix (v, ss, dots := TRUE);
    name := ss.stk[0];
    FOR i := 1 TO ss.top-1 DO name := String.Concat (name, ss.stk[i]) END;
    Error.WarnStr (1, name, "potentially unhandled exception");
  END NoteException;

PROCEDURE Fingerprint (t: T;  map: Type.FPMap;  wr: MBuf.T) =
  VAR e: Elt;
  BEGIN
    IF (t = NIL) THEN t := DefaultSet END;
    IF (NOT t.any) THEN
      MBuf.PutText (wr, " RAISES(");
      e := t.elts;
      WHILE (e # NIL) DO
        Value.Fingerprint (e.except, map, wr);
        e := e.next;
      END;
      MBuf.PutText (wr, ")");
    END;
  END Fingerprint;

(*-------------------------------------------------------------- internal ---*)

PROCEDURE Resolve (t: T) =
  (* look up each of the named exceptions *)
  VAR e: Elt;  o: Value.T;  save: INTEGER;
  BEGIN
    IF (t.resolved) THEN RETURN END;
    save := Scanner.offset;
    Scanner.offset := t.origin;
    e := t.elts;
    WHILE (e # NIL) DO
      o := Scope.LookUpQID (t.env, e.name);
      IF (o = NIL) THEN
        Error.QID (e.name, "undefined");
      ELSIF (Value.ClassOf (o) # Value.Class.Exception) THEN
        Error.QID (e.name, "is not an exception");
      ELSE
        e.except := Value.Base (o);
      END;
      e := e.next;
    END;
    Scanner.offset := save;
    t.elts := SortElts (t.elts);
    t.resolved := TRUE;
  END Resolve;

(************* assume the lists are sorted ***************************)
PROCEDURE EltSubset (a, b: Elt): BOOLEAN =
  BEGIN
    WHILE (a # NIL) DO
      LOOP
        IF (b = NIL) THEN RETURN FALSE END;
        IF (b.except = a.except) THEN EXIT END;
        b := b.next;
      END;
      (* this element of a is in b *)
      a := a.next;
    END;
    RETURN TRUE;
  END EltSubset;

(***** assumes that the lists are not sorted *************************
PROCEDURE EltSubset (a, b: Elt): BOOLEAN =
  VAR ar, br: Elt;
  BEGIN
    ar := a;
    WHILE (ar # NIL) DO
      br := b;
      LOOP
        IF (br = NIL) THEN RETURN FALSE END;
        IF (br.except = ar.except) THEN EXIT END;
        br := br.next;
      END;
      (* this element of a is in b *)
      ar := ar.next;
    END;
    RETURN TRUE;
  END EltSubset;
*********************************************************************)

PROCEDURE SortElts (e: Elt): Elt =
  VAR i: INTEGER;  x: Elt;  tmp: ARRAY [0..9] OF Elt;
  BEGIN
    IF (e = NIL) THEN RETURN NIL END;
    IF (e.next = NIL) THEN RETURN e END;

    (* unpack the list *)
    i := 0;  x := e;
    WHILE (x # NIL) DO
      IF (i <= LAST (tmp)) THEN tmp[i] := x END;
      x := x.next;
      INC (i);
    END;

    IF (i <= NUMBER (tmp)) THEN
      RETURN DoSort (tmp, i);
    ELSE
      WITH ref = NEW (REF ARRAY OF Elt, i) DO
        i := 0;  x := e;
        WHILE (x # NIL) DO  ref[i] := x;  x := x.next; INC (i)  END;
        RETURN DoSort (ref^, i);
      END;
    END;
  END SortElts;

PROCEDURE DoSort (VAR e: ARRAY OF Elt;  n: INTEGER): Elt =
  VAR x: Elt;  j: INTEGER;
  BEGIN
    (* insertion sort the list *)
    FOR i := 1 TO n-1 DO
      x := e[i];
      j := i-1;
      WHILE (j >= 0) AND EltLT (x, e[j]) DO  e[j+1] := e[j]; DEC (j)  END;
      e[j+1] := x;
    END;

    (* build the new linked list *)
    FOR i := 0 TO n-2 DO  e[i].next := e[i+1]  END;
    e[n-1].next := NIL;

    RETURN e[0];
  END DoSort;

PROCEDURE EltLT (a, b: Elt): BOOLEAN =
  VAR aName, bName: String.Stack;
  BEGIN
    IF (a = b)               THEN RETURN FALSE END;
    IF (a = NIL)             THEN RETURN TRUE  END;
    IF (b = NIL)             THEN RETURN FALSE END;
    IF (a.except = b.except) THEN RETURN FALSE END;
    IF (a.except = NIL)      THEN RETURN TRUE  END;
    IF (b.except = NIL)      THEN RETURN FALSE END;
    aName.top := 0;  bName.top := 0;
    Scope.NameToPrefix (a.except, aName);
    Scope.NameToPrefix (b.except, bName);
    FOR i := 0 TO MIN (aName.top, bName.top) - 1 DO
      WITH ax = aName.stk[i], bx = bName.stk[i] DO
        IF (ax # bx) THEN RETURN (String.Hash (ax) < String.Hash (bx)) END;
      END;
    END;
    RETURN (aName.top < bName.top);
  END EltLT;

BEGIN
END ESet.