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

(* File: Scope.m3                                              *)
(* Last modified on Wed Jul 22 22:06:20 1992 by kalsow     *)
(*      modified on Sat Feb 16 02:55:11 1991 by muller         *)

MODULE Scope;

IMPORT M3, String, Value, Type, Module, Error, Procedure;
IMPORT Emit, Scanner, ValueRep, Variable, Frame, Tracer;

CONST
  InitialSize = 4;
  EmptyHash   = -1;

REVEAL
  M3.Scope = M3.Node BRANDED "Scope.T" OBJECT
    next       : T;
    parent     : T;
    name       : String.T;
    children   : INTEGER;
    curSize    : INTEGER; (* # of entries in 'contents' *)
    hashSize   : INTEGER; (* # of entries added to hash table *)
    contents   : ValueList;
    aliases    : NameList;
    hash       : UNTRACED REF ARRAY OF INTEGER;
    frameSize  : INTEGER := 0;      (* # of pointers in the frame *)
    frameID    : INTEGER := 0;      (* if # 0, there is a frame visible
                                       in this scope *)
    viaFrame   : BOOLEAN := FALSE;  (* the C scope for this one is not
                                       within the C scope of parent *)
    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 *)
    open       : BOOLEAN := FALSE;  (* => lookups can see parent *)
    module     : BOOLEAN := FALSE;  (* => is an outer module scope *)
    imported   : BOOLEAN := FALSE;  (* => scope outside main compilation *)
  END;

VAR
  frameID   := 1;
  top       : T;
  allScopes : T;

VAR (* string "constants" *)
  emptyStr    : String.T;
  Dot         : String.T;
  Underscore  : String.T;
  DUnderscore : String.T;
  Parent      : String.T;
  StarLParen  : String.T;
  LParen      : String.T;
  RParen      : String.T;

PROCEDURE PushNew (open: BOOLEAN;  name: String.T;
                    viaFrame := FALSE;  module := FALSE): T =
  VAR t := NEW (T);
  BEGIN
    t.origin     := Scanner.offset;
    t.next       := allScopes;  allScopes := t;
    t.parent     := top;
    t.name       := NewScopeName (name);
    t.children   := 0;
    t.curSize    := 0;
    t.hashSize   := 0;
    t.contents   := NEW (ValueList, InitialSize);
    t.aliases    := NIL;
    t.hash       := NIL;
    t.frameID    := 0;
    t.viaFrame   := viaFrame;
    t.hasFrame   := FALSE;
    t.localFrame := TRUE;
    t.open       := open;
    t.module     := module;
    t.imported   := (Module.depth # 1);
    top := t;
    RETURN t;
  END PushNew;

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

PROCEDURE New1 (obj: Value.T): T =
  VAR t := NEW (T);  alias: String.T;
  BEGIN
    t.origin     := Scanner.offset;
    t.next       := allScopes;  allScopes := t;
    t.parent     := top;
    t.name       := NewScopeName (NIL);
    t.children   := 0;
    t.curSize    := 1;
    t.hashSize   := 0;
    t.contents   := NEW (ValueList, 1);
    t.aliases    := NIL;
    t.hash       := NIL;
    t.frameID    := 0;
    t.viaFrame   := FALSE;
    t.hasFrame   := FALSE;
    t.localFrame := TRUE;
    t.open       := TRUE;
    t.module     := FALSE;
    t.imported   := (Module.depth # 1);

    (* insert the single value into this scope *)
    t.contents[0] := obj;
    IF (obj.scope = NIL) THEN obj.scope := t END;
    alias := CheckName (t, obj);
    IF (alias # NIL) THEN
      t.aliases := NEW (NameList, 1);
      t.aliases[0] := alias;
    END;

    top := t;
    RETURN t;
  END New1;

PROCEDURE NewScopeName (name: String.T): String.T =
  BEGIN
    IF (name # NIL) THEN RETURN name END;
    IF (top # NIL) THEN
      INC (top.children);
      RETURN String.AddInt (top.children);
    END;
    RETURN emptyStr;
  END NewScopeName;

PROCEDURE IsLexicallyNested (t: T;  lexical: BOOLEAN) =
  BEGIN
    t.viaFrame := NOT lexical;
  END IsLexicallyNested;

PROCEDURE Push (t: T): T =
  VAR old := top;
  BEGIN
    <* ASSERT t # NIL *>
    top := t;
    RETURN old;
  END Push;

PROCEDURE Pop (old: T) =
  BEGIN
    <* ASSERT old # NIL *>
    top := old;
  END Pop;

PROCEDURE Top (): T =
  (* return the top "open" scope *)
  VAR t: T;
  BEGIN
    t := top;
    WHILE (t # NIL) AND (NOT t.open) DO t := t.parent END;
    RETURN t;
  END Top;

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

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

PROCEDURE LookUp (t: T;  name: String.T;  strict: BOOLEAN): Value.T =
  VAR o: Value.T;  viaFrame := FALSE;
  BEGIN
    LOOP
      IF (t = NIL) THEN RETURN NIL END;
      o := LookUpX (t, name);
      IF (o # NIL) THEN EXIT END;
      IF (strict) OR (NOT t.open) THEN RETURN NIL END;
      viaFrame := viaFrame OR t.viaFrame;
      t := t.parent;
    END;

    IF (Module.depth = 1) THEN
      (* this is a top-level use of the symbol! *)
      o.used := TRUE;
      IF o.obsolete THEN
        Error.WarnStr (2, name, "<*OBSOLETE*> symbol used");
      ELSIF o.unused THEN
        Error.WarnStr (2, name, "<*UNUSED*> symbol used");
      END;
    END;

    o.inFrame := o.inFrame OR
     (viaFrame AND (NOT t.module) 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 LookUp;

PROCEDURE LookUpX (t: T;  name: String.T): Value.T =
  VAR hash, hx, maxHash: INTEGER;  o: Value.T;
  BEGIN
    IF (t.hashSize # t.curSize) THEN HashScope (t) END;
    IF (t.hashSize > 0) THEN
      maxHash := NUMBER (t.hash^);
      hash := String.Hash (name) MOD maxHash;
      LOOP
        hx := t.hash [hash];
        IF (hx = EmptyHash) THEN EXIT END;
        o := t.contents[hx];
        IF ((t.aliases = NIL) AND (o.name = name))
          OR ((t.aliases # NIL) AND (t.aliases[hx] = name)) THEN
          RETURN o;
        END;
        INC (hash);
        IF (hash >= maxHash) THEN hash := 0 END;
      END;
    END;
    RETURN NIL;
  END LookUpX;

PROCEDURE Insert (o: Value.T) =
  BEGIN
    InsertUnderAlias (o, NIL);
  END Insert;

PROCEDURE InsertUnderAlias (o: Value.T;  alias: String.T) =
  VAR t: T;  new_alias: String.T;
  BEGIN
    t := top;

    new_alias := CheckName (t, o);
    IF (new_alias # NIL) AND (alias = NIL) THEN  alias := new_alias END;

    IF (t.curSize >= NUMBER(t.contents^)) THEN ExpandContents (t) END;
    IF (o.scope = NIL) THEN o.scope := t END;
    t.contents [t.curSize] := o;

    IF (alias # NIL) THEN
      IF (t.aliases = NIL) THEN ExpandAliases (t) END;
      t.aliases [t.curSize] := alias;
    ELSIF (t.aliases # NIL) THEN
      t.aliases [t.curSize] := o.name;
    END;

    INC (t.curSize);
  END InsertUnderAlias;

PROCEDURE CheckName (t: T;  o: Value.T): String.T =
  VAR alias: String.T := NIL;
  BEGIN
    (* check for a reserved word *)
    IF (t # Initial) AND (LookUp (Initial, o.name, TRUE) # NIL) THEN
      Error.Str (o.name, "Reserved identifier redefined");
    END;

    IF String.IsReservedC (o.name) AND NOT OuterMost (t) THEN
      alias := o.name;
      o.name := String.Concat (o.name, Underscore);
      IF (NOT t.imported) THEN
        Error.WarnStr (0, alias, "C reserved word, appending underscore");
      END;
    END;

    RETURN alias;
  END CheckName;

PROCEDURE ExpandContents (t: T) =
  VAR z := NEW (ValueList, 2 * NUMBER (t.contents^));
  BEGIN
    FOR i := 0 TO t.curSize - 1 DO  z[i] := t.contents[i] END;
    t.contents := z;
    IF (t.aliases # NIL) THEN ExpandAliases (t) END;
  END ExpandContents;

PROCEDURE ExpandAliases (t: T) =
  VAR z := NEW (NameList, NUMBER (t.contents^));
  BEGIN
    IF (t.aliases = NIL) THEN
      FOR i := 0 TO t.curSize - 1 DO
        IF (t.contents[i] # NIL) THEN z[i] := t.contents[i].name END;
      END;
    ELSE
      FOR i := 0 TO t.curSize - 1 DO z[i] := t.aliases[i] END;
    END;
    t.aliases := z;
  END ExpandAliases;

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 ToListWithAliases (t: T;  VAR objs: ValueList;  VAR cnt: INTEGER;
                               VAR aliases: NameList) =
  BEGIN
    IF (t = NIL)
      THEN  objs := NIL;         cnt := 0;          aliases := NIL;
      ELSE  objs := t.contents;  cnt := t.curSize;  aliases := t.aliases;
    END;
  END ToListWithAliases;

PROCEDURE TypeCheck (t: T;  VAR cs: Value.CheckState) =
  (* note: we separate the type checking of procedures heads and bodies
     in an attempt to keep the error messages sorted in a rational order *)
  BEGIN
    IF (t = NIL) THEN RETURN END;
    RemoveDuplicates (t);
    FOR i := 0 TO t.curSize - 1 DO
      Value.TypeCheck (t.contents[i], cs);
    END;
    FOR i := 0 TO t.curSize - 1 DO
      TYPECASE Value.Base (t.contents[i]) OF
      | NULL            => (* ignore *)
      | Procedure.T (p) => Procedure.CheckBody (p, cs);
      ELSE                 (* ignore *)
      END;
    END;
  END TypeCheck;

PROCEDURE GenFrameTypes () =
  VAR t := allScopes;  save: Emit.Stream;
  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;

    save := Emit.Switch (Emit.Stream.TypeDecls);
    t := allScopes;
    WHILE t # NIL DO
      IF t.frameID # 0 AND t.parent # NIL AND t.parent.frameID # t.frameID THEN
        FOR i := 0 TO t.curSize - 1 DO 
          IF t.contents[i].inFrame THEN
            Type.Compile (Value.TypeOf (t.contents[i]));
          END;
        END;
        Emit.OpI ("typedef struct _frame@ {\001\n", t.frameID);
        IF t.parent.frameID # 0 THEN
          Emit.OpI ("struct _frame@ *_parent;\n", t.parent.frameID);
          INC (t.frameSize);
        END;
        FOR i := 0 TO t.curSize - 1 DO 
          IF t.contents[i].inFrame THEN
            Emit.OpF ("@ ", Value.TypeOf (t.contents[i]));
            Emit.OpS (" *@;\n", t.contents[i].name);
            INC (t.frameSize);
          END;
        END;
        Emit.OpI ("\002} *_FRAME@;\n", t.frameID);
      END;
      t := t.next;
    END;
    EVAL Emit.Switch (save);
  END GenFrameTypes;

PROCEDURE EmitFrameName (t: T; testOnly := FALSE): BOOLEAN =
  BEGIN
    IF (t = NIL) OR (t.parent = NIL) THEN RETURN FALSE END;
    IF (t.parent.frameID = 0) THEN RETURN FALSE END;
    IF NOT testOnly THEN Emit.Op ("_parent") END;
    RETURN TRUE;
  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 same id as that of the parent of t. generate the name for it. *)

  VAR current := top;  target: INTEGER;
  BEGIN
    IF (t = NIL) OR (t.parent = NIL) THEN RETURN FALSE END;
    target := t.parent.frameID;
    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;
    RETURN TRUE;
  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;
    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);
        INC (Frame.cur.size);
      END;
      Emit.OpI ("{\001\nstruct _frame@ _frame;\n", t.frameID);
      INC (Frame.cur.size, t.frameSize);
    END;
  END Enter;

PROCEDURE InitValues (t: T) =
  BEGIN
    IF t = NIL THEN RETURN; END;
    IF t.hasFrame THEN
      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;
    END;
    FOR i := 0 TO t.curSize - 1 DO Value.Declare1 (t.contents[i]); END;
    Tracer.EmitPending ();
    FOR i := 0 TO t.curSize - 1 DO Value.Declare2 (t.contents[i]); END;
    Tracer.EmitPending ();
  END InitValues;

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

PROCEDURE WarnUnused (t: T) =
  VAR save, level: INTEGER;  vc: Value.Class;  name: String.T;  v: Value.T;
  BEGIN
    IF (t = NIL) OR (t.imported) THEN RETURN END;
    save := Scanner.offset;
    FOR i := 0 TO t.curSize - 1 DO
      v := t.contents[i];
      name := v.name; IF (t.aliases # NIL) THEN name := t.aliases[i] END;
      IF (NOT v.used) AND (NOT v.exportable) THEN
        IF NOT (v.unused OR v.obsolete) THEN
          level := 2;
          vc := Value.ClassOf (v);
          IF (vc = Value.Class.Formal) OR
            ((vc = Value.Class.Var) AND Variable.IsFormal (Value.Base(v))) THEN
            level := 1;
          END;
          Scanner.offset := v.origin;
          Error.WarnStr (level, name, "not used");
	END;
      END;
    END;
    Scanner.offset := save;
  END WarnUnused;

PROCEDURE RemoveDuplicates (t: T) =
  VAR n, save: INTEGER;  objs: ValueList;  o, z: Value.T;  on, zn: String.T;
  BEGIN
    save := Scanner.offset;
    objs := t.contents;
    n := 0;
    FOR oi := 0 TO t.curSize - 1 DO
      o := objs[oi];
      IF (o # NIL) THEN
        on := o.name;  IF (t.aliases # NIL) THEN on := t.aliases[oi] END;
        FOR zi := oi + 1 TO t.curSize - 1 DO
          z := objs[zi];
          IF (z # NIL) THEN
            zn := z.name;  IF (t.aliases # NIL) THEN zn := t.aliases[zi] END;
            IF (zn = on) THEN (* same name *)
              Scanner.offset := z.origin;
              IF (Value.Base (z) = Value.Base (o)) THEN
                (* same item duplicated => kill 2nd one *)
                Error.Str (o.name, "duplicate import");
              ELSE (* different items with the same name! *)
                Error.Str (zn, "symbol redefined");
                o := z; (* keep the most recent definition *)
              END;
              objs[zi] := NIL;
            END;
          END;
        END;
        objs[n] := o;
        IF (t.aliases # NIL) THEN t.aliases[n] := on END;
        INC (n);
      END;
    END;
    t.curSize := n;
    Scanner.offset := save;
 END RemoveDuplicates;

PROCEDURE HashScope (t: T) =
  VAR
    max := 2 * t.curSize;
    x := NEW (UNTRACED REF ARRAY OF INTEGER, max);
    hash: INTEGER;
    o: Value.T;
    on: String.T;
  BEGIN
    FOR i := 0 TO max - 1 DO  x[i] := -1  END;
    FOR i := 0 TO t.curSize - 1 DO
      o := t.contents[i];
      on  := o.name; IF (t.aliases # NIL) THEN on := t.aliases[i] END;
      hash := String.Hash (on) MOD max;
      WHILE (x[hash] # EmptyHash) DO
        INC (hash);
        IF (hash >= max) THEN hash := 0 END;
      END;
      x[hash] := i;
    END;
    t.hashSize := t.curSize;
    t.hash := x;
  END HashScope;

PROCEDURE NameToPrefix (v: Value.T; VAR p: String.Stack;
                        considerExternal := TRUE;
                        dots := FALSE) =
  VAR t: T; count: INTEGER := 0; haveRParen := FALSE;  dot: String.T;
    save: INTEGER;
  BEGIN
    v := Value.Base (v);
    IF (dots)
      THEN dot := Dot;
      ELSE dot := DUnderscore;
    END;
    IF considerExternal AND v.external THEN
      p.stk [p.top] := v.extName;
      INC (p.top);
    ELSIF v.exported OR v.imported OR v.scope.module THEN
      IF v.scope.name = emptyStr THEN
        p.stk [p.top] := v.name;
        INC (p.top, 1);
      ELSE
        p.stk [p.top]   := v.scope.name;
        p.stk [p.top+1] := dot;
        p.stk [p.top+2] := v.name;
        INC (p.top, 3);
      END;
    ELSIF Value.ClassOf (v) = Value.Class.Procedure OR
	  Value.ClassOf (v) = Value.Class.Expr THEN
      (* count how may strings we'll produce *)
      save := p.top;
      count := p.top;
      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;
        IF (t.module) 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] := dot;
          p.stk [count]     := t.name;
        END;
        IF (NOT t.open) THEN EXIT END;
        IF (t.module) THEN EXIT END;
        t := t.parent;
      END;
      <* ASSERT count = save *>
    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] := v.name;
      INC (p.top);
      IF haveRParen THEN p.stk [p.top] := RParen; INC (p.top); END;
    END;
  END NameToPrefix;

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

PROCEDURE GlobalName (v: Value.T;  VAR p: String.Stack) =
  VAR t: T;  count, save: INTEGER;
  BEGIN
    v := Value.Base (v);

    (* count how may strings we'll produce *)
    save := p.top;
    count := p.top;
    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;
      IF (t.module) 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] := Dot;
        p.stk [count]     := t.name;
      END;
      IF (NOT t.open) THEN EXIT END;
      IF (t.module) THEN EXIT END;
      t := t.parent;
    END;

    <* ASSERT count = save *>
  END GlobalName;

PROCEDURE Initialize () =
  BEGIN
    emptyStr    := String.Add ("");
    Dot         := String.Add (".");
    Underscore  := String.Add ("_");
    DUnderscore := String.Add ("__");
    Parent      := String.Add ("_parent->");
    StarLParen  := String.Add ("(*(");
    LParen      := String.Add ("((");
    RParen      := String.Add ("))");

    Initial := PushNew (FALSE, emptyStr);
  END Initialize;

PROCEDURE Reset () =
  BEGIN
    top := NIL;
    allScopes := NIL;
    top := Initial;
  END Reset;

BEGIN
END Scope.