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

(* File: Scope.m3                                              *)
(* Last modified on Thu Apr 26 23:06:13 1990 by muller         *)
(*      modified on Wed Feb 14 10:03:56 1990 by kalsow         *)

UNSAFE MODULE Scope;

IMPORT M3, String, Value, Type, Module, Error, Procedure, OpaqueType;
IMPORT ObjectType, RefType, Emit, Scanner, Delay, NamedType, ValueRep;
IMPORT Variable, Temp;

CONST
  InitialSize = 4;

REVEAL
  M3.Scope = UNTRACED BRANDED "Scope.T" REF RECORD
    next       : T;
    parent     : T;
    viaFrame   : BOOLEAN;           (* the C scope for this one is not
                                       within the C scope of parent *)
    frameID    : INTEGER := 0;      (* if # 0, there is a frame visible
                                       in this scope *)
    localFrame : BOOLEAN := TRUE;   (* true if this visible frame is
                                       local to the procedure that
                                       encloses this frame; false if
                                       this frame is one of the arguments
                                       of this procedure *)
    hasFrame   : BOOLEAN := FALSE;  (* iff this scope introduces a frame *)
    name       : String.T;
    children   : INTEGER;
    maxSize    : INTEGER;
    curSize    : INTEGER;
    hashSize   : INTEGER;
    contents   : ValueList;
    hash       : ValueList;
    open       : BOOLEAN;
    bound      : BOOLEAN;
  END;

VAR
  frameID   := 1;
  top       : T;
  allScopes : T;
  emptyStr  : String.T;
  Underscore, UnderscoreUnderscore, Parent, 
        StarLParen, LParen, RParen: String.T;

PROCEDURE PushNew (open: BOOLEAN;  name: String.T; viaFrame := FALSE): T =
  VAR t: T;
  BEGIN
    t := NEW (T);
    t.next     := allScopes;  allScopes := t;
    t.parent   := top;
    IF name = NIL AND top # NIL THEN
      INC (top.children);
      t.name := String.AddInt (top.children);
    ELSE
      t.name := name;
    END;
    t.maxSize  := InitialSize;
    t.curSize  := 0;
    t.hashSize := 0;
    t.hash     := NIL;
    t.open     := open;
    t.viaFrame := viaFrame;
    t.contents := NEW (ValueList, t.maxSize);
    top := t;
    RETURN t;
  END PushNew;

PROCEDURE PopNew () =
  BEGIN
    top := top.parent;
  END PopNew;

PROCEDURE New1 (obj: Value.T): T =
  VAR t: T;
  BEGIN
    t := NEW (T);
    t.next     := allScopes;  allScopes := t;
    t.parent   := top;
    IF top # NIL THEN
      INC (top.children);
      t.name := String.AddInt (top.children);
    ELSE
      t.name := emptyStr;
    END;
    t.maxSize  := 1;
    t.curSize  := 1;
    t.hashSize := 0;
    t.hash     := NIL;
    t.open     := TRUE;
    t.contents := NEW (ValueList, 1);
    t.contents[0] := obj;
    IF (obj.scope = NIL) THEN obj.scope := t END;
    top := t;
    RETURN t;
  END New1;
    
PROCEDURE Push (t: T) =
  BEGIN
    <* ASSERT t # NIL *>
    top := t;
  END Push;

PROCEDURE Pop () =
  BEGIN
    top := top.parent;
  END Pop;

PROCEDURE Top (): T =
  BEGIN
    RETURN top;
  END Top;

PROCEDURE OuterMost (t: T) : BOOLEAN =
  BEGIN
    RETURN t.parent = Initial;
  END OuterMost;

PROCEDURE LookUp (name: String.T): Value.T =
  BEGIN
    RETURN LookUpInScope (top, name);
  END LookUp;

PROCEDURE LookUpInScope (t: T;  name: String.T): Value.T =
  VAR hash: INTEGER; o: Value.T;  viaFrame := FALSE;
  BEGIN
    LOOP
      <* ASSERT t.hash # NIL *>
      IF (t.hashSize > 0) THEN
        hash := (LOOPHOLE (name, INTEGER) DIV 4) MOD t.hashSize;
        LOOP
          o := t.hash [hash];
          IF (o = NIL) THEN EXIT END;
          IF (o.name = name) THEN
            o.used := TRUE;
            o.usedAtTop := o.usedAtTop OR Module.depth = 1 OR
                           (NOT Module.IsInterface() AND Module.depth = 2);
            o.inFrame := o.inFrame OR
			 (viaFrame AND t.parent # Initial AND
                          Value.ClassOf (o) = Value.Class.Var);
            IF o.inFrame AND t.frameID = 0 THEN
              t.frameID := frameID;
              t.hasFrame := TRUE;
              t.localFrame := TRUE;
              INC (frameID);
            END;
            RETURN o;
          END;
          INC (hash);
          IF (hash >= t.hashSize) THEN hash := 0 END;
        END;
      END;
      IF (NOT t.open) THEN RETURN NIL END;
      viaFrame := viaFrame OR t.viaFrame;
      t := t.parent;
      IF (t = NIL) THEN RETURN NIL END;
    END;
  END LookUpInScope;

PROCEDURE LookUpQID (READONLY q: String.QID): Value.T =
  BEGIN
    IF (q.module = NIL) THEN
      RETURN LookUpInScope (top, q.item);
    ELSE
      TYPECASE LookUpInScope (top, q.module) OF
      | NULL         => RETURN NIL;
      | Module.T (m) => RETURN LookUpInScope (Module.ExportScope (m), q.item);
      ELSE              RETURN NIL;
      END;
    END;
  END LookUpQID;

PROCEDURE Insert (o: Value.T) =
  VAR t: T;  z: ValueList;
  BEGIN
    t := top;
    <* ASSERT t # NIL AND t.hashSize = 0 *>

    (* check for a reserved word *)
    IF (t # Initial)
      AND (Initial.hash # NIL)
      AND (LookUpInScope (Initial, o.name) # NIL) THEN
      Error.Str (o.name, "Reserved identifier redefined");
    END;

    IF (t.curSize >= t.maxSize) THEN
      (* double the number of slots *)
      t.maxSize := 2 * t.maxSize;
      z := NEW (ValueList, t.maxSize);
      FOR i := 0 TO t.curSize - 1 DO  z[i] := t.contents[i]  END;
      t.contents := z;
    END;

    IF (o.scope = NIL) THEN o.scope := t END;
    t.contents [t.curSize] := o;
    INC (t.curSize);
  END Insert;

PROCEDURE ForEach (t: T;  visit: Visitor) =
  BEGIN
    <* ASSERT t # NIL *>
    FOR i := 0 TO t.curSize - 1 DO  visit (t.contents[i])  END;
  END ForEach;

PROCEDURE ToList (t: T;  VAR objs: ValueList;  VAR cnt: INTEGER) =
  BEGIN
    IF (t = NIL)
      THEN  objs := NIL;         cnt := 0
      ELSE  objs := t.contents;  cnt := t.curSize;
    END;
  END ToList;

PROCEDURE Seal (t: T) =
  BEGIN
    IF (t = NIL) THEN RETURN END;
    CleanUp (t);
  END Seal;

PROCEDURE Bind (t: T;  finishDelays: BOOLEAN) =
  BEGIN
    IF (t = NIL) THEN RETURN END;
    IF (t.bound) THEN RETURN END;
    t.bound := TRUE;
    CleanUp (t);
    FOR i := 0 TO t.curSize - 1 DO
      IF (finishDelays) AND (Delay.pending) THEN Delay.FinishUp () END;
      Value.Bind (t.contents[i]);
    END;
    IF (finishDelays) AND (Delay.pending) THEN Delay.FinishUp () END;
    FOR i := 0 TO t.curSize - 1 DO
      TYPECASE t.contents[i] OF
      | NULL            => (* ignore *)
      | Procedure.T (p) => Procedure.BindBody (p);
      ELSE                 (* ignore *)
      END;
    END;
  END Bind;

PROCEDURE TypeCheck (t: T;  finishDelays: BOOLEAN) =
  BEGIN
    IF (t = NIL) THEN RETURN END;
    FOR i := 0 TO t.curSize - 1 DO
      IF (finishDelays) AND (Delay.pending) THEN Delay.FinishUp () END;
      Value.TypeCheck (t.contents[i]);
    END;
    IF (finishDelays) AND (Delay.pending) THEN Delay.FinishUp () END;
    FOR i := 0 TO t.curSize - 1 DO
      TYPECASE t.contents[i] OF
      | NULL            => (* ignore *)
      | Procedure.T (p) => Procedure.CheckBody (p);
      ELSE                 (* ignore *)
      END;
    END;
  END TypeCheck;

PROCEDURE GenFrameTypes () =
  VAR t := allScopes;
  BEGIN
    (* If we have (scope with frame)
                  { scopes without frame }
                  (scope with frame)
       then we mark the scopes in the middle has having a frame with the same
       id as the parent one. *)
    WHILE t # NIL DO
      IF t.frameID = 0 THEN
        VAR a := t.parent;
            viaFrame := t.viaFrame;
          BEGIN
            WHILE (a # NIL) AND (a.frameID = 0) DO
              viaFrame := viaFrame OR a.viaFrame;
              a := a.parent; END;
            IF a # NIL THEN
              t.localFrame := NOT viaFrame;
              t.frameID := a.frameID; END;
          END;
      END;
      t := t.next;
    END;

    t := allScopes;
    WHILE t # NIL DO
      IF t.frameID # 0 AND t.parent # NIL AND t.parent.frameID # t.frameID THEN
        Emit.OpI ("typedef struct frame@ {\001\n", t.frameID);
        IF t.parent.frameID # 0 THEN
          Emit.OpI ("struct frame@ *parent;\n", t.parent.frameID);
        END;
        FOR i := 0 TO t.curSize - 1 DO 
          IF t.contents[i].inFrame THEN
            Emit.OpI ("t@ ", Type.Name (t.contents[i].type));
            Emit.OpS (" *_@;\n", t.contents[i].name);
          END;
        END;
        Emit.OpI ("\002} *FRAME@;\n", t.frameID);
      END;
      t := t.next;
    END;
  END GenFrameTypes;

PROCEDURE EmitFrameName (t: T): BOOLEAN =
  BEGIN
    IF t # NIL AND t.parent # NIL AND t.parent.frameID # 0 THEN
      Emit.Op ("parent");
      RETURN TRUE;
    ELSE
      RETURN FALSE;
    END;
  END EmitFrameName;

PROCEDURE EmitLocalFrameName (t: T): BOOLEAN =
  (* we are in some scope, which must have a frame visible;
     somewhere following the parent field, we should see a frame
     with the save id as that of the parent of t. generate the name for it. *)

  VAR current := top;
  BEGIN
    IF t # NIL AND t.parent # NIL THEN
      WITH target = t.parent.frameID DO
        IF target = 0 THEN RETURN FALSE; END;
        <* ASSERT current.frameID # 0 *>
        IF current.localFrame
          THEN Emit.Op ("(&frame)");
          ELSE Emit.Op ("parent");
        END;
        WHILE current.frameID # target DO
          IF current.hasFrame THEN Emit.Op ("->parent"); END;
          current := current.parent;
        END;
      END;
      RETURN TRUE;
    ELSE
      RETURN FALSE;
    END;
  END EmitLocalFrameName;

PROCEDURE EmitFrameType (t: T) =
  BEGIN
    IF t # NIL AND t.parent # NIL AND t.parent.frameID # 0 THEN
      Emit.OpI ("FRAME@ parent;\n", t.parent.frameID);
    END;
  END EmitFrameType;

PROCEDURE Enter (t: T) =
  BEGIN
    IF (t = NIL) THEN RETURN END;
    Emit.Op ("{\001\n");
    FOR i := 0 TO t.curSize - 1 DO Value.Declare0 (t.contents[i]); END;
    IF t.hasFrame THEN
      IF t.parent.frameID # 0 AND t.parent.localFrame AND NOT t.viaFrame THEN
        Emit.OpI ("FRAME@ parent = &frame;\n", t.parent.frameID);
      END;
      Emit.OpI ("{\001\nstruct frame@ frame;\n", t.frameID);
      IF t.parent.frameID # 0 THEN
        Emit.Op  ("frame.parent = parent;\n"); 
      END;
      FOR i := 0 TO t.curSize - 1 DO
        IF t.contents[i].inFrame THEN
          Emit.OpS ("frame._@ = ", t.contents[i].name);
	  Variable.LoadLValue (t.contents[i]);
          Emit.Op (";\n");
        END;
      END;
    ELSE
      Emit.Op ("{\001\n");
    END;
    Generate (t);
  END Enter;

PROCEDURE Generate (t: T) =
  BEGIN
    IF t = NIL THEN RETURN; END;
    FOR i := 0 TO t.curSize - 1 DO Value.Declare1 (t.contents[i]); END;
    FOR i := 0 TO t.curSize - 1 DO Value.Declare2 (t.contents[i]); END;
  END Generate;

PROCEDURE Exit (t: T) =
  BEGIN
    IF (t = NIL) THEN RETURN END;
    Emit.Op ("}\002\n}\002\n");
  END Exit;

PROCEDURE WarnUnused (t: T) =
  VAR save, level: INTEGER;  vc: Value.Class;
  BEGIN
    IF t = NIL OR Module.IsInterface() THEN RETURN END;
    save := Scanner.offset;
    FOR i := 0 TO t.curSize - 1 DO
      WITH x = t.contents[i] DO
        IF (NOT x.used) AND (NOT x.imported) AND (NOT x.exported) THEN
          IF NOT (x.unused OR x.obsolete) THEN
            level := 2;
	    vc := Value.ClassOf (x);
            IF (vc = Value.Class.Formal) OR
              ((vc = Value.Class.Var) AND Variable.IsFormal (x)) THEN
              level := 1;
            END;
            Scanner.offset := x.origin;
            Error.WarnStr (level, x.name, "not used");
          END;
        ELSIF (x.used) THEN
          IF x.obsolete THEN
            Scanner.offset := x.origin;
            Error.WarnStr (2, x.name, "obsolete");
          ELSIF x.unused THEN
            Scanner.offset := x.origin;
            Error.WarnStr (2, x.name, "<*UNUSED*> symbol is used");
          END;
	END;
      END;
    END;
    Scanner.offset := save;
  END WarnUnused;

PROCEDURE CleanUp (t: T) =
  BEGIN
    IF (t.hash = NIL) THEN RemoveDuplicates (t); HashScope (t);  END;
  END CleanUp;

PROCEDURE RemoveDuplicates (t: T) =
  VAR n: INTEGER;  objs: ValueList;  o, z: Value.T;
  BEGIN
    objs := t.contents;
    n := 0;
    FOR i := 0 TO t.curSize - 1 DO
      o := objs[i];
      IF (o # NIL) THEN
        FOR j := i + 1 TO t.curSize - 1 DO
          z := objs[j];
          IF (z = NIL) THEN
            (* ignore it *)
          ELSIF (z = o) THEN
            (* same item duplicated => kill 2nd one *)
            objs[j] := NIL;
          ELSIF (z.name = o.name) THEN
            (* different items with the same name! *)
            o := Value.SelectOne (o, z);
            objs[j] := NIL;
          END;
        END;
        objs[n] := o;
        INC (n);
      END;
    END;
    t.curSize := n;
  END RemoveDuplicates;

PROCEDURE HashScope (t: T) =
  VAR x: ValueList; max, hash: INTEGER; o: Value.T;
  BEGIN
    max := 2 * t.curSize;
    t.hashSize := max;
    x := NEW (ValueList, max);
    FOR i := 0 TO max - 1 DO  x[i] := NIL  END;
    FOR i := 0 TO t.curSize - 1 DO
      o := t.contents[i];
      hash := (LOOPHOLE (o.name, INTEGER) DIV 4) MOD max;
      WHILE (x[hash] # NIL) DO
        INC (hash);
        IF (hash >= max) THEN hash := 0 END;
      END;
      x[hash] := o;
    END;
    t.hash := x;
  END HashScope;

PROCEDURE NameToPrefix (v: Value.T; VAR p: String.Stack;
                        considerExternal := TRUE) =
  VAR t: T; count: INTEGER := 0; haveRParen := FALSE;
  BEGIN
    IF considerExternal AND v.external THEN
      p.stk [p.top] := v.extName;
      INC (p.top);
    ELSIF v.exported OR v.imported OR v.scope.parent = Initial THEN
      IF v.scope.name = emptyStr THEN
        p.stk [p.top] := Underscore;
        p.stk [p.top+1] := v.name;
        INC (p.top, 2);
      ELSE
        p.stk [p.top] := Underscore;
        p.stk [p.top+1] := v.scope.name;
        p.stk [p.top+2] := UnderscoreUnderscore;
        p.stk [p.top+3] := v.name;
        INC (p.top, 4);
      END;
    ELSIF Value.ClassOf (v) = Value.Class.Procedure THEN
      (* count how may strings we'll produce *)
      count := p.top + 1;
      t := v.scope;
      LOOP
        IF t = NIL THEN EXIT END;
        IF t.name # emptyStr THEN INC (count, 2); END;
        IF (NOT t.open) THEN EXIT END;
        t := t.parent;
      END;
      INC (count);

      p.top := count; 
      DEC (count);
      p.stk [count] := v.name;
      t := v.scope;
      LOOP
        IF t = NIL THEN EXIT END;
        IF t.name # emptyStr THEN 
          DEC (count, 2);
          p.stk [count + 1] := UnderscoreUnderscore;
          p.stk [count]     := t.name;
        END;
        IF (NOT t.open) THEN EXIT END;
        t := t.parent;
      END;
      DEC (count);
      p.stk [count] := Underscore;
      <* ASSERT count = 0 *>
    ELSE
      IF v.inFrame AND v.scope # top THEN
        (* this test above is only an heuristics *)
        t := top;
        WHILE v.scope # t AND NOT t.viaFrame DO t := t.parent; END;
        IF v.scope # t THEN
          IF Variable.IsIndirect (v)
            THEN p.stk [p.top] := LParen;
            ELSE p.stk [p.top] := StarLParen;
          END;
          p.stk [p.top+1] := Parent;
          INC (p.top, 2);
          t := t.parent;
          haveRParen := TRUE;
        END;
        WHILE v.scope # t DO
          IF t.hasFrame THEN p.stk [p.top] := Parent; INC (p.top); END;
          t := t.parent;
        END;
      END;
      p.stk [p.top] := Underscore;
      p.stk [p.top + 1] := v.name;
      INC (p.top, 2);
      IF haveRParen THEN p.stk [p.top] := RParen; INC (p.top); END;
    END;
  END NameToPrefix;

PROCEDURE GenName (v: Value.T) =
  VAR p: String.Stack;
  BEGIN
    p.top := 0;
    NameToPrefix (v, p);
    Emit.OpZ ("@", p);
  END GenName;

PROCEDURE Initialize () =
  BEGIN
    allScopes := NIL;
    top       := NIL;
    emptyStr  := String.Add ("");
    Initial   := PushNew (FALSE, emptyStr);
    Underscore := String.Add ("_");
    UnderscoreUnderscore := String.Add ("__");
    Parent := String.Add ("parent->");
    StarLParen := String.Add ("(*(");
    LParen := String.Add ("((");
    RParen := String.Add ("))");
  END Initialize;

BEGIN
END Scope.