IMPLEMENTATION MODULE YaflPragmas;

IMPORT LookAhead;
FROM Streams IMPORT StdOut;
FROM YaflCfg IMPORT YaflCfg;
FROM YaflClImplementation IMPORT ClassImplementation;
FROM YaflDeclarations IMPORT ConstDeclaration, SingleDataItem;
FROM YaflIdentifiers IMPORT Ident;
FROM YaflLiteral IMPORT StringLiteral;
FROM YaflMetImplementation IMPORT MethodImplementation;
FROM YaflModules IMPORT ImplementationModule, DefinitionModule;
FROM YaflSystem IMPORT PatternSystemMethod;
        
  CLASS Pragma;
    INHERITS Declaration(DummyDeclCodeGenerator);     

    VAR
      TheParam: NTList(NonTerminal);
      TheId: Ident;

    REDEFINE METHOD SubTree: ARRAY OF NonTerminal;
      BEGIN       
      RESULT.CREATE (1);
      RESULT [0] := TheId;
      IF TheParam <> VOID THEN
        RESULT := RESULT + TheParam.SubTree;
        END;
      END SubTree;

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

    METHOD Param: NTList(NonTerminal);
      BEGIN
      RESULT := TheParam;
      END Param;

    METHOD SetId (Data: ARRAY OF CHAR);
      BEGIN
      TheId.CREATE (LineNr, ColNr, Data);
      END SetId;

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

    REDEFINE METHOD Enter;
      BEGIN
      END Enter;
      
    REDEFINE METHOD Tag;
      BEGIN 
      Warning ("Unsupported pragma: " + WhatAmI);
      END Tag;
      
    REDEFINE METHOD CheckType;
      BEGIN
      END CheckType;

    --------------------------
    -- This Parse method only parses the parameters,
    -- as the pragma's Id is alredy recognized at this
    -- stage.
    --------------------------
    REDEFINE METHOD Parse(Lkh: LookAhead);
      VAR
        GoOn: BOOLEAN; 
        p: NonTerminal;
      BEGIN
      IF Lkh.Ok THEN
        IF Lkh.CurrentToken = Lkh.LeftParen THEN
          Lkh.GetToken;
          GoOn := TRUE;
          WHILE (Lkh.Ok) AND GoOn DO
            IF Lkh.CurrentToken = Lkh.Ident THEN
              p := Lkh.AcceptIdent;
             ELSE
              p := Lkh.AcceptLiteral(Lkh.PlainExpressionContext);
              END;
            IF TheParam = VOID THEN
              TheParam.CREATE;
              END;
            TheParam.Append (p);
            IF Lkh.CurrentToken = Lkh.Comma THEN
              Lkh.GetToken;
             ELSE
              GoOn := FALSE;
              END; 
            END;
          IF Lkh.Ok THEN
            Lkh.Accept (Lkh.RightParen);
            END;
          END;
        Lkh.Accept (Lkh.SemiColon);
        END;
      END Parse;

  END Pragma;
-------------------------------------
  CLASS CallBackPragma;
    INHERITS Pragma;      
      VAR
        TheMeth: MethodDeclaration;
        TheName: ARRAY OF CHAR;
    
      METHOD Meth: MethodDeclaration;
        BEGIN
        RESULT := TheMeth;     
        END Meth;                     
        
      METHOD CallBackName: ARRAY OF CHAR;
        BEGIN            
        RESULT := TheName;
        END CallBackName;
        
      REDEFINE METHOD Tag;
        BEGIN   
        IF (Param = VOID) OR (Param.Size <> 2) THEN
          Error ("Arity error");
         ELSE                       
          WHAT Param.Get(0) OF
            IN Ident:
              TAG.UniqueTag;
              IF TAG.GetRef <> VOID THEN
                WHAT TAG.GetRef OF
                  IN MethodDeclaration:
                    TheMeth := TAG;       
                    --------------------------
                    -- Make sure this is a valid method for
                    -- the callback.
                    --------------------------             
                    IF TheMeth.Redefine OR NOT TheMeth.Class.Once THEN
                      Error ("Invalid callback method");
                     ELSE 
                      WHAT Param.Get(1) OF                 
                        IN StringLiteral:
                          TheName := TAG.Value;
                          TheMeth.SetCallBackName (TheName);
                          END;
                        IN Ident:
                          TheName := TAG.Data;        
                          TheMeth.SetCallBackName (TheName);
                          END;
                       ELSE
                        Error ("String literal of identifier expected");
                        END; 
                      END;
                    END;
                 ELSE 
                  Error ("Method identifier expected");
                  END; 
                END;
              END;
           ELSE
            Error ("Identifier expected");
            END; -- What 
          END;
        ASSERT TheName <> VOID;
        END Tag;  
        
    END CallBackPragma;
-------------------------------------
  CLASS PublishPragma;
    INHERITS Pragma;      
      VAR
        TheMeth: MethodDeclaration;
    
      METHOD Meth: MethodDeclaration;
        BEGIN
        RESULT := TheMeth;     
        END Meth;                     
        
      REDEFINE METHOD Tag;
        BEGIN   
        IF (Param = VOID) OR (Param.Size = 0) THEN
          Error ("Arity error");
         ELSE                       
          FOR p IN Param DO
            WHAT p OF
              IN Ident:
                TAG.UniqueTag;
                IF TAG.GetRef <> VOID THEN
                  WHAT TAG.GetRef OF
                    IN MethodDeclaration:
                      TAG.SetPublish (TRUE);
                      END;
                   ELSE 
                    Error ("Method identifier expected");
                    END;
                  END; 
                END;
             ELSE
              Error ("Identifier expected");
              END; -- What 
            END;
          END;
        END Tag;  
        
    END PublishPragma;
-------------------------------------
  CLASS IncludePragma;
    INHERITS Pragma;                          
      VAR
        TheInc: ARRAY OF ARRAY OF CHAR;
    
      REDEFINE METHOD Tag;
        BEGIN   
        IF (Param <> VOID) THEN
          TheInc.CREATE (Param.Size);
          FOR i := 0 TO TheInc.SIZE - 1 DO
            WHAT Param.Get(i) OF
              IN StringLiteral:
                TheInc [i] := TAG.Value;
                END;
             ELSE
              Param.Get(i).Error ("String literal expected");
              END;
            END;
          END;
        ASSERT GrandPa <> VOID;
        WHAT GrandPa OF
          IN ImplementationModule:
            GrandPa.AttachPragma (THIS);  -- Such pragmas are attached
                                          -- to the whole compilation unit.
            END;
         ELSE
          Error ("Implementation module pragma");
          END;          
        END Tag;  

    METHOD Includes: ARRAY OF ARRAY OF CHAR;
      BEGIN
      RESULT := TheInc;
      END Includes;
        
    END IncludePragma;
-------------------------------------
  CLASS InlineConstPragma;
    INHERITS Pragma;      
       VAR
         Text: ARRAY OF CHAR;
    
      REDEFINE METHOD Tag;
        BEGIN   
        IF (Param = VOID) OR (Param.Size <> 2) THEN
          Error ("Arity error");
         ELSE
          WHAT Param.Get(0) OF
            IN Ident:
              TAG.UniqueTag;
              IF TAG.GetRef <> VOID THEN
                WHAT TAG.GetRef OF
                  IN ConstDeclaration:
                    TAG.AttachPragma (THIS);
                    WHAT Param.Get(1) OF
                      IN Ident:
                        Text := TAG.Data;
                        END;
                      IN StringLiteral:
                        Text := TAG.Value;
                        END;
                     ELSE
                      Error ("Replacement identifier or string expected");
                      END;
                    END;
                 ELSE
                  TAG.Error ("Constant identifier expected");
                  END;
                END;              
              END;
           ELSE
            Error ("Constant identifier expected");
            END;
          END;
        END Tag;

      METHOD TextReplacement: ARRAY OF CHAR;
        BEGIN
        RESULT := Text;
        END TextReplacement;  

    END InlineConstPragma;
----------------------------------------
  CLASS KeepFieldsPragma;
    INHERITS Pragma; 
    VAR
      Value: BOOLEAN;

    REDEFINE METHOD Tag;
      BEGIN
      WHAT GrandPa OF
        IN ImplementationModule:
          IF Param <> VOID THEN
            Error("Arity error");
            END;
          YaflCfg.SetKeepFieldInfo (Value);
          END;
       ELSE
        Error("Implementation module pragma");
        END;
      END Tag;    

    REDEFINE METHOD CREATE (LineNr, ColNr: INTEGER;
                            Value: BOOLEAN);
      BEGIN
      BASE (LineNr, ColNr);
      THIS.Value := Value;
      END CREATE;                            

  END KeepFieldsPragma;                    
----------------------------------------  
  CLASS VarTypePragma;
    INHERITS Pragma; 
    
    REDEFINE METHOD Tag;
      VAR
        TheDataItem: SingleDataItem;
        
        METHOD CheckDataItem (Id: Ident): SingleDataItem;
          BEGIN
          ASSERT Id <> VOID;
          Id.UniqueTag;
          IF Id.GetRef <> VOID THEN
            WHAT Id.GetRef OF
              IN SingleDataItem:
                RESULT := TAG;
                END;
             ELSE
              -- Don't abort...
              END;
            END;
          END CheckDataItem;
        
      BEGIN
      WHAT GrandPa OF
        IN ImplementationModule:
          IF (Param = VOID) OR (Param.Size <> 2) THEN
            Error("Arity error");
           ELSE
            WHAT Param.Get(0) OF
              IN Ident:
                TheDataItem := CheckDataItem (TAG);
                IF (TheDataItem <> VOID) THEN
                  -----------------------
                  -- It is indeed an attribute identifier
                  -----------------------
                  WHAT Param.Get(1) OF
                    IN StringLiteral:
                      TheDataItem.SetAttributeType (TAG.Value);
                      END;
                    IN Ident:
                      TheDataItem.SetAttributeType (TAG.Data);
                      END;
                   ELSE
                    Error ("String or identifier expected");
                    END;
                 ELSE
                  Error ("Attribute or variable identifier expected [1]");
                  END;
                END;
             ELSE
              Error ("Identifier expected");
              END;
            END;
          END;
       ELSE
        Error("Implementation module pragma");
        END;
      END Tag;
    
    REDEFINE METHOD CREATE (LineNr, ColNr: INTEGER);
      BEGIN
      BASE (LineNr, ColNr);
      END CREATE;
      
  END VarTypePragma;                    
---------------------------------------------------------------
  CLASS InlineMethodPragma;
    INHERITS Pragma; 
    
    REDEFINE METHOD Tag;
      VAR
        TheMethod: MethodDeclaration;
        Table: ARRAY OF ARRAY OF CHAR;
        PSystemMethod: PatternSystemMethod;
        
        METHOD CheckMethodDeclaration (Id: Ident): MethodDeclaration;
          BEGIN
          ASSERT Id <> VOID;
          IF Id.GetRef <> VOID THEN
            WHAT Id.GetRef OF
              IN MethodDeclaration:
                IF NOT TAG.Class.Once THEN
                  Error ("Method inlining attached to non-once class");
                 ELSIF TAG.Redefine THEN
                  Error ("Method inlining attached to a redefining method");
                 ELSE
                  WHAT TAG OF
                    IN MethodImplementation:
                      RESULT := TAG.Definition;
                      END;
                   ELSE
                    -- Don't abort...
                    END;
                  IF RESULT = VOID THEN
                    RESULT := TAG;
                    END;
                  END;
                END;
             ELSE          
              Error ("Method declaration identifier expected");
              -- Don't abort...
              END;
            END;
          END CheckMethodDeclaration;
        
      BEGIN
      IF (Param = VOID) OR (Param.Size < 2) THEN
        Error("Arity error");
       ELSE
        WHAT Param.Get(0) OF
          IN Ident:
            TAG.UniqueTag;
            TheMethod := CheckMethodDeclaration (TAG);
            IF (TheMethod <> VOID) THEN
              -----------------------
              -- It is indeed an attribute identifier
              -----------------------
              Table.CREATE (Param.Size - 1);
              FOR i := 1 TO Param.Size - 1 DO
                WHAT Param.Get(i) OF
                  IN StringLiteral:     
                    Table[i-1] := TAG.Value;
                    END;
                  IN Ident:
                    Table[i-1] := TAG.Data;
                    END;
                 ELSE
                  Param.Get(i).Error ("String or identifier expected");
                  END;  
                PSystemMethod.CREATE (TheMethod, Table);
                END;
              END;
            END;
         ELSE
          Error ("Identifier expected");
          END;
        END;
      END Tag;
    
    REDEFINE METHOD CREATE (LineNr, ColNr: INTEGER);
      BEGIN
      BASE (LineNr, ColNr);
      END CREATE;
      
  END InlineMethodPragma;                    
---------------------------------------------------------------
  CLASS VisibleFieldPragma;
    INHERITS Pragma;

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

    REDEFINE METHOD Tag;
      VAR
        TheDataItem: SingleDataItem;
        
        METHOD CheckContext (DataItem: SingleDataItem): BOOLEAN;
          BEGIN
          ASSERT DataItem <> VOID;
          IF DataItem.Context <> VOID THEN
            WHAT DataItem.Context OF
              IN ClassImplementation:
                RESULT := TRUE;
                END;
             ELSE
              -- Don't abort if no implementation
              END;
            END;
          END CheckContext;
          
        METHOD CheckDataItem (Id: Ident): SingleDataItem;
          BEGIN
          ASSERT Id <> VOID;
          IF Id.GetRef <> VOID THEN
            WHAT Id.GetRef OF
              IN SingleDataItem:
                RESULT := TAG;
                END;
             ELSE
              -- Don't abort...
              END;
            END;
          END CheckDataItem;
        
      BEGIN
      WHAT GrandPa OF
        IN ImplementationModule:
          IF (Param = VOID) OR (Param.Size <> 1) THEN
            Error("Arity error");
           ELSE
            WHAT Param.Get(0) OF
              IN Ident:
                TAG.UniqueTag;
                TheDataItem := CheckDataItem (TAG);
                IF (TheDataItem <> VOID) AND TheDataItem.IsAttribute THEN
                  -----------------------
                  -- It is indeed an attribute identifier
                  -----------------------
                  TheDataItem.AttachPragma(THIS);
                 ELSE
                  Error ("Attribute identifier expected [1]");
                  END;
                END;
             ELSE
              Error ("Identifier expected");
              END;
            END;
          END;
       ELSE
        Error("Implementation module pragma");
        END;
      END Tag;
      
    END VisibleFieldPragma;
        
----------------------------------------
  CLASS ErrorPragma;
    INHERITS Pragma;
    
    VAR
      Fatal: BOOLEAN;
    
    REDEFINE METHOD CREATE (LineNr, ColNr: INTEGER;
                            Fatal: BOOLEAN);
      BEGIN
      THIS.Fatal := Fatal;
      BASE (LineNr, ColNr);      
      END CREATE;
      
    REDEFINE METHOD Tag;
      BEGIN
      IF (Param = VOID) OR (Param.Size <> 1) THEN
        Error ("Arity error");
       ELSE
        WHAT Param.Get(0) OF
          IN StringLiteral:
            IF Fatal THEN
              Error (TAG.Value);
             ELSE
              Warning (TAG.Value);
              END;
            END;
         ELSE
          Error ("String literal expected");
          END;
        END;
      END Tag;
      
  END ErrorPragma;
----------------------------------------
  CLASS ObsoletePragma;
    INHERITS Pragma;
    
    REDEFINE METHOD Tag;
      BEGIN
      WHAT GrandPa OF
        IN DefinitionModule:
          IF Param = VOID THEN
            Warning ("Obsolete module");
           ELSE
            IF Param.Size = 1 THEN
              WHAT Param.Get(0) OF
                IN StringLiteral:
                  Warning (TAG.Value);
                  END;
               ELSE
                Error ("String literal expected");
                END; -- What
             ELSE
              Error ("Arity error");
              END;  
            END;
          END;
       ELSE
        Error ("The Obsolete pragma should only be used within definition " +
               "modules");
        END;
      END Tag;
      
  END ObsoletePragma;
  
END YaflPragmas;
