IMPLEMENTATION MODULE YaflClasses;

FROM Conversions IMPORT IntConversions;
FROM YaflLex IMPORT LexicalAnalyzer;
FROM List IMPORT List;
FROM YaflParser IMPORT NonTerminal;
FROM Streams IMPORT StdErr;
FROM YaflSymbols IMPORT SymbolTable;
FROM YaflCfg IMPORT CurrentSpot, YaflCfg;
FROM YaflIdentifiers IMPORT Ident, IdentList;
FROM YaflMetImplementation IMPORT MethodImplementation;
FROM YaflNTList IMPORT MultiDeclList, MethodList, NTSet;
FROM YaflParamClasses IMPORT ClassActual;
FROM Streams IMPORT StdOut, StdErr;
FROM YaflPredefined IMPORT PredefItems, ThisDataItem;
FROM YaflClImplementation IMPORT ClassImplementation;
FROM YaflPreconditions IMPORT ClassInvariant;
FROM Conversions IMPORT IntConversions;
FROM String IMPORT String;
FROM YaflDictionary IMPORT ModuleReference;
FROM YaflType IMPORT InstType;

  CLASS ClassDeclaration(MethodComponent IN MethodDeclaration,
                         Enclosing       IN CompilationUnit,
                         gc              IN ClassDeclCodeGenerator);
    INHERITS Declaration(gc);

    VAR
      TheOnce: BOOLEAN;
      TheClassName: Ident;
      TheClassFormals: ClassFormalSet;
      TheInheritsCl: InheritsClause;
      TheMethodsList: MethodList (MethodComponent);
      TheConstsList: DeclList (ConstDeclaration);
      ThePragmaList: DeclList (Pragma);
      TheInvariantList: NTList (ClassInvariant);
      TheSubDecls: MultiDeclList;
      
    REDEFINE METHOD CREATE (LineNr, ColNr : INTEGER);
      BEGIN      
      BASE (LineNr, ColNr);
      TheMethodsList.CREATE;
      TheConstsList.CREATE;
      ThePragmaList.CREATE;
      TheInvariantList.CREATE;
      TheSubDecls.CREATE;
      TheSubDecls.SetFather (THIS);
      TheSubDecls.AppendList (TheMethodsList);
      TheSubDecls.AppendList (TheConstsList);
      TheSubDecls.AppendList (ThePragmaList);
      END CREATE;
      
    REDEFINE METHOD SubDecls: MultiDeclList;
      BEGIN        
      RESULT := TheSubDecls;
      END SubDecls;
      
    METHOD SetOnce (Val: BOOLEAN);
      BEGIN
      TheOnce := Val;
      END SetOnce;

    METHOD Image: ARRAY OF CHAR;
      BEGIN
      RESULT := Id.Data;
      END Image;
      
    METHOD DotImage: ARRAY OF CHAR;
      BEGIN
      RESULT := Module.Id.Data + "." + Id.Data;
      END DotImage;

    METHOD Once: BOOLEAN;
      BEGIN
      RESULT := TheOnce;
      END Once;

    METHOD Module : Enclosing;
      BEGIN
      IF GrandPa <> VOID THEN
        WHAT GrandPa OF
          IN Enclosing:
            RESULT := TAG;
            END;
          END;
        END;
      END Module;

    METHOD ModuleName: ARRAY OF CHAR;
      BEGIN
      RESULT := Module.Id.Data;
      END ModuleName;  
      
    METHOD ParseClassDeclaration (Lkh: LookAhead);
      BEGIN
      IF Lkh.CurrentToken = LexicalAnalyzer.Once THEN
        Lkh.GetToken;
        SetOnce (TRUE);
        END;
      Lkh.Accept (LexicalAnalyzer.Class);
      TheClassName := Lkh.AcceptIdent;
      ASSERT TheClassName <> VOID;
      ASSERT Id <> VOID;
      ASSERT Id = TheClassName;
      SetSon (TheClassName);
      IF Lkh.CurrentToken = Lkh.LeftParen THEN
        TheClassFormals := Lkh.AcceptClassFormals;
        SetSon (TheClassFormals);
        END;
      Lkh.Accept (LexicalAnalyzer.SemiColon);
      IF Lkh.CurrentToken = LexicalAnalyzer.Inherits THEN
        TheInheritsCl.CREATE(Lkh.LineNr, Lkh.ColNr);
        TheInheritsCl.Parse(Lkh);
        SetSon (TheInheritsCl);
        END;
      END ParseClassDeclaration;
      
      
    METHOD ParseDeclarationList(Lkh: LookAhead; 
                                Implementation: BOOLEAN);
      VAR
        DList: DeclList;
      BEGIN
      WHILE (Lkh.CurrentToken <> Lkh.End) 
            AND (Lkh.CurrentToken <> Lkh.Begin) AND Lkh.Ok DO
        IF Lkh.Ok THEN
          ASSERT SubDecls <> VOID;
          DList := Lkh.AcceptDeclarationList(Implementation,
                                             LookAhead.ClassContext);
	  IF DList.Size = 0 THEN
	    Lkh.Error ("Declaration expected");
	    END;
          SubDecls.AppendFromList(DList);
          END;
        WHILE (Lkh.CurrentToken = Lkh.Invariant) AND Lkh.Ok DO
          TheInvariantList.Append(Lkh.AcceptClassInvariant);
          END;
        END;
      END ParseDeclarationList;
      
    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      RESULT.CREATE (3);
      RESULT[0] := TheClassName;
      RESULT[1] := TheClassFormals;
      RESULT[2] := TheInheritsCl;
      RESULT := RESULT + SubDecls.SubTree;
      RESULT := RESULT + TheInvariantList.SubTree;
      END SubTree;
             
    REDEFINE METHOD Id: Ident;
      BEGIN
      RESULT := TheClassName;
      END Id;

    METHOD Inherits: InheritsClause;
      BEGIN
      RESULT:= TheInheritsCl;
      END Inherits;

    METHOD ClassFormals: ClassFormalSet;
      BEGIN
      RESULT := TheClassFormals;
      END ClassFormals;
      
    METHOD Arity: INTEGER;
      BEGIN
      IF TheClassFormals <> VOID THEN
        RESULT := TheClassFormals.Size;
        END;
      END Arity;
      
    METHOD IsParameterized: BOOLEAN;
      BEGIN               
      RESULT := Arity > 0;
      END IsParameterized;

    METHOD GetDecl (IdSearched: ARRAY OF CHAR): Declaration;
      BEGIN
      RESULT := GetLocalDecl (IdSearched);
      END GetDecl;
      
    METHOD GetLocalDecl (IdSearched: ARRAY OF CHAR): Declaration;
      BEGIN
      RESULT := SubDecls.Find (IdSearched);
      -----------------------------------
      -- If not found, then look in
      -- the inheritance chain recursively.
      -----------------------------------

      IF Inherits <> VOID THEN   -- Make sure that the inherits
        Inherits.UniqueTag;      -- clause has been tagged
        END; -- IF

      ASSERT Inherits <> VOID IMPLIES Inherits.IsTagged;

      IF (RESULT = VOID) AND 
         (Inherits <> VOID) AND 
         (Inherits.Class <> VOID) THEN
        RESULT := Inherits.Class.GetDecl (IdSearched);
        END;
      IF RESULT = VOID THEN
        RESULT := PredefItems.FindPredefinedMethod (IdSearched);
        END;
      END GetLocalDecl;

    METHOD GetFormalPos (IdSearched: ARRAY OF CHAR): INTEGER;
      VAR 
        FormalList: NTList(ClassFormal); 
      BEGIN
      IF ClassFormals <> VOID THEN
        FormalList := ClassFormals.FormalList;
        RESULT := FIRST i IN 0 TO FormalList.Size - 1 :-
                    FormalList.Get(i).Id.Data = IdSearched;
        END;
      END GetFormalPos;
      
    METHOD FindPos (ClFormal: ClassFormal): INTEGER;
      VAR
        FormalList: NTList(ClassFormal);
      BEGIN
      ASSERT ClassFormals <> VOID;
      FormalList := ClassFormals.FormalList;
      RESULT := -1;
      FOR i := 0 TO FormalList.Size-1 WHILE RESULT < 0 DO
        IF FormalList.Get(i) = ClFormal THEN
          RESULT := i;
          END;
        END;
      ASSERT RESULT >= 0;
      END FindPos;
      
    METHOD CyclicInherits: BOOLEAN;
      VAR
        Other: ClassDeclaration;
      BEGIN
      IF Inherits <> VOID THEN
        Other := Inherits.Class;
        WHILE (Other <> VOID) AND (NOT RESULT) DO
          RESULT := THIS.Match(Other);
          IF NOT RESULT THEN
            IF Other.Inherits <> VOID THEN
              Other := Other.Inherits.Class;
             ELSE
              Other := VOID;
              END;
            END;
          END;
        END;
      END CyclicInherits;

    METHOD TagInvariants;
      BEGIN
      ASSERT TheInvariantList <> VOID;  
      IF TheInvariantList.Size > 0 THEN 
        SymbolTable.PushLevel;
        SubDecls.Enter;
        TheInvariantList.UniqueTag;
        SymbolTable.PopLevel;
        END;
      END TagInvariants;
      
    ------------------------------------------
    -- Tag the methodheader of each method
    -- included in this class
    ------------------------------------------
    METHOD TagMethodHeaders;
      BEGIN
      SymbolTable.PushLevel;
      EnterFormalClasses;
      CurrentSpot.PushCurrentClass(THIS);
      FOR Meth IN Methods DO
        Meth.TagHeader;
        END;
      CurrentSpot.PopCurrentClass;
      SymbolTable.PopLevel;
      END TagMethodHeaders;
      
    METHOD TagAssertions;
      BEGIN
      SymbolTable.PushLevel;
      CurrentSpot.PushCurrentClass(THIS);
      EnterInheritedSymbols;
      SubDecls.Enter;
      FOR Meth IN Methods DO
        Meth.TagAssertions;
        END;
      CurrentSpot.PopCurrentClass;
      SymbolTable.PopLevel;
      END TagAssertions;
      
    METHOD TagInheritsClause;
      BEGIN
      SymbolTable.PushLevel;
      EnterFormalClasses;
      IF Inherits <> VOID THEN
        Inherits.UniqueTag;

        ASSERT Inherits.IsTagged;
        END;
      SymbolTable.PopLevel;
      END TagInheritsClause;
      
    METHOD FirstPassTag;
      BEGIN
      SymbolTable.PushLevel;
      IF ClassFormals <> VOID THEN
        Canonic.ClassFormals.UniqueTag;
        END;
      IF Inherits <> VOID THEN
        EnterFormalClasses;
        Inherits.UniqueTag;
        END;
      EnterInheritedConsts;
      TheConstsList.Enter;
      TheConstsList.UniqueTag;
      TagInvariants;
      SymbolTable.PopLevel;
      END FirstPassTag;

    VAR
      InheritsChecked: BOOLEAN;

    REDEFINE METHOD CheckType;
      BEGIN
      CurrentSpot.PushCurrentClass (THIS);
      IF NOT InheritsChecked THEN
        InheritsChecked := TRUE;
        IF Inherits <> VOID THEN
          Inherits.UniqueCheckType;
          END;
        ----------------------
        -- Make sure that the CREATE method, redefined or
        -- inherited is parameterless.
        ----------------------
        IF Once THEN
          ASSERT Create <> VOID;
          IF Create.Arity <> 0 THEN
            Error ("A ONCE class should support " +
                   "a parameterless CREATE method");
            END;
          END;
        END;
      ASSERT TheInvariantList <> VOID;  
      TheInvariantList.UniqueCheckType;
      SubDecls.UniqueCheckType;
      CurrentSpot.PopCurrentClass;
      END CheckType;
      
    METHOD EnterInheritedConsts;
      VAR
        Cl: ClassDeclaration;
        Visited: NTSet (ClassDeclaration);
        GoOn: BOOLEAN;
      BEGIN            
      Cl := THIS;                   
      GoOn := TRUE;
      WHILE (Cl <> VOID) AND (Cl.Inherits <> VOID) AND GoOn DO
        IF Visited = VOID THEN
          Visited.CREATE;
          END;
        IF Visited.Includes (Cl) THEN
          Inherits.Error ("Cyclic inheritance relationship");
          GoOn := FALSE;
         ELSE
          Visited.Add (Cl);
          Cl.Inherits.UniqueTag;
          Cl := Cl.Inherits.Class;
          IF (Cl <> VOID) THEN
            Cl.Consts.Enter; 
            END;
          END;
        END;
      END EnterInheritedConsts;
      
    METHOD EnterInheritedSymbols;
      VAR
        Cl: ClassDeclaration;
      BEGIN
      IF (Inherits <> VOID) THEN
        ASSERT Inherits.IsTagged;
        Cl := Inherits.Class;
        IF (Cl <> VOID) THEN
          Cl.EnterInheritedSymbols;
          Cl.Methods.Enter;
          Cl.Consts.Enter; 
          WHAT Cl OF
            IN ClassImplementation:
              IF TAG.Definition <> VOID THEN
                TAG.Definition.EnterDeferred;
                END;
              END;
           ELSE
            END;
          END;
        END;
      END EnterInheritedSymbols;

    METHOD EnterFormalClasses;
      BEGIN
      IF TheClassFormals <> VOID THEN
        This.GetType.Actuals.Enter;
        END;
      END EnterFormalClasses;

    VAR
      ConstrainedList: NTList(ConstrainedClassDecl);

    ----------------------------------
    -- Redefine the ClearGc method in such
    -- a way that the attached constrained class
    -- declarations are cleaned as well
    ----------------------------------

    REDEFINE METHOD ClearGc;
      BEGIN 
      BASE;
      FOR Cons IN ConstrainedList DO
        Cons.ClearGc;
        END; 
      END ClearGc;


    METHOD MakeConstrainedClass (Actuals: ClassActualSet):
                                           ConstrainedClassDecl;
      BEGIN
      ASSERT THIS = Canonic;
      IF ConstrainedList = VOID THEN
        ConstrainedList.CREATE;
        END;
      FOR Curr IN ConstrainedList WHILE RESULT = VOID DO
        IF Actuals = Curr.Actuals THEN
          RESULT := Curr;
         ELSIF (Actuals <> VOID) AND (Curr.Actuals <> VOID) THEN
          ASSERT Actuals.ActualList.Size = Curr.Actuals.ActualList.Size;
          IF Actuals.Match (Curr.Actuals) THEN
            RESULT := Curr;
            END;
          END;
        END;
      IF RESULT = VOID THEN
        RESULT.CREATE (THIS, Actuals);
        IF Actuals <> VOID THEN
          Actuals.SetConstrained (RESULT);
          END;
        ConstrainedList.Append (RESULT);
        END;
      END MakeConstrainedClass;
      
    METHOD MakeConstrainedType(ArrayLevel: INTEGER;
                               Actuals: ClassActualSet): Type;
      VAR
        TheConstrainedClass: ConstrainedClassDecl;
      BEGIN
      ASSERT THIS = Canonic;
      TheConstrainedClass := MakeConstrainedClass (Actuals);
      RESULT := TheConstrainedClass.MakeType (ArrayLevel);
      END MakeConstrainedType;

    METHOD MakeType (ArrayLevel: INTEGER): Type;
      BEGIN
      RESULT := Canonic.MakeConstrainedType (ArrayLevel, VOID);
      END MakeType;

    METHOD MakeClassType: Type;
      BEGIN
      IF ClassFormals = VOID THEN
        RESULT := Canonic.MakeType(0);
       ELSE
        RESULT := Canonic.MakeConstrainedType(0, 
                  ClassFormals.ToVirtualActualSet);
        END;
      END MakeClassType;
      
    METHOD Compatible (Other: ClassDeclaration): BOOLEAN;
      BEGIN
      IF Other = THIS THEN
        RESULT := TRUE;
       ELSIF Other <> VOID THEN
        WHAT Other OF
          IN ClassImplementation:
            IF TAG.Definition <> VOID THEN
              RESULT := Compatible (TAG.Definition);
              END;
            END;
          IN VirtualClassDecl:
            IF TAG.FormalRef <> VOID THEN
              RESULT := Compatible (TAG.FormalRef.LimitingClass);
              END;
            END;  
         ELSE
          END;
        IF (NOT RESULT) AND (Other.Inherits <> VOID) THEN
          RESULT := Compatible(Other.Inherits.Class);
          END;
        END;
      END Compatible;

    METHOD Match (Other: ClassDeclaration): BOOLEAN;
      BEGIN
      RESULT := (Other = THIS);
      ASSERT Other <> VOID;
      IF NOT RESULT THEN
        WHAT Other OF
          IN ClassImplementation:
            RESULT := TAG.Match (THIS);
            END;
         ELSE
          END;
        END;
      END Match;

    METHOD Create: MethodDeclaration;
      VAR
        Decl: Declaration;
      BEGIN
      Decl := GetDecl (PredefItems.Create.Id.Data);
      IF Decl <> VOID THEN
        WHAT Decl OF
          IN MethodDeclaration:
            RESULT := TAG;
            END;
          END;
        END;
      IF RESULT = VOID THEN
        RESULT := PredefItems.Create;
        END;
      END Create;
      
    METHOD NoChange: MethodDeclaration;
      BEGIN
      RESULT := PredefItems.NoChange;
      END NoChange;
      
    METHOD NeedsConstructFunc: BOOLEAN;
      BEGIN
      RESULT := IsParameterized OR
                ((BaseClass <> VOID) AND BaseClass.NeedsConstructFunc);
      END NeedsConstructFunc;
      
    METHOD Pragmas: DeclList(Pragma);
      BEGIN
      RESULT := ThePragmaList;
      END Pragmas;
      
    METHOD Methods: MethodList(MethodComponent);
      BEGIN
      RESULT := TheMethodsList;
      END Methods;
      
    METHOD Consts: DeclList(ConstDeclaration);
      BEGIN                    
      RESULT := TheConstsList;
      END Consts;
      
    METHOD Invariants: NTList(ClassInvariant);
      BEGIN
      RESULT := TheInvariantList;
      END Invariants;
      
    METHOD BaseClass: ClassDeclaration;
      BEGIN
      IF Inherits <> VOID THEN
        RESULT := Inherits.Class;
        END;
      END BaseClass;
        
    METHOD InheritanceDepth: INTEGER;
      VAR   
        Cl: ClassDeclaration;
      BEGIN
      Cl := THIS;
      WHILE Cl <> VOID DO
        RESULT := RESULT + 1;
        Cl := Cl.BaseClass;
        END;      
      END InheritanceDepth;
      
    METHOD InheritanceChain: ARRAY OF ClassDeclaration;
      VAR
         Depth: INTEGER;
        Cl: ClassDeclaration;
      BEGIN
      ASSERT InheritanceDepth > 0;
      Depth := InheritanceDepth - 1;
      IF Depth <> 0 THEN
        RESULT.CREATE (Depth);
        Cl := BaseClass;
        FOR i := 0 TO Depth - 1 DO
          ASSERT Cl <> VOID;
          RESULT [i] := Cl;
          Cl := Cl.BaseClass;
          END;
        ASSERT Cl = VOID;
        END;
      END InheritanceChain;
      
    VAR
      TheThis: ThisDataItem;
      TheThisType: Type;
      
    METHOD ThisType: Type;
      VAR
        ActSet: ClassActualSet;
      BEGIN          
      ----------------------------------------
      -- build the type of THIS
      ----------------------------------------
      IF TheThisType = VOID THEN
        IF ClassFormals = VOID THEN
          TheThisType := Canonic.MakeType (0);
         ELSE
          ActSet := ClassFormals.ToVirtualActualSet;
          TheThisType := Canonic.MakeConstrainedType (ArrayLevel := 0, ActSet);
          END;
        END;
      RESULT := TheThisType;
      END ThisType;
      
    METHOD This: ThisDataItem;
      BEGIN
      IF TheThis = VOID THEN
        TheThis := PredefItems.This.CLONE;
        TheThis.SetType (ThisType);
        IF ThisType.Actuals <> VOID THEN
          FOR Act IN ThisType.Actuals.ActualList.Row DO
            WHAT Act.Class OF
              IN VirtualClassDecl:
                TAG.SetDataItemRef (TheThis);
                END;
              END;
            END;
          END;
        END;
      RESULT := TheThis;
      END This;
      
    METHOD Canonic: ClassDeclaration;
      BEGIN
      RESULT := THIS;
      END Canonic;
              
    -----------------------------------------
      
    VAR
      TheRef: ClassReference;
      
    METHOD Reference: ClassReference;
      BEGIN                        
      IF TheRef = VOID THEN
        TheRef := ClassDictionary.FindClass (Module.Id.Data,Id.Data);
        END;
      RESULT := TheRef;
      END Reference;
      
    METHOD EnterInDictionary;
        
      METHOD KeepDual(Cl: ClassDeclaration);
        BEGIN   
        IF Cl <> VOID THEN
          WHAT Cl OF
            IN VirtualClassDecl:
              END;
           ELSE
            Cl.Reference.DoKeepDual;           
            END;
          END;
        END KeepDual;
           
      BEGIN
      Reference.SetState (State);       
      
      IF IsTagged THEN     
        IF BaseClass <> VOID THEN
          Reference.SetBaseClass (ClassDictionary.FindClass(
                                  BaseClass.Module.Id.Data,
                                  BaseClass.Id.Data));
          END;
        IF ClassFormals <> VOID THEN  
          FOR Form IN ClassFormals.FormalList DO  
            KeepDual(Form.LimitingClass);
            END;
          END;  
          
        IF Inherits <> VOID THEN
          FOR Act IN Inherits.ActualClasses DO
            KeepDual(Act);
            END; 
          END;
        END;
      
      FOR Meth IN Methods DO
        CurrentSpot.PushCurrentMethod(Meth);
        Meth.EnterInDictionary;
        CurrentSpot.PopCurrentMethod;
        END;
  
      FOR Const IN Consts DO
        Const.EnterInDictionary (THIS);
        END;

      END EnterInDictionary;             
         
    -----------------------------------------
                         
    METHOD ConstrainedReturn (Meth: MethodDeclaration): Type;
      VAR
        Decl: Declaration;
        Cl: ClassDeclaration;
      BEGIN
      ASSERT Meth.Return <> VOID;
      Cl := THIS;
      WHILE (Cl <> VOID) AND (RESULT = VOID) DO
        Decl := Cl.GetLocalDecl (Meth.Id.Data);
        IF Decl <> VOID THEN
          WHAT Decl OF
            IN MethodDeclaration:
              IF TAG.Redefine AND TAG.ConstrainedRedefinition THEN
                RESULT := TAG.Return;
                END;
              END;
            END;
          END;
        Cl := Cl.BaseClass;
        IF Cl <> VOID THEN
          Cl := Cl.Canonic;
          END;
        END;
      IF RESULT = VOID THEN
        RESULT := Meth.Return;
        END;
      END ConstrainedReturn;

    METHOD Public: BOOLEAN;
      BEGIN
      RESULT := TRUE;
      END Public;
      
    METHOD ClosestCanonic: ClassDeclaration;
      BEGIN             
      RESULT := Canonic;
      END ClosestCanonic;
      
    METHOD DeleteMethod (El : MethodComponent);
      BEGIN
      SubDecls.DeleteElement (El);
      END DeleteMethod;
      
    METHOD Removed: BOOLEAN;
      BEGIN       
      RESULT := (YaflCfg.PleaseGlobalOptimize) AND 
                (Module <> VOID) AND Reference.Removed;
      END Removed;

    METHOD Publish: BOOLEAN;
      BEGIN
      RESULT := THERE_IS Meth IN Methods :- Meth.Publish;
      END Publish;

  END ClassDeclaration;
----------------------------------------

  CLASS ConstrainedClassDecl;
    INHERITS Declaration(DeclarationCodeGenerator);

    VAR
      TheSimpleType: ClassDeclaration;
      TheClassActuals: ClassActualSet;
      
    METHOD Image: ARRAY OF CHAR;
      BEGIN
      RESULT := TheSimpleType.Image;
      IF TheClassActuals <> VOID THEN
        RESULT := RESULT + '(';
        FOR i := 0 TO TheClassActuals.Size - 1 DO
          IF i <> 0 THEN
            RESULT := RESULT + ',';
            END;
          RESULT := RESULT + TheClassActuals.ActualList.Get(i).Class.Image;
          END;
        RESULT := RESULT + ')';
        END;
      END Image;

    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      END SubTree;

    REDEFINE METHOD Parse(Lkh: LookAhead);
      BEGIN
      END Parse;

    METHOD SimpleType: ClassDeclaration;
      BEGIN
      RESULT := TheSimpleType;
      END SimpleType;

    METHOD Actuals : ClassActualSet;
      BEGIN
      RESULT := TheClassActuals;
      END Actuals;

    REDEFINE METHOD CREATE (SimpleType: ClassDeclaration;
                            Actuals: ClassActualSet);
      BEGIN
      ASSERT SimpleType <> VOID;
      BASE(0,0);
      TheClassActuals := Actuals; 
      IF Actuals <> VOID THEN
        Actuals.SetConstrained (THIS);
        END;
      TheSimpleType := SimpleType;
      END CREATE;

    REDEFINE METHOD WhatAmI: ARRAY OF CHAR;
      BEGIN
      RESULT := "ConstrainedClassDecl(" + SimpleType.WhatAmI + ":" +
                SimpleType.Id.Data + ")";
      END WhatAmI;
      
    METHOD SetActual (Actuals: ClassActualSet);
      BEGIN
      TheClassActuals := Actuals;
      Actuals.SetConstrained (THIS);
      END SetActual;
      
    METHOD Compatible (Other: ConstrainedClassDecl): BOOLEAN;
      VAR
        OtherActual: ClassActualSet;
      BEGIN
      ASSERT (TheSimpleType <> VOID) AND (Other.SimpleType <> VOID);
      ---------------------------------------------------------
      -- First, check the compatibility between the SimpleTypes
      ---------------------------------------------------------             
      RESULT := TheSimpleType.Compatible(Other.SimpleType);
      IF RESULT THEN                                           
        ----------------------------------------------------------
        -- If the SimpleTypes are compatible, we check the Actuals
        ----------------------------------------------------------
        IF (TheClassActuals <> VOID) AND IsConstrained THEN
          ----------------------------------------------------
          -- Find the correct value for the Actuals if the
          -- second class is a derived class from the first
          ----------------------------------------------------
          OtherActual := Other.GetActual(TheSimpleType);
          ASSERT OtherActual <> VOID;
          ASSERT TheClassActuals.Size = OtherActual.Size;
          -----------------------------------------------------
          -- To be compatible, the two parameters must either
          -- be equal or the first one must be an unconstrained type
          -----------------------------------------------------
          RESULT := TheClassActuals.Match (OtherActual);
          END; 
        END;
      END Compatible;
      
    METHOD Match (Other: ConstrainedClassDecl): BOOLEAN;
      BEGIN                                                  
      --------------------------------------
      -- First, the SimpleTypes are matched
      --------------------------------------
      IF (TheSimpleType <> VOID) AND (Other <> VOID) AND
         (Other.SimpleType <> VOID) THEN
        RESULT := TheSimpleType.Match(Other.SimpleType);
        IF RESULT THEN                       
          ----------------------------------------------------
          -- Then the actual parameters are matched two by two
          ----------------------------------------------------
          IF NOT (TheClassActuals = VOID IFF Other.Actuals = VOID) THEN
            RESULT := FALSE;
           ELSIF TheClassActuals <> VOID THEN
            IF IsConstrained THEN
              IF TheClassActuals.Size <> Other.Actuals.Size THEN
                RESULT := FALSE;
               ELSE 
                RESULT := TheClassActuals.Match (Other.Actuals);
                END;
              END;
            END;
          END;
        END;
      END Match;
    
    VAR
      TypeArray: ARRAY OF Type;

    METHOD MakeType (ArrayLevel: INTEGER): Type;
      CONST
        MaxArray = 12;
      VAR  
        Tmp: InstType;
      BEGIN
      ASSERT ArrayLevel < MaxArray;
      ASSERT ArrayLevel >= 0;
      IF TypeArray = VOID THEN
        TypeArray.CREATE (MaxArray);
        END;
      IF TypeArray[ArrayLevel] <> VOID THEN
        RESULT := TypeArray[ArrayLevel];
       ELSE
        Tmp.CREATE(0, 0);
        RESULT := Tmp;
        RESULT.Set (THIS, ArrayLevel);
        TypeArray[ArrayLevel] := RESULT;
        END;
      END MakeType;

    --------------------------------------------
    -- ClearGC is redefined in order to remove the
    -- code generators attached to the array
    -- of types attached to THIS
    --------------------------------------------
    REDEFINE METHOD ClearGc;
      BEGIN
      BASE;
      FOR t IN TypeArray | t <> VOID DO
        t.ClearGc;
        END;
      END ClearGc;

    --------------------------------------------
    -- Build the structure which will hold the
    -- value of the ClassFormal parameter.
    --------------------------------------------
    VAR
      ParamArray: ARRAY OF ClassActualSet;
      Asked: BOOLEAN;

    METHOD Dump;
      VAR
        ClassDecl: ClassDeclaration;
      BEGIN
      StdOut.WriteLn;
      StdOut.WriteLine ("ConstrainedClassDecl:" + SimpleType.Image);
      ClassDecl := SimpleType;                        
      FOR i := 0 TO ParamArray.SIZE - 1 DO
        IF ClassDecl <> VOID THEN
          StdOut.WriteLine("  " + ClassDecl.Image);
         ELSE
          StdOut.WriteLine("  VOID Class");
          END;
        IF ParamArray[i] = VOID THEN
          StdOut.WriteLine ("    VOID");
         ELSE
          FOR j := 0 TO ParamArray[i].ActualList.Size - 1 DO
            StdOut.WriteLine ("    " + ParamArray[i].ActualList.
                                       Get(j).Class.Image);
            END;
          END;
        IF ClassDecl <> VOID THEN
          ClassDecl := ClassDecl.BaseClass;
          END;
        END;
      END Dump;
      
    METHOD BuildActualStructure : BOOLEAN;
      VAR
         k: INTEGER;
        ClassDecl: ClassDeclaration;
        ActualList: NTList(ClassActual);
        CurrentActual: ClassActual;
        GoOn: BOOLEAN;
        
        METHOD FindVirtual (FormalList: NTList(ClassFormal);
                            Virt: VirtualClassDecl): INTEGER;
          BEGIN
          RESULT := FIRST i IN 0 TO FormalList.Size - 1 :-
                           FormalList.Get(i) = Virt.FormalRef;
          END FindVirtual;
          
      BEGIN    
      ----------------------------------
      -- Each structure is memorized,
      -- so that it is built only once.
      ----------------------------------
      RESULT := TRUE;
      IF NOT Asked THEN
        Asked := TRUE;
        GoOn := TRUE;
        ParamArray.CREATE (SimpleType.InheritanceDepth);      
        ------------------------------------------------
        -- We initialise the structure 
        -- with the Actuals of this ConstrainedClassDecl
        ------------------------------------------------
        IF TheClassActuals <> VOID THEN
          ParamArray [0] := TheClassActuals;
          END;  
        ClassDecl := SimpleType;                        
        --------------------------------------
        -- Complete each level of the structure
        -- by following the inheritance chain
        --------------------------------------
        FOR i := 1 TO ParamArray.SIZE - 1 WHILE GoOn DO
          IF (ClassDecl.Inherits <> VOID) AND
             (ClassDecl.Inherits.Actuals <> VOID) THEN
            ActualList := ClassDecl.Inherits.Actuals.ActualList;
            ParamArray[i].CREATE (0, 0);  
            ---------------------------------------
            -- Find the values for the ClassFormal of this level
            ---------------------------------------
            FOR j := 0 TO ActualList.Size - 1 WHILE GoOn DO
              ---------------------------------------
              -- If the parameter of the inheritance clause 
              -- refers to a ClassFormal, its value is found
              -- from the previous level of the structure.  
              -- Its position corresponds to the ClassFormal.
              ---------------------------------------
              CurrentActual := ActualList.Get(j);
              WHAT CurrentActual.Class OF
                IN VirtualClassDecl:
                  ASSERT ClassDecl.ClassFormals <> VOID;
                  k := FindVirtual (ClassDecl.ClassFormals.FormalList, TAG);
                  ASSERT k >= 0;
                  IF (ParamArray[i-1] <> VOID) AND
                     (k < ParamArray[i-1].Size) AND
                     (ParamArray[i-1].ActualList.Get(k) <> VOID) THEN
                    ParamArray[i].ActualList.Append (
                      ParamArray[i-1].ActualList.Get(k));
                   ELSE
                    DEBUG
                      Dump;
                      END;
                    Error ("Error while building class actuals");
                    GoOn := FALSE;
                    RESULT := FALSE;
                    END;
                  END;
               ELSE
                ParamArray[i].ActualList.Append (CurrentActual.CLONE);
                END;
              END;
            END;
          ClassDecl := ClassDecl.BaseClass;
          END;
        END;
      END BuildActualStructure;

    ----------------------------------------------
    -- Find the correct value of each ClassActual
    -- of this ConstrainedClassDecl depending on 
    -- a specified context.
    ----------------------------------------------
    METHOD CheckActuals (Context: ConstrainedClassDecl): ClassActualSet;
      VAR 
        Modif: BOOLEAN;
        ActClassArr,
        TempArr: ARRAY OF ClassActual;
      BEGIN                                                 
      IF TheClassActuals <> VOID THEN
        RESULT.CREATE (0, 0);
        ActClassArr := TheClassActuals.ActualList.Row;
        TempArr := ActClassArr.CLONE;
        FOR i := 0 TO TempArr.SIZE - 1 DO
          WHAT ActClassArr[i].Class OF
            IN VirtualClassDecl:
              ASSERT TAG.Constrained <> VOID;
              IF TAG.Constrained <> THIS THEN
                ----------------------------------
                -- If the ClassActual refers to a ClassFormal,
                -- we find its correct value inside the
                -- structure initialized by Context.
                ---------------------------------- 
                TempArr[i].CREATE (RESULT, 0, 0);
                TempArr[i].SetClass (Context.ParameterValue (TAG));
                Modif := TRUE;
                END;
              END;  
           ELSE
            END;
          END;
        IF Modif THEN
          RESULT.SetFromArray (TempArr);
         ELSE
          RESULT := VOID;
          END;
        END;
      END CheckActuals;

    -----------------------------------------------
    -- Returns the actual class provided as parameter
    -- corresponding to Virtual somewhere in the
    -- inheritance chain attached to THIS.
    -----------------------------------------------
    METHOD GetFormalValue (Formal: ClassFormal): ClassDeclaration;
      VAR
        ClassLevel, ParamLevel: INTEGER;  
        ClassDecl: ClassDeclaration;
        FormalList: NTList(ClassFormal);
        Continue: BOOLEAN;
        
        ----------------------------
        -- The SkipToNext method follows 
        -- the inheritance chain starting at
        -- ClassDecl, until it refers
        -- to a parametrized class.
        ----------------------------
        METHOD SkipToNext;
          BEGIN
          WHILE ClassDecl.ClassFormals = VOID DO
            ClassDecl := ClassDecl.BaseClass;
            ASSERT ClassDecl <> VOID;
            ClassLevel := ClassLevel + 1;
            END;
          ASSERT ClassLevel < ParamArray.SIZE;
          END SkipToNext;
        
      BEGIN
      IF BuildActualStructure THEN
        ClassDecl := SimpleType;
        SkipToNext;
        DEBUG
          IF ClassDecl.ClassFormals = VOID THEN
            StdOut.WriteLine ("Looking for formals in class: " + 
                                  ClassDecl.Id.Data);
            ASSERT FALSE;
            END;
          END;
        ParamLevel := 0;
        FormalList := ClassDecl.ClassFormals.FormalList;
        Continue := TRUE;
        WHILE (RESULT = VOID) AND Continue DO
          ASSERT FormalList.Get(ParamLevel) <> VOID;
          IF FormalList.Get(ParamLevel) = Formal THEN
            IF ParamArray [ClassLevel] = VOID THEN
              Continue := FALSE;
             ELSE
              ASSERT ParamArray [ClassLevel].ActualList <> VOID;
              ASSERT ParamArray [ClassLevel].ActualList.Get(ParamLevel) <> VOID;
              RESULT := ParamArray [ClassLevel].ActualList.
                        Get(ParamLevel).Class;
              END;
           ELSIF ParamLevel < FormalList.Size - 1 THEN
            ParamLevel := ParamLevel + 1;
           ELSE 
            --------------------------------------------
            -- Try next class, reset ParamLevel to zero
            --------------------------------------------
            ParamLevel := 0;
            ClassLevel := ClassLevel + 1;
            ASSERT ClassLevel < ParamArray.SIZE;
            ASSERT ClassDecl.Inherits <> VOID;
            ClassDecl := ClassDecl.Inherits.Class;
            -------------------------------------------
            -- Follow the chain, as long as there is no 
            -- formal parameter defined.
            -------------------------------------------
            SkipToNext;
            FormalList := ClassDecl.ClassFormals.FormalList;
            END;
          END;
        END;
      END GetFormalValue;
      
    -----------------------------------------------
    -- Returns the actual class provided as parameter
    -- corresponding to Virtual somewhere in the
    -- inheritance chain attached to THIS.
    -----------------------------------------------
    METHOD ParameterValue (Virtual: VirtualClassDecl): ClassDeclaration;
      BEGIN
      RESULT := GetFormalValue (Virtual.FormalRef);
      END ParameterValue;
    
    METHOD GetActual(ClassDecl: ClassDeclaration): ClassActualSet;
      VAR
        Ind: INTEGER;
        CurClass: ClassDeclaration;
      BEGIN
      CurClass := SimpleType;
      WHILE NOT CurClass.Match(ClassDecl) DO
        DEBUG
          IF CurClass.BaseClass = VOID THEN
            StdErr.WriteLine ("Cannot find: " + ClassDecl.Id.Data + "/" +
                                                SimpleType.Id.Data);
            ASSERT FALSE;
            END;
          END;
        CurClass := CurClass.BaseClass;
        ASSERT CurClass <> VOID;
        Ind := Ind + 1;
        END;
      IF BuildActualStructure THEN
        RESULT := ParamArray[Ind];
        END;
      END GetActual;
      
    METHOD BuildContextual (Context: ConstrainedClassDecl): 
                                           ConstrainedClassDecl;
      VAR
        SimpleClass: ClassDeclaration;
        TheActuals: ClassActualSet;
      BEGIN
      WHAT TheSimpleType OF
        IN VirtualClassDecl:
          ASSERT Context <> VOID;
          SimpleClass := Context.ParameterValue(TAG);
          IF SimpleClass = VOID THEN
            --------------------------------------------
            -- At this stage, we simply have no idea of how to
            -- produce a sensible ConstrainedClassDecl, since
            -- we cannot deduce the actual parameter for the
            -- virtual class declaration. Hence, we simply
            -- refer to the default, senseless ConstrainedClassDecl
            -- we can attach to the VirtualClassDecl, assuming that
            -- the only significant operation one can perform on
            -- this ConstrainedClassDecl is to take advantage of
            -- a possible limiting clause.
            --------------------------------------------
            -- RESULT := 
           ELSE
            ------------------------------------------------
            -- If SimpleType refers to a parametric class,
            -- we create VirtualClassDecl for the Actuals
            ------------------------------------------------
            IF SimpleClass.ClassFormals <> VOID THEN
              RESULT.CREATE (SimpleClass, 
                             SimpleClass.ClassFormals.ToVirtualActualSet);
             ELSE   
              RESULT := SimpleClass.MakeConstrainedClass(VOID);
              END;
            END;
          END;   
       ELSE
        TheActuals := CheckActuals(Context);
        IF TheActuals = VOID THEN
          RESULT := THIS; 
         ELSE
          RESULT := TheSimpleType.MakeConstrainedClass(TheActuals);
          END;
        END;      
      END BuildContextual;
      
    ---------------------------------------
    -- The IsConstrained method returns FALSE if THIS refers
    -- to a parameterized class, where the actuals are
    -- virtual classes attached to itself.
    ---------------------------------------
    METHOD IsConstrained: BOOLEAN;
      VAR
        Cl: ClassDeclaration;
      BEGIN
      RESULT := TRUE;
      IF (TheClassActuals <> VOID) AND (TheClassActuals.Size > 0) THEN
        Cl := TheClassActuals.ActualList.Get(0).Class;
        IF Cl <> VOID THEN
          WHAT Cl OF
            IN VirtualClassDecl:
              IF TAG.Constrained = THIS THEN
                RESULT := FALSE;
                END;
              END;
           ELSE
            END;
          END;
        END;
      END IsConstrained;

  END ConstrainedClassDecl;
----------------------------------------
  CLASS VirtualClassDecl;
       ----------------------------------------
       -- The Actual classes provided here are of little
       -- value, since a virtual class declaration holds
       -- no method-like components, and is not enclosed within
       -- any specific kind of CompilationUnit.
       ----------------------------------------
    INHERITS ClassDeclaration(MethodDeclaration,
                              CompilationUnit,
                              VirtualClassDeclCodeGenerator); 
    VAR
      TheActualRef: ClassActual;
      TheDataItemRef: SingleDataItem;
      TheNr: INTEGER;
      
    REDEFINE METHOD BaseClass: ClassDeclaration;
      BEGIN
      IF FormalRef <> VOID THEN
        RESULT := FormalRef.LimitingClass;
        END;
      END BaseClass;
         
    REDEFINE METHOD WhatAmI: ARRAY OF CHAR;
      BEGIN
      RESULT := "VirtualClassDecl";
      END WhatAmI;  
      
    REDEFINE METHOD Image: ARRAY OF CHAR;
      BEGIN
      RESULT := "Virtual(" + IntConversions.IntToString (TheNr, 0) + ')';
      IF FormalRef <> VOID THEN
        RESULT := RESULT + "(" + FormalRef.Set.Class.Image + ")";
        END;
      IF TheDataItemRef <> VOID THEN
        RESULT := RESULT + '->' + TheDataItemRef.Id.Data;
        END;
      END Image;  
      
    REDEFINE METHOD Compatible (Other: ClassDeclaration): BOOLEAN;
      BEGIN
      RESULT := Other = THIS;
      END Compatible;  

    REDEFINE METHOD Match(Other: ClassDeclaration): BOOLEAN;
      BEGIN 
      RESULT := Other = THIS;
      END Match;
      
    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      END SubTree;

    REDEFINE METHOD Parse(Lkh: LookAhead);
      BEGIN
      END Parse;

    REDEFINE METHOD CREATE (ActualReference: ClassActual);
      VAR
        Counter: ONCE INTEGER;
      BEGIN
      BASE(0,0);
      TheActualRef := ActualReference;
      Counter := Counter + 1;
      TheNr := Counter;
      END CREATE;
                    
    METHOD FormalRef: ClassFormal;
      BEGIN
      RESULT := ActualRef.Formal;
      END FormalRef;
      
    REDEFINE METHOD Id: Ident;  
      BEGIN
      RESULT := FormalRef.Id;
      END Id;
        
    METHOD SetDataItemRef(DataItem: SingleDataItem);
      BEGIN
      TheDataItemRef := DataItem;
      END SetDataItemRef;
    
    METHOD GetDataItemRef: SingleDataItem;
      BEGIN
      RESULT := TheDataItemRef;
      END GetDataItemRef;
      
            
    -------------------------------
    -- Searching for a declaration in a virtual
    -- class declaration happens by calling its
    -- attached formal; which will check whether 
    -- it has been limited or not.
    -------------------------------
    REDEFINE METHOD GetDecl (IdSearched: ARRAY OF CHAR): Declaration;
      BEGIN
      IF FormalRef <> VOID THEN
        RESULT := FormalRef.GetDecl (IdSearched);
        END;
      END GetDecl;    
      
    METHOD ActualRef: ClassActual;
      BEGIN
      RESULT := TheActualRef;
      END ActualRef;
      
    METHOD Constrained: ConstrainedClassDecl;
      BEGIN
      RESULT := ActualRef.Set.Constrained;
      END Constrained;
      
    METHOD Nr: INTEGER;
      BEGIN  
      RESULT := TheNr;
      END Nr;   
      
    REDEFINE METHOD ClosestCanonic: ClassDeclaration;
      BEGIN  
      IF FormalRef <> VOID THEN
        IF FormalRef.LimitingClass <> VOID THEN
          RESULT := FormalRef.LimitingClass.Canonic;
          END;           
        END;
      END ClosestCanonic;
      
    END VirtualClassDecl;

----------------------------------------

END YaflClasses;
