------------------------------------------------------------------------------ -- Templates Parser -- -- -- -- Copyright (C) 2010-2019, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 3, or (at your option) any -- -- later version. This library is distributed in the hope that it will be -- -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Strings.Hash_Case_Insensitive; with Ada.Text_IO; separate (Templates_Parser) package body Macro is function Default_Callback (Name : String; Params : Parameter_Set) return String; -- Default macro callback package Registry is new Containers.Indefinite_Hashed_Maps (String, Tree, Strings.Hash_Case_Insensitive, "="); Set : Registry.Map; ---------------------- -- Default_Callback -- ---------------------- function Default_Callback (Name : String; Params : Parameter_Set) return String is function Parameters return String; -- Returns parameters ---------------- -- Parameters -- ---------------- function Parameters return String is R : Unbounded_String; begin for K in Params'Range loop Append (R, Params (K)); if K /= Params'Last then Append (R, ","); end if; end loop; return To_String (R); end Parameters; begin return To_String (Begin_Tag) & Name & "(" & Parameters & ")" & To_String (End_Tag); end Default_Callback; --------- -- Get -- --------- function Get (Name : String) return Tree is Position : constant Registry.Cursor := Set.Find (Name); begin if Registry.Has_Element (Position) then return Registry.Element (Position); else return null; end if; end Get; -------------------------- -- Print_Defined_Macros -- -------------------------- procedure Print_Defined_Macros is begin Text_IO.Put_Line ("------------------------------------- MACROS"); for C in Set.Iterate loop declare Name : constant String := Registry.Key (C); Macro : constant Tree := Registry.Element (C); begin Text_IO.Put_Line ("[MACRO] " & Name); Print_Tree (Macro); Text_IO.Put_Line ("[END_MACRO]"); Text_IO.New_Line; end; end loop; end Print_Defined_Macros; -------------- -- Register -- -------------- procedure Register (Name : String; T : not null Tree) is Old : Tree := Get (Name); begin if Old /= null then Set.Delete (Name); Release (Old); end if; Set.Insert (Name, T); end Register; ------------- -- Rewrite -- ------------- procedure Rewrite (T : in out Tree; Parameters : not null access Data.Parameter_Set) is use type Definitions.Tree; procedure Rewrite_Tree (T : in out Tree; Parameters : not null access Data.Parameter_Set); -- Recursivelly rewrite the whole tree package Set_Var is new Containers.Indefinite_Hashed_Maps (String, Definitions.Tree, Strings.Hash_Case_Insensitive, "="); procedure Release_Definition (Position : Set_Var.Cursor); -- Release definition tree pointed to by Position Vars : Set_Var.Map; ------------------------ -- Release_Definition -- ------------------------ procedure Release_Definition (Position : Set_Var.Cursor) is E : Definitions.Tree := Set_Var.Element (Position); begin Definitions.Release (E); end Release_Definition; ------------------ -- Rewrite_Tree -- ------------------ procedure Rewrite_Tree (T : in out Tree; Parameters : not null access Data.Parameter_Set) is procedure Rewrite (T : in out Data.Tree); -- Rewrite every variable references @_$N_@ (where N is a -- number) by the corresponding variable or value found in -- Parameters(N) or by the corresponding variable mapping in Vars. procedure Rewrite (T : in out Expr.Tree); -- Rewrite condition. -- In @@IF@@ @_$N_@ = val -- Replace $N by Parameters(N) or by the corresponding value in the -- variable mapping or does nothing if Parameters(N) does not exist -- or no variable mapping found. procedure Rewrite (Included : in out Included_File_Info); -- Process included files (from @@INCLUDE@@ or @@EXTENDS@@) ------------- -- Rewrite -- ------------- procedure Rewrite (T : in out Data.Tree) is procedure Replace (T, C, Prev : in out Data.Tree; Ref : Positive); -- Replace node C with the parameters pointed to by Ref procedure Replace (T, C, Prev : in out Data.Tree; Value : String); -- As above, but replace by Value procedure Delete_Node (T : in out Data.Tree; C, Prev : Data.Tree); -- Delete node C ----------------- -- Delete_Note -- ----------------- procedure Delete_Node (T : in out Data.Tree; C, Prev : Data.Tree) is use type Data.Tree; Old : Data.Tree; begin if Prev = null then Old := T; T := C.Next; else Old := C; Prev.Next := C.Next; end if; Data.Release (Old, Single => True); end Delete_Node; ------------- -- Replace -- ------------- procedure Replace (T, C, Prev : in out Data.Tree; Ref : Positive) is use type Data.Tree; New_Node : constant Data.Tree := Data.Clone (Parameters (Ref)); begin New_Node.Next := C.Next; if Prev = null then Data.Release (T, Single => True); T := New_Node; else Data.Release (Prev.Next, Single => True); Prev.Next := New_Node; end if; Prev := New_Node; C := New_Node.Next; end Replace; procedure Replace (T, C, Prev : in out Data.Tree; Value : String) is use type Data.Tree; New_Node : constant Data.Tree := new Data.Node' (Data.Text, Line => C.Line, Col => Value'First, Next => C.Next, Value => To_Unbounded_String (Value)); begin if Prev = null then Data.Release (T, Single => True); T := New_Node; else Data.Release (Prev.Next, Single => True); Prev.Next := New_Node; end if; Prev := New_Node; C := New_Node.Next; end Replace; use type Data.Tree; D, Prev : Data.Tree; Moved : Boolean := False; begin D := T; Prev := null; while D /= null loop case D.Kind is when Data.Text => null; when Data.Var => -- Rewrite also the macro call if any if D.Var.Is_Macro then Rewrite_Tree (D.Var.Def, Parameters); else if D.Var.N > 0 then -- This is a reference to a parameter if D.Var.N <= Parameters'Length and then Parameters (D.Var.N) /= null then -- This is a reference to replace Replace (T, D, Prev, D.Var.N); else -- This variable does not have reference, remove -- it. Delete_Node (T, D, Prev); D := D.Next; end if; Moved := True; elsif Vars.Contains (To_String (D.Var.Name)) then -- This is a variable that exists into the map. -- It means that this variable is actually the -- name of a SET which actually has been passed -- a reference to another variable. declare E : constant Definitions.Tree := Vars.Element (To_String (D.Var.Name)); begin case E.N.Kind is when Definitions.Const => Replace (T, D, Prev, To_String (E.N.Value)); when Definitions.Ref => if E.N.Ref <= Parameters'Length and then Parameters (E.N.Ref) /= null then Replace (T, D, Prev, E.N.Ref); else Replace (T, D, Prev, ""); end if; when Definitions.Ref_Default => if E.N.Ref <= Parameters'Length and then Parameters (E.N.Ref) /= null then Replace (T, D, Prev, E.N.Ref); else Replace (T, D, Prev, To_String (E.N.Value)); end if; end case; end; Moved := True; end if; end if; end case; if Moved then Moved := False; else Prev := D; D := D.Next; end if; end loop; end Rewrite; ------------- -- Rewrite -- ------------- procedure Rewrite (T : in out Expr.Tree) is use type Data.Tree; procedure Replace (T : in out Expr.Tree; Ref : Positive) with Inline; -- Replace T with the parameters pointed to by Ref procedure Replace (T : in out Expr.Tree; Value : String) with Inline; -- Replace the node by the given value ------------- -- Replace -- ------------- procedure Replace (T : in out Expr.Tree; Value : String) is Ctx : aliased Filter.Filter_Context (0); N_Value : constant String := Data.Translate (T.Var, Value, Ctx'Access); Line : constant Natural := T.Line; begin Expr.Release (T, Single => True); T := new Expr.Node' (Expr.Value, Line, V => To_Unbounded_String (N_Value)); end Replace; procedure Replace (T : in out Expr.Tree; Ref : Positive) is Ctx : aliased Filter.Filter_Context (0); Tag_Var : Data.Tag_Var; begin case Parameters (Ref).Kind is when Data.Text => -- We need to evaluate the value against the filters Replace (T, Data.Translate (T.Var, To_String (Parameters (Ref).Value), Ctx'Access)); when Data.Var => Tag_Var := Data.Clone (Parameters (Ref).Var); Data.Release (T.Var); T.Var := Tag_Var; end case; end Replace; begin case T.Kind is when Expr.Value => null; when Expr.Var => if T.Var.N > 0 then if T.Var.N <= Parameters'Length and then Parameters (T.Var.N) /= null then -- This is a reference to replace Replace (T, T.Var.N); else -- Referencing a parameter that does not exist Replace (T, ""); end if; elsif Vars.Contains (To_String (T.Var.Name)) then -- This is a variable that exists in the map. -- It means that this variable is actually the -- name of a SET which actually has been passed -- a reference to another variable. declare E : constant Definitions.Tree := Vars.Element (To_String (T.Var.Name)); begin case E.N.Kind is when Definitions.Const => Replace (T, To_String (E.N.Value)); when Definitions.Ref => if E.N.Ref <= Parameters'Length and then Parameters (E.N.Ref) /= null then Replace (T, E.N.Ref); else Replace (T, ""); end if; when Definitions.Ref_Default => null; end case; end; else -- Preserve the node as it is. It is likely refering to a -- variable that was defined outside of the macro. null; end if; when Expr.Op => Rewrite (T.Left); Rewrite (T.Right); when Expr.U_Op => Rewrite (T.Next); end case; end Rewrite; ------------- -- Rewrite -- ------------- procedure Rewrite (Included : in out Included_File_Info) is begin for K in Included.Params'Range loop declare use type Data.NKind; use type Data.Tree; P : Data.Tree renames Included.Params (K); Old : Data.Tree; begin if P /= null and then P.Kind = Data.Var and then P.Var.N > 0 then Old := Included.Params (K); Included.Params (K) := Data.Clone (Parameters (P.Var.N)); Data.Release (Old); end if; end; end loop; end Rewrite; N : Tree := T; Prev : Tree; Moved : Boolean := False; begin T := N; while N /= null loop case N.Kind is when Text => Rewrite (N.Text); when If_Stmt => Rewrite (N.Cond); Rewrite_Tree (N.N_True, Parameters); Rewrite_Tree (N.N_False, Parameters); when Set_Stmt => -- Record definition and delete node, note that the -- defintion tree will be freed later as we need the tree -- for the rewriting. Vars.Include (To_String (N.Def.Name), N.Def); declare Old : Tree := N; begin if Prev = null then T := N.Next; N := T; else Prev.Next := N.Next; N := Prev.Next; end if; Unchecked_Free (Old); Moved := True; end; when Table_Stmt => Rewrite_Tree (N.Blocks, Parameters); when Section_Block => Rewrite_Tree (N.Common, Parameters); Rewrite_Tree (N.Sections, Parameters); when Section_Stmt => Rewrite_Tree (N.N_Section, Parameters); when Include_Stmt => Rewrite (N.I_Included); when Extends_Stmt => Rewrite (N.E_Included); when others => null; end case; if Moved then Moved := False; else Prev := N; N := N.Next; end if; end loop; end Rewrite_Tree; begin Rewrite_Tree (T, Parameters); Vars.Iterate (Release_Definition'Access); end Rewrite; begin Callback := Default_Callback'Access; end Macro;