IMPLEMENTATION MODULE YaflDeclarations;

FROM YaflLex IMPORT LexicalAnalyzer;
FROM Linked IMPORT LinkedList;
IMPORT ModuleTable;
IMPORT Ref;
FROM Streams IMPORT StdOut;
FROM YaflSymbols IMPORT SymbolTable;
FROM YaflCfg IMPORT YaflCfg, CurrentSpot;
FROM YaflMethods IMPORT MethodDeclaration;
FROM YaflModules IMPORT DefinitionModule;
FROM YaflClasses IMPORT ClassDeclaration, VirtualClassDecl;
FROM YaflClDefinition IMPORT ClassDefinition;  
FROM YaflClImplementation IMPORT ClassImplementation;
FROM YaflNTList IMPORT NTList;
FROM YaflParamClasses IMPORT ClassActual, ClassFormalSet;
FROM YaflPragmas IMPORT InlineConstPragma, VisibleFieldPragma;
FROM YaflPredefined IMPORT PredefClass;
FROM YaflStatements IMPORT Assignment;

FROM YaflDictionary IMPORT ClassReference,
                           ConstReference,
                           ConstDictionary, 
                           AttributeReference,
                           AttributeDictionary; 
                           
  CLASS InheritsClause;
    INHERITS NonTerminal(DummyNTCodeGenerator);

    VAR
      TheQualId: QualIdent;
      TheClassActual: ClassActualSet; 

    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      VAR
        Used: INTEGER;
      BEGIN
      RESULT.CREATE (3);
      RESULT[0] := TheQualId;
      Used := 1;
      IF TheClassActual <> VOID THEN
        RESULT[Used] := TheClassActual;
        Used := Used + 1;
        END;
      RESULT := RESULT.SLICE (0, Used);
      END SubTree;

    REDEFINE METHOD Parse(Lkh: LookAhead);
      BEGIN
      Lkh.Accept (LexicalAnalyzer.Inherits);
      TheQualId := Lkh.AcceptQualIdent;
      SetSon (TheQualId);
      TheClassActual := Lkh.AcceptClassActuals;
      SetSon (TheClassActual);            
      IF Lkh.CurrentToken = Lkh.Hide THEN
        Warning ("HIDE clauses are obsolete and ignored");
        Lkh.GetToken;
        VOID := Lkh.AcceptIdentList;
        END;
      Lkh.Accept (LexicalAnalyzer.SemiColon);
      END Parse;

    REDEFINE METHOD Tag;
      VAR
        Cl: ClassDeclaration;
      BEGIN
      IF QualId <> VOID THEN
        QualId.UniqueTag;
        ----------------------------------------
        -- Tag the Actual parameters and
        -- compare the Actuals with the
        -- Formals of the inherited class
        ----------------------------------------
        Cl := QualId.GetRef;
        IF Cl <> VOID THEN
          WHAT Cl OF
            IN PredefClass:
              Error ("Cannot inherit from a predefined type");
              END;
           ELSE
            IF Cl.Once THEN
              Error ("Cannot inherit from a ONCE class");
             ELSIF TheClassActual <> VOID THEN
              TheClassActual.UniqueTag;
              END;
            END;
         ELSE
          DEBUG
            Error ("Inheritance TAG failure: " + QualId.FirstIdent.Data);
            END;
          END;
        END;
      END Tag;

    REDEFINE METHOD CheckType;
      VAR
        Cl: ClassDeclaration;
        ClFormals: ClassFormalSet;
      BEGIN
      Cl := Class;
      IF Cl <> VOID THEN
        ClFormals := Cl.ClassFormals;
        IF ClFormals <> VOID THEN
          IF NOT ClFormals.MatchClassActuals (TheClassActual) THEN
            Error ("Parameterized class mismatch");
            END;
         ELSIF NOT (TheClassActual = VOID) THEN
          Error ("Class arity error");
          END;
        END;
      END CheckType;

    METHOD QualId: QualIdent;
      BEGIN
      RESULT := TheQualId;
      END QualId;

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

    METHOD Class: ClassDeclaration;
      VAR
        Ref: NonTerminal;
      BEGIN
      UniqueTag;
      ASSERT IsTagged;
      Ref := QualId.GetRef;
      IF Ref <> VOID THEN
        WHAT Ref OF
          IN ClassDeclaration:
            RESULT := TAG;
            END;
         ELSE
          DEBUG
            StdOut.WriteInt (LineNr, 5);
            StdOut.WriteString ("  QualId.Last: " + QualId.LastIdent.Data);
            StdOut.WriteLn;
            ASSERT FALSE;
            END;
          END;
        END;
      END Class;

    REDEFINE METHOD WhatAmI: ARRAY OF CHAR;
      BEGIN
      RESULT := "InHeritsClause";
      END WhatAmI;

--    METHOD HideClause: IdentList;
--      BEGIN
--      RESULT := TheHideClause;
--      END HideClause;

    METHOD Match (Other: InheritsClause);
      BEGIN
      IF NOT Class.Match (Other.Class) THEN
        Error ("Inheritance relationship differs from the definition[2]");
       ELSE
        IF NOT (Actuals = VOID IFF Other.Actuals = VOID) THEN
          Error ("Inheritance relationship differs from the definition[3]");
         ELSIF Actuals <> VOID THEN
          IF NOT Actuals.Match(Other.Actuals) THEN
            Error ("Inheritance relationship differs from the definition[4]");
            END;
          END;
        END;
      END Match;

    METHOD ActualClasses: ARRAY OF ClassDeclaration;
      VAR 
         Size: INTEGER;
        ActList: NTList(ClassActual);
      BEGIN
      IF TheClassActual <> VOID THEN
        ActList := TheClassActual.ActualList;
        Size := ActList.Size;
        RESULT.CREATE(Size);
        FOR i := 0 TO Size - 1 DO
          RESULT [i] := ActList.Get(i).Class;
          END;
        END;
      END ActualClasses;
        
  END InheritsClause;

----------------------------------------
  CLASS Declaration(gc IN DeclarationCodeGenerator);
    INHERITS NonTerminal(gc);

    VAR
      PragList: List(Pragma);
      
    REDEFINE METHOD CREATE (LineNr, ColNr: INTEGER);
      BEGIN
      BASE (LineNr, ColNr);
      END CREATE;
      
    METHOD SubDecls: MultiDeclList;
      BEGIN 
      -- Default behaviour is to return VOID
      END SubDecls;
      
    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      RESULT.CREATE (1);
      RESULT[0] := SubDecls;
      END SubTree;
      
    METHOD AttachPragma (Prag: Pragma);
      BEGIN            
      IF PragList = VOID THEN
        PragList.CREATE;
        END;
      PragList.Append (Prag);
      END AttachPragma;      
      
    METHOD PragmaList: List(Pragma);
      BEGIN          
      RESULT := PragList;
      END PragmaList;
    
    METHOD Enter;
      BEGIN
      SymbolTable.Enter(Id.Data, THIS);
      Id.SetRef (THIS);
      END Enter;

----------------------------------------------------      
-- Searches FirstDecl and nexts
-- for all the elements which match
-- the class of the elements which
-- can be stored in TheList, and
-- stores them.
----------------------------------------------------
    METHOD GrabDeclarations (TheList: List);  
      BEGIN
      IF SubDecls <> VOID THEN
        SubDecls.GrabDeclarations (TheList);
        END;
      END GrabDeclarations;
                  
    VAR
      IsDeleted: BOOLEAN;  
    
    METHOD MarkAsDeleted;
      BEGIN      
      IF NOT IsDeleted THEN
        IsDeleted := TRUE;
        IF SubDecls <> VOID THEN
          SubDecls.MarkAsDeleted;
          END;
        END;
      END MarkAsDeleted;        
      
    METHOD Deleted: BOOLEAN;
      BEGIN
      RESULT := IsDeleted;
      END Deleted;
      
  END Declaration;
---------------------------------------
  CLASS ConstDeclaration;
    INHERITS Declaration(ConstDeclCodeGenerator);
    VAR
      TheConstName: Ident;
      TheExpr: TypedNonTerminal;

    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      RESULT.CREATE(2);
      RESULT[0] := TheConstName;
      RESULT[1] := TheExpr;
      END SubTree;

    REDEFINE METHOD Parse(Lkh: LookAhead);
      BEGIN
      TheConstName := Lkh.AcceptIdent;
      SetSon (TheConstName);
      Lkh.Accept (LexicalAnalyzer.Equal);
      TheExpr := Lkh.AcceptPlainExpr;
      SetSon (TheExpr);
      Lkh.Accept (LexicalAnalyzer.SemiColon);
      END Parse;

    REDEFINE METHOD Id: Ident;
      BEGIN
      RESULT := TheConstName;
      END Id;

    METHOD Expr : TypedNonTerminal;
      BEGIN
      RESULT := TheExpr;
      END Expr;

    REDEFINE METHOD WhatAmI: ARRAY OF CHAR;
      BEGIN
      RESULT := "ConstDeclaration";
      END WhatAmI;

    REDEFINE METHOD Tag;
      BEGIN 
      IF TheExpr <> VOID THEN
        TheExpr.UniqueTag;
        END;
      TheConstName.SetRef (THIS);
      END Tag;

    REDEFINE METHOD CheckType;
      BEGIN
      IF (GetFolded = VOID) AND (InlineString = VOID) THEN
        Error ("Non constant expression");
        END;
      END CheckType;

    VAR
      InlineAsked: BOOLEAN;
      InString: ARRAY OF CHAR;

    METHOD InlineString: ARRAY OF CHAR;
      BEGIN
      IF NOT InlineAsked THEN
        InlineAsked := TRUE;
        FOR p IN  PragmaList WHILE InString = VOID DO
          WHAT p OF
            IN InlineConstPragma:
              InString := TAG.TextReplacement;
              END;
           ELSE
            --Don't abort
            END;
          END;
        END;
      RESULT := InString;
      END InlineString;

    METHOD GetFolded: Literal;
      BEGIN
      IF InlineString = VOID THEN
        RESULT := Expr.GetFolded;
        END;
      END GetFolded;

      
    ----------------------------------------
    METHOD EnterInDictionary (Class : ClassDeclaration);                
    
      VAR
        TheRef : ConstReference;
      
      METHOD Reference : ConstReference;
        BEGIN
        IF TheRef = VOID THEN
          TheRef := ConstDictionary.FindConst (Class.Module.Id.Data,
                                               Class.Id.Data,
                                               Id.Data);
          END; -- IF
        RESULT := TheRef;  
        ASSERT RESULT <> VOID;
        END Reference;    
           
      BEGIN
      Reference.SetState (State);
                                                  
      WHAT Class OF 
        IN ClassDefinition:
          Reference.SetDeclPos (Id.ColNr, Id.LineNr);
          END;
        IN ClassImplementation:
          Reference.SetImplPos (Id.ColNr, Id.LineNr);
          END;
       ELSE
        ASSERT FALSE; 
        END; -- WHAT   
      END EnterInDictionary;
    
    ----------------------------------------

  END ConstDeclaration;
----------------------------------------
  CLASS SingleDataItem;
    INHERITS Declaration(SingleDataItemCodeGenerator);
    CONST
      IsLocalStatus     = 997;
      IsFormalStatus    = 998;
      IsAttributeStatus = 999;
      
    VAR
      TheId: Ident;
      TheType: Type;
      FlagReadOnly,  
      FlagKeepInfo, 
      FlagOnce:       BOOLEAN;
      Status:         INTEGER;
      TheCName:       ARRAY OF CHAR;
      TheOnceNumber:  INTEGER;
      
--    INVARIANT
--      (Status = 0) OR (Status = IsLocalStatus) OR (Status = IsFormalStatus) OR
--      (Status = IsAttributeStatus);

    METHOD GetType: Type;
      BEGIN
      RESULT := TheType;
      END GetType;

    METHOD SetType (TheType: Type);
      BEGIN
      THIS.TheType := TheType;
      END SetType;

    REDEFINE METHOD CREATE (Id: Ident;
                            TheType: Type;
                            ReadOnly,
                            Once: BOOLEAN);
      BEGIN
      BASE(Id.LineNr, Id.ColNr);
      TheId := Id;
      THIS.TheType := TheType;
      Id.SetRef (THIS);
      FlagReadOnly := ReadOnly;
      FlagOnce := Once;
      -- XXJC
      SetSon(Id);
      SetSon(TheType);
      -- END XXJC
      END CREATE;

    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      RESULT.CREATE (2);
      RESULT[0] := TheId;
      RESULT[1] := TheType;
      END SubTree;

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

    METHOD ReadOnly: BOOLEAN;
      BEGIN
      RESULT := FlagReadOnly;
      END ReadOnly;

    REDEFINE METHOD Id: Ident;
      BEGIN
      RESULT := TheId;
      END Id;
      
    VAR
      ReadStatements: NTList(Statement);
          
    METHOD UseRead(Stat: Statement);
      BEGIN                  
      IF Stat <> VOID THEN
        ASSERT Stat <> VOID;
        IF ReadStatements = VOID THEN
          ReadStatements.CREATE;
          ReadStatements.Append (Stat);
         ELSIF ReadStatements.Get(ReadStatements.Size - 1) <> Stat THEN
          ReadStatements.Append (Stat);
          END;
        END;
      END UseRead;
      
    VAR
      WriteStatements: NTList(Statement);
          
    METHOD UseWrite(Stat: Statement);
      BEGIN                  
      IF Stat <> VOID THEN
        IF WriteStatements = VOID THEN
          WriteStatements.CREATE;
          WriteStatements.Append (Stat);
         ELSIF WriteStatements.Last <> Stat THEN
          WriteStatements.Append (Stat);
          END;
        END;
      END UseWrite;
      
    METHOD UsedRead: BOOLEAN;
      BEGIN    
      RESULT := ReadStatements <> VOID;
      ASSERT RESULT IMPLIES ReadStatements.Size > 0;
      END UsedRead;
      
    METHOD UsedWrite: BOOLEAN;
      BEGIN
      RESULT := WriteStatements <> VOID;
      ASSERT RESULT IMPLIES WriteStatements.Size > 0;
      END UsedWrite;
      
    METHOD UsedLValue: BOOLEAN;
      BEGIN          
      IF UsedWrite THEN
        FOR i := 0 TO WriteStatements.Size - 1 WHILE NOT RESULT DO
          WHAT WriteStatements.Get(i) OF
            IN Assignment:
              RESULT := TRUE;
              END;           
           ELSE
            -- Don't abort
            END;
          END;
        END;
      END UsedLValue;

    METHOD UsedNonLocalWrite: BOOLEAN;
      VAR
        ThisMethod: MethodImplementation;
      BEGIN                              
      ThisMethod := MethodContext;
      ASSERT ThisMethod <> VOID;
      RESULT := UsedWrite AND THERE_IS w IN WriteStatements :-
                   w.MethodContext <> ThisMethod;
      END UsedNonLocalWrite;

    METHOD SetReadOnly (Value: BOOLEAN);
      BEGIN
      FlagReadOnly := Value;
      END SetReadOnly;

    REDEFINE METHOD WhatAmI: ARRAY OF CHAR;
      BEGIN
      RESULT := "SingleDataItem";
      END WhatAmI;
      
    VAR
      TheContext: Declaration;

    METHOD SetContext(Context: Declaration);
      BEGIN
      ASSERT TheContext = VOID;
      TheContext := Context;
      END SetContext;
    
    METHOD Context: Declaration;
      BEGIN
      IF TheContext = VOID THEN
        TheContext := MethodContext;
        IF TheContext <> VOID THEN
          Status := IsLocalStatus;
         ELSE
          TheContext := ClassContext;
          Status := IsAttributeStatus;
          END;      
       ELSE
        RESULT := TheContext;
        END;
      END Context;   
                             
    METHOD IsLocal: BOOLEAN;
      BEGIN
      IF Status = 0 THEN
        VOID := Context;
        END;
      RESULT := Status = IsLocalStatus;
      END IsLocal;  

    METHOD IsFormal: BOOLEAN;
      BEGIN
      IF Status = 0 THEN
        VOID := Context;
        END;
      RESULT := Status = IsFormalStatus;
      END IsFormal;   
      
    METHOD IsAttribute: BOOLEAN;
      BEGIN
      IF Status = 0 THEN
        VOID := Context;
        END;
      RESULT := Status = IsAttributeStatus;
      END IsAttribute;

    METHOD UseObjPtr: BOOLEAN;
      BEGIN
      IF TheCName = VOID THEN
        RESULT := TheType.UseObjPtr;
        END;
      END UseObjPtr;
      
    METHOD KeepInfo: BOOLEAN;
      BEGIN
      RESULT := FlagKeepInfo;
      END KeepInfo;

------------------------------------------------------------      
-- added by bernard
-- check if the field should be hidden      
------------------------------------------------------------
    METHOD HideInfo: BOOLEAN;
      BEGIN
      RESULT := TRUE;
      FOR p IN PragmaList DO
        WHAT p OF
          IN VisibleFieldPragma:
            RESULT := FALSE;
            END;
         ELSE -- don't abort
          END;
        END;
      END HideInfo;
      
    METHOD CheckUsage;
      BEGIN
      IF NOT KeepInfo THEN
        IF NOT UsedRead THEN
          IF NOT UsedWrite THEN
            Warning ("'" + Id.Data + "' not referenced");
           ELSE
            Warning ("'" + Id.Data + "' is set but not read");
            END;
         ELSIF NOT UsedWrite THEN
          Warning ("'" + Id.Data + "' is never set");
          END;
        END;
      END CheckUsage;
      
    ---------------------------------------
    -- The SetAttributeType is used to attach a C type
    -- identifier to an attribute, which is not denoted by
    -- any of YAFL's predefined types.
    ---------------------------------------
    METHOD SetAttributeType (CName: ARRAY OF CHAR);
      BEGIN
      TheCName := CName;
      END SetAttributeType;
      
    METHOD Once: BOOLEAN;
      BEGIN
      RESULT := FlagOnce;
      END Once;   
      
    METHOD GetCName: ARRAY OF CHAR;
      BEGIN
      RESULT := TheCName;
      END GetCName;
      
    METHOD OnceNumber: INTEGER;
      BEGIN
      ASSERT Once;
      IF TheOnceNumber = 0 THEN
        TheOnceNumber := YaflCfg.UniqueNumber;
        END;
      RESULT := TheOnceNumber;
      END OnceNumber;
      
    REDEFINE METHOD Tag;
      VAR
        Actuals: ClassActualSet;      
        ClDecl: ClassDeclaration;
        NewType: Type;
      BEGIN
      FlagKeepInfo := YaflCfg.KeepFieldInfo;
      TheType.UniqueTag;
      ClDecl := TheType.SimpleType;
      IF ClDecl <> VOID THEN
        WHAT ClDecl OF
          IN PredefClass:
            END;
          IN VirtualClassDecl:
            END;
         ELSE
          ClDecl := ClDecl.Canonic;
          IF (NOT TheType.IsConstrained) THEN
            IF (ClDecl.ClassFormals <> VOID) THEN
              NewType := ClDecl.MakeConstrainedType 
                                   (TheType.ArrayLevel,
                                   ClDecl.ClassFormals.ToVirtualActualSet);
              ----------------------------
              -- Now, attach all these newly created VirtualClassDecl's
              -- to the variable which they belong to.                                     
              ----------------------------
              Actuals := NewType.Actuals;
              ASSERT Actuals <> VOID;
              FOR Act IN Actuals.ActualList DO
                WHAT Act.Class OF
                  IN VirtualClassDecl:
                    TAG.SetDataItemRef (THIS);
                    END;
                  END;
                END;
              SetType (NewType);                                         
              END; 
            END;
          END;
        END;
      END Tag;
      
    REDEFINE METHOD CheckType;
      BEGIN
      ----------------------------------
      -- If required, register THIS as a ONCE markable
      -- for the enclosing class
      ----------------------------------
      IF Once AND UseObjPtr THEN
        ClassContext.RegisterOnceVariable (THIS);
        END;
      END CheckType; 
      
    METHOD Removed: BOOLEAN;
      BEGIN 
      RESULT := (GetType <> VOID) AND GetType.Removed;
      END Removed;

    ----------------------------------------
    
    METHOD ClassContext: ClassImplementation;
      VAR
        r: ONCE Ref(ClassImplementation);
      BEGIN              
      IF r = VOID THEN
        r.CREATE (VOID);
	END;
      GetAncestor (r);
      RESULT := r.Get;
      r.Set(VOID);
      END ClassContext;
    
    METHOD MethodContext: MethodImplementation;
      VAR
        r: ONCE Ref(MethodImplementation);
      BEGIN              
      IF r = VOID THEN
        r.CREATE (VOID);
	END;
      GetAncestor (r);
      RESULT := r.Get;
      r.Set(VOID);
      END MethodContext;
    
    VAR
      TheRef : AttributeReference;
               
    METHOD Reference : AttributeReference;
      VAR
        Class: ClassImplementation;
      BEGIN
      -- ASSERT IsAttribute;
      Class := ClassContext;
      IF TheRef = VOID THEN
        TheRef := AttributeDictionary.FindAttribute (Class.Module.Id.Data,
                                                     Class.Id.Data,
                                                     Id.Data);
        END; -- IF
      RESULT := TheRef;  
      ASSERT RESULT <> VOID;
      END Reference;
   
    METHOD EnterInDictionary;
      BEGIN
      Reference.SetState (State);
      Reference.SetImplPos (Id.ColNr, Id.LineNr);
      END EnterInDictionary;
    
    METHOD NeedsOwnMarking: BOOLEAN;        
      BEGIN 
      IF UseObjPtr AND NOT Once AND UsedWrite THEN
        FOR Stat IN WriteStatements WHILE NOT RESULT DO
          IF Stat.LoopContext <> VOID THEN
            RESULT := TRUE;
           ELSE
            WHAT Stat OF
              IN Assignment:
                RESULT := TRUE;
                END;
             ELSE
              -- Don't abort...
              END;
            END;
          END;
        END;
      END NeedsOwnMarking;

  END SingleDataItem;
----------------------------------------
  CLASS InLineDeclaration;
    INHERITS Declaration(DummyDeclCodeGenerator);
    VAR
      InLineStat: InLineStatement;

    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN
      RESULT.CREATE(1);
      RESULT[0] := InLineStat;
      END SubTree;

    REDEFINE METHOD Parse(Lkh: LookAhead);
      BEGIN
      InLineStat := Lkh.AcceptInLineStatement;
      Lkh.Accept (LexicalAnalyzer.SemiColon);
      END Parse;

    REDEFINE METHOD WhatAmI: ARRAY OF CHAR;
      BEGIN
      RESULT := "InLineDeclaration";
      END WhatAmI;
      
    REDEFINE METHOD Enter;
      BEGIN
      END Enter;

  END InLineDeclaration;
----------------------------------------

END YaflDeclarations;
