------------------------------------------------------------------------------ -- Templates Parser -- -- -- -- Copyright (C) 1999-2020, 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.Calendar; with Ada.Characters.Handling; with Ada.Containers.Indefinite_Ordered_Sets; with Ada.Containers.Indefinite_Vectors; with Ada.Exceptions; with Ada.IO_Exceptions; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Text_IO; with Ada.Unchecked_Deallocation; with GNAT.Calendar.Time_IO; with GNAT.Regpat; with Templates_Parser.Configuration; with Templates_Parser.Input; with Templates_Parser.Utils; package body Templates_Parser is use Ada.Exceptions; use Ada.Strings; Internal_Error : exception; Blank : constant Maps.Character_Set := Maps.To_Set (' ' & ASCII.HT); function Get_Parameters (Parameters : String) return Parameter_Set; -- Returns the parameters set as parsed into Parameters. This routines -- handles both positional and named parameters. It is currently used for -- include and macro parameters. -------------- -- Tag Info -- -------------- Begin_Tag : Unbounded_String := To_Unbounded_String (Default_Begin_Tag); End_Tag : Unbounded_String := To_Unbounded_String (Default_End_Tag); Set_Token : constant String := "@@SET@@"; Table_Token : constant String := "@@TABLE@@"; Terminate_Sections_Token : constant String := "@@TERMINATE_SECTIONS@@"; Begin_Token : constant String := "@@BEGIN@@"; End_Token : constant String := "@@END@@"; Section_Token : constant String := "@@SECTION@@"; End_Table_Token : constant String := "@@END_TABLE@@"; Macro_Token : constant String := "@@MACRO@@"; End_Macro_Token : constant String := "@@END_MACRO@@"; If_Token : constant String := "@@IF@@"; Elsif_Token : constant String := "@@ELSIF@@"; Else_Token : constant String := "@@ELSE@@"; End_If_Token : constant String := "@@END_IF@@"; Include_Token : constant String := "@@INCLUDE@@"; Extends_Token : constant String := "@@EXTENDS@@"; End_Extends_Token : constant String := "@@END_EXTENDS@@"; Block_Token : constant String := "@@BLOCK@@"; End_Block_Token : constant String := "@@END_BLOCK@@"; Inline_Token : constant String := "@@INLINE@@"; End_Inline_Token : constant String := "@@END_INLINE@@"; A_Terminate_Sections_Token : constant String := "TERMINATE_SECTIONS"; A_Reverse_Token : constant String := "REVERSE"; A_Terse_Token : constant String := "TERSE"; A_Aligh_On : constant String := "ALIGN_ON"; ------------ -- Filter -- ------------ package Filter is ---------------------- -- Filters setting -- ---------------------- -- A filter appear just before a tag variable (e.g. @_LOWER:SOME_VAR_@ -- and means that the filter LOWER should be applied to SOME_VAR before -- replacing it in the template file. type Mode is (Multiply, -- Multiply the given parameter to the string (operator "*") Plus, -- Add the given parameter to the string (operator "+") Minus, -- Substract the given parameter to the string (operator "-") Divide, -- Divide the given parameter to the string (operator "/") Absolute, -- Returns the abosulte value Add, -- Add the given parameter to the string Add_Param, -- Add an HTTP parameter to the string, add the '&' parameter -- separator if needed. BR_2_EOL, -- Replaces all
HTML tags by a given end-of-line sequence BR_2_LF, -- Replaces all
HTML tags by LF characters Capitalize, -- Lower case except char before spaces and underscores Clean_Text, -- Only letter/digits all other chars are changed to spaces Coma_2_Point, -- Replaces comas by points Contract, -- Replaces a suite of spaces by a single space character Del_Param, -- Delete an HTTP parameter from the string, removes the '&' -- Parameter separator if needed. Div, -- Divide the given parameter to the string Exist, -- Returns "TRUE" if var is not empty and "FALSE" otherwise File_Exists, -- Returns "TRUE" if var is the name of an existing file and "FALSE" -- otherwise. Format_Date, -- Returns the date formatted using the format parameter. This -- format is following the GNU/date as implemented in -- GNAT.Calendar.Time_IO. The date must be in the ISO format -- YYYY-MM-DD eventually followed by a space and the time with the -- format HH:MM:SS. So the string must be either 10 or 19 characters -- long. Format_Number, -- Returns the number with a space added between each 3 digits -- blocks. The decimal part is not transformed. If the data is not a -- number nothing is done. The data is trimmed before processing it. Is_Empty, -- Returns "TRUE" if var is empty and "FALSE" otherwise LF_2_BR, -- Replaces all LF character to
HTML tag Lower, -- Lower case Match, -- Returns "TRUE" if var match the pattern passed as argument Max, -- Returns the max between the filter parameter and the value Min, -- Returns the min between the filter parameter and the value Modulo, -- Returns current value modulo N (N is the filter parameter) Mult, -- Multiply the given parameter to the string Neg, -- Change the size of the value No_Digit, -- Replace all digits by spaces No_Dynamic, -- This is a command filter, it indicates that the variable even if -- not found in the translation table will not be looked up into the -- dynamic context (Lazy_Tag). This filter just returns the string -- as-is. No_Letter, -- Removes all letters by spaces No_Space, -- Removes all spaces found in the value Oui_Non, -- If True return Oui, If False returns Non, else do nothing Point_2_Coma, -- Replaces points by comas Repeat, -- Returns N copy of the original string. The number of copy is -- passed as parameter. Replace, -- Replaces part of the string using a regultar expression. This is -- equivalent to the well known "s///" sed -- command. It replaces only the first match. Replace_All, -- Idem as above, but replace all matches. This equivalent to the -- well known "s///g" sed command. Replace_Param, -- Idem as @_ADD_PARAM(key=value):DEL_PARAM(key):VAR_@ Invert, -- Reverse string Size, -- Returns the number of characters in the string value Slice, -- Returns a slice of the string Strip, -- Trim leading and trailing spaces and characters HT, LF, CR, NUL Sub, -- Substract the given parameter to the string Trim, -- Trim leading and trailing space Upper, -- Upper case User_Defined, -- A user's defined filter Web_Encode, -- Idem as Web_Escape and also encode non 7-bit ASCII characters as -- &#xxx;. Web_Escape, -- Convert characters <>&" to HTML equivalents: <, > and & -- and " Web_NBSP, -- Convert spaces to HTML   - non breaking spaces Wrap, -- Wrap lines longer than a given number of characters Yes_No -- If True return Yes, If False returns No, else do nothing ); type User_CB_Type is (With_Param, No_Param, As_Tagged); type User_CB (Typ : User_CB_Type := With_Param) is record case Typ is when With_Param => CBP : Callback; when No_Param => CB : Callback_No_Param; when As_Tagged => CBT : User_Filter_Access; end case; end record; type Parameter_Mode is (Str, Regexp, Regpat, Slice, User_Callback); function Parameter (Mode : Filter.Mode) return Parameter_Mode; -- Returns the parameter mode for the given filter type Pattern_Matcher_Access is access GNAT.Regpat.Pattern_Matcher; type Parameter_Data (Mode : Parameter_Mode := Slice) is record case Mode is when Str => S : Unbounded_String; when Regexp => R_Str : Unbounded_String; Regexp : Pattern_Matcher_Access; when Regpat => P_Str : Unbounded_String; Regpat : Pattern_Matcher_Access; Param : Unbounded_String; when Slice => First : Integer; Last : Integer; when User_Callback => Handler : User_CB; P : Unbounded_String; end case; end record; No_Parameter : constant Parameter_Data := Parameter_Data'(Slice, 0, -1); function Image (P : Parameter_Data) return String; -- Returns parameter string representation procedure Release (P : in out Parameter_Data) with Inline; -- Release all memory allocated P type Filter_Context (P_Size : Natural) is record Translations : Translate_Set; Lazy_Tag : Dynamic.Lazy_Tag_Access; I_Parameters : Parameter_Set (1 .. P_Size); end record; type Callback is access function (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; -- P is the filter parameter, no parameter by default. Parameter are -- untyped and will be parsed by the filter function if needed. type Routine is record Handle : Callback; Parameters : Parameter_Data; end record; type Set is array (Positive range <>) of Routine; type Set_Access is access Set; procedure Release (S : in out Set); -- Release all memory allocated P type String_Access is access constant String; type Filter_Record is record Name : String_Access; Handle : Callback; end record; -- User's filter procedure Register (Name : String; Handler : Templates_Parser.Callback); procedure Register (Name : String; Handler : Callback_No_Param); procedure Register (Name : String; Handler : not null access User_Filter'Class); procedure Free_Filters; function User_Handle (Name : String) return User_CB; -- Returns the registered user's callback for the given filter name -- filter functions, see above procedure Check_Null_Parameter (P : Parameter_Data); -- Raises Template_Error if P is not equal to Null_Parameter function Absolute (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Add_Param (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function BR_2_EOL (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function BR_2_LF (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Capitalize (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Clean_Text (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Coma_2_Point (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Contract (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Del_Param (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Exist (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function File_Exists (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Format_Date (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Format_Number (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Is_Empty (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function LF_2_BR (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Lower (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Match (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Max (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Min (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Neg (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function No_Digit (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function No_Dynamic (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function No_Letter (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function No_Space (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Oui_Non (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Point_2_Coma (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Repeat (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Replace (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Replace_All (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Replace_Param (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Reverse_Data (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Size (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Slice (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Strip (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Trim (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Upper (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function User_Defined (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Web_Encode (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Web_Escape (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Web_NBSP (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Wrap (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Yes_No (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Plus (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Minus (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Divide (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Multiply (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Modulo (S : String; C : not null access Filter_Context; P : Parameter_Data := No_Parameter) return String; function Handle (Name : String) return Callback; -- Returns the filter function for the given filter name function Handle (Mode : Filter.Mode) return Callback; -- Returns the filter function for the given filter mode function Mode_Value (Name : String) return Mode; -- Returns the Mode for filter named Name. This is the internal -- representation for this filter name. function Name (Handle : Callback) return String; -- Returns the filter name for the given filter function function Is_No_Dynamic (Filters : Set_Access) return Boolean; -- Returns True if Filters contains NO_CONTEXT end Filter; --------------- -- Main tree -- --------------- type Node; type Tree is access Node; ---------- -- Data -- ---------- package Data is type Node; type Tree is access Node; type NKind is (Text, Var); type Attribute is (Nil, Length, Line, Min_Column, Max_Column, Up_Level, Indent); type Internal_Tag is (No, Now, Year, Month, Month_Name, Day, Day_Name, Hour, Minute, Second, Number_Line, Table_Line, Table_Level, Up_Table_Line); type Attribute_Data is record Attr : Attribute := Nil; Value : Integer; end record; No_Attribute : constant Attribute_Data := (Nil, 0); type Parameter_Set is array (Natural range <>) of Tree; type Parameters is access all Parameter_Set; type Tag_Var is record Name : Unbounded_String; Filters : Filter.Set_Access; Attribute : Attribute_Data; N : Integer; -- Include variable index Internal : Internal_Tag; -- No if not an internal variable Is_Macro : Boolean := False; -- True if this is a macro call Parameters : Data.Parameters; Def : Templates_Parser.Tree; end record; type Node (Kind : NKind) is record Next : Tree; Line : Natural; Col : Positive; -- first character position in the line case Kind is when Text => Value : Unbounded_String; when Var => Var : Tag_Var; end case; end record; function Is_Include_Variable (T : Tag_Var) return Boolean with Inline; -- Returns True if T is an include variable (Name is $) function To_Data_Parameters (Parameters : Templates_Parser.Parameter_Set) return Data.Parameters; -- Returns Parameters as a Data.Tree set function Build (Str : String) return Tag_Var; -- Create a Tag from Str. A tag is composed of a name and a set of -- filters. function Image (T : Tag_Var) return String; -- Returns string representation for the Tag variable function Translate (T : Tag_Var; Value : String; Context : not null access Filter.Filter_Context) return String; -- Returns the result of Value after applying all filters for tag T procedure Release (T : in out Tag_Var); -- Release all memory associated with Tag procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Parameter_Set, Parameters); function Parse (Content : String; Line : Natural) return Tree; -- Parse text line and returns the corresponding tree representation procedure Print_Tree (D : Tree); -- Decend the text tree and print it to the standard output procedure Release (D : in out Tree; Single : Boolean := False); -- Release all memory used by the tree or only the pointed node if -- Single is set to True. function Clone (D : Tree) return Tree; -- Returns a Clone of D function Clone (V : Tag_Var) return Tag_Var; -- Returns a Clone of V end Data; ----------------- -- Definitions -- ----------------- package Definitions is type NKind is (Const, Ref, Ref_Default); type Node (Kind : NKind := Const) is record Value : Unbounded_String; Ref : Positive; end record; type Def is record Name : Unbounded_String; N : Node; end record; type Tree is access Def; function Parse (Line : String) return Tree; -- Returns a defintion data package Def_Map is new Containers.Indefinite_Hashed_Maps (String, Node, Ada.Strings.Hash, "=", "="); subtype Map is Def_Map.Map; procedure Print_Tree (D : Tree); -- Decend the text tree and print it to the standard output procedure Release (D : in out Tree); -- Release all memory used by the tree function Clone (D : Tree) return Tree; -- Returns a Clone of D end Definitions; ------------------ -- Expressions -- ------------------ package Expr is type Ops is (O_And, O_Or, O_Xor, O_Cat, O_Sup, O_Inf, O_Esup, O_Einf, O_Equal, O_Diff, O_In); function Image (O : Ops) return String; -- Returns Ops string representation type U_Ops is (O_Not); function Image (O : U_Ops) return String; -- Returns U_Ops string representation type Node; type Tree is access Node; type NKind is (Value, Var, Op, U_Op); -- The node is a value, a variable a binary operator or an unary -- operator. type Node (Kind : NKind) is record Line : Natural; case Kind is when Value => V : Unbounded_String; when Var => Var : Data.Tag_Var; when Op => O : Ops; Left, Right : Tree; when U_Op => U_O : U_Ops; Next : Tree; end case; end record; function Is_True (Str : String) return Boolean with Inline; -- Return True if Str is one of "TRUE" or "T", the test is not -- case sensitive. function Parse (Expression : String; Line : Natural) return Tree; -- Parse Expression and returns the corresponding tree representation procedure Print_Tree (E : Tree); -- Decend the expression's tree and print the expression. It outputs the -- expression with all parenthesis to show without ambiguity the way the -- expression has been parsed. procedure Release (E : in out Tree; Single : Boolean := False); -- Release all associated memory with the tree function Clone (E : Tree) return Tree; -- Returns a Clone of E Unknown : constant String := "*"; -- Value returned when the expression cannot be determined statically function Analyze (E : Expr.Tree) return String; -- Static analysis of expresssion E, returns TRUE, FALSE or value -- Unknown if the value cannot be determined statically (some variables -- are in the expression). end Expr; -------------------------------- -- Template Tree definitions -- -------------------------------- type Nkind is (Info, -- first node is tree infos C_Info, -- second node is cache tree info Text, -- this is a text line Set_Stmt, -- a definition statement If_Stmt, -- an IF tag statement Table_Stmt, -- a TABLE tag statement Section_Block, -- a TABLE block (common, section) Section_Stmt, -- a TABLE section Include_Stmt, -- an INCLUDE tag statement Extends_Stmt, -- an EXTENDS tag statement Block_Stmt, -- a BLOCK tag statement Inline_Stmt); -- an INLINE tag statement -- A template line is coded as a suite of Data and Var elements -- The first node in the tree is of type Info and should never be release -- and changed. This ensure that included tree will always be valid -- otherwise will would have to parse all the current trees in the cache -- to update the reference. -- -- Static_Tree represent a Tree immune to cache changes. Info point to the -- first node and C_Info to the second one. C_Info could be different to -- Info.Next in case of cache changes. This way we keep a pointer to the -- old tree to be able to release it when not used anymore. This way it is -- possible to use the cache in multitasking program without trouble. The -- changes in the cache are either because more than one task is parsing -- the same template at the same time, they will update the cache with the -- same tree at some point, or because a newer template was found in the -- file system. type Static_Tree is record Info : Tree; C_Info : Tree; end record; Null_Static_Tree : constant Static_Tree := (null, null); package Tree_Map is new Containers.Indefinite_Hashed_Maps (String, Tree, Strings.Hash, "=", "="); type Included_File_Info is record File : Static_Tree; Filename : Data.Tree; Params : Data.Parameters; end record; package String_Set is new Containers.Indefinite_Vectors (Positive, String); type Node (Kind : Nkind) is record Next : Tree; Line : Natural; case Kind is when Info => Filename : Unbounded_String; -- Name of the file Timestamp : Configuration.Time_Stamp; -- Date/Time of last change I_File : Tree; -- Included file references; Nodes are Include_Stmt or -- Extends_Stmt when C_Info => Obsolete : Boolean := False; -- True if newer version in cache Used : Natural := 0; -- >0 if currently used when Text => Text : Data.Tree; when Set_Stmt => Def : Definitions.Tree; when If_Stmt => Cond : Expr.Tree; N_True : Tree; N_False : Tree; when Extends_Stmt => N_Extends : Tree; -- The BLOCK children E_Included : Included_File_Info; -- Extended file when Block_Stmt => B_Name : Unbounded_String; N_Block : Tree; when Table_Stmt => Terminate_Sections : Boolean; Reverse_Index : Boolean; Terse : Boolean; Align_On : String_Set.Vector; Blocks : Tree; Blocks_Count : Natural; -- Number if blocks when Section_Block => Common : Tree; Sections : Tree; Sections_Count : Natural; -- Number of sections when Section_Stmt => N_Section : Tree; when Include_Stmt => I_Included : Included_File_Info; when Inline_Stmt => Before : Unbounded_String; Sep : Unbounded_String; After : Unbounded_String; I_Block : Tree; end case; end record; procedure Release (T : in out Tree; Include : Boolean := True); -- Release all memory associated with the tree function Clone (T : Tree) return Tree; -- Returns a Clone of T procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Node, Tree); ------------------- -- Cached Files -- ------------------- -- Cached_Files keep the parsed Tree for a given file in memory. This -- package has two implementations one is thread safe so it is possible to -- use the cache in a multitasking program. The other is meant to be used -- for configuration that do not want to drag the tasking runtime. package Cached_Files is procedure Add (Filename : String; T : Tree; Old : out Tree); -- Add Filename/T to the list of cached files. If Filename is -- already in the list, replace the current tree with T. Furthermore -- if Filename tree is already in use, Old will be set with the -- previous C_Info node otherwise Old will be T.Next (C_Info node -- for current tree). procedure Get (Filename : String; Result : out Static_Tree); -- Returns the Tree for Filename or Null_Static_Tree if Filename has -- not been cached or is obsolete. procedure Release (T : in out Static_Tree); -- After loading a tree and using it, it is required that it be -- released. This will ensure that a tree marked as obsolete (a new -- version being now in the cache) will be released from the memory. procedure Release; -- Release the internal cache. This free the memory used for all -- currently loaded template trees. end Cached_Files; ----------- -- Macro -- ----------- package Macro is procedure Register (Name : String; T : not null Tree); -- Register a new macro definition, if previous definition exists, -- replace with the new definition. function Get (Name : String) return Tree; -- Get macro tree, returns null if this macro has no definition procedure Rewrite (T : in out Tree; Parameters : not null access Data.Parameter_Set); -- Rewrite the macro tree with the given parameters. All @_1_@ -- parameters in the macro definition are replaced with the -- corresponding value in the parameter set. procedure Print_Defined_Macros; -- Print the defined macros (for debug purpose) Callback : Macro_Callback; end Macro; ---------------- -- Simplifier -- ---------------- package Simplifier is procedure Run (T : in out Tree); -- Execute a tree simplifier pass, removes statically known IF branch -- and merges all consecutive TEXT node. end Simplifier; --------- -- Tag -- --------- procedure Field (T : Tag; N : Positive; Result : out Tag_Node_Access; Found : out Boolean); -- Returns the Nth item in Tag procedure Field (T : Tag; Cursor : Indices; Up_Value : Natural; Result : out Unbounded_String; Found : out Boolean); -- Returns Value in Tag at position Cursor. Found is set to False if -- there is no such value in Tag. function No_Quote (Str : String) return String; -- Removes quotes around Str. If Str (Str'First) and Str (Str'Last) -- are quotes return Str (Str'First + 1 .. Str'Last - 1) otherwise -- return Str as-is. function Quote (Str : String) return String; -- Returns Str quoted if it contains spaces, otherwise just returns Str function Is_Number (S : String) return Boolean with Inline; -- Returns True if S is a decimal number procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access); procedure Unchecked_Free is new Unchecked_Deallocation (Tag_Node_Arr, Tag_Node_Arr_Access); function Build_Include_Pathname (Filename, Include_Filename : String) return String; -- Returns the full pathname to the include file (Include_Filename). It -- returns Include_Filename if there is a pathname specified, or the -- pathname of the main template file as a prefix of the include -- filename. function Load (Filename : String; Cached : Boolean := False; Include_File : Boolean := False) return Static_Tree; -- Load a template file and returns the semantic tree. The template file is -- cached if Cached is set to true. If cached next Load will use the -- preparsed tree. procedure Print_Tree (T : Tree; Level : Natural := 0); -- Print the semantic tree, this is mostly for debugging purpose --------- -- "&" -- --------- function "&" (T : Tag; Value : String) return Tag is Item : constant Tag_Node_Access := new Tag_Node' (Templates_Parser.Value, null, V => To_Unbounded_String (Value)); begin T.Ref_Count.all := T.Ref_Count.all + 1; Unchecked_Free (T.Data.Tag_Nodes); if T.Data.Head = null then T.Data.all := (T.Data.Count + 1, Min => Natural'Min (T.Data.Min, 1), Max => Natural'Max (T.Data.Max, 1), Nested_Level => 1, Separator => To_Unbounded_String (Default_Separator), Head => Item, Last => Item, Tag_Nodes => null, Values => null); return (Ada.Finalization.Controlled with T.Ref_Count, Data => T.Data); else T.Data.Last.Next := Item; T.Data.all := (T.Data.Count + 1, Min => Natural'Min (T.Data.Min, 1), Max => Natural'Max (T.Data.Max, 1), Nested_Level => T.Data.Nested_Level, Separator => T.Data.Separator, Head => T.Data.Head, Last => Item, Tag_Nodes => null, Values => null); return (Ada.Finalization.Controlled with T.Ref_Count, Data => T.Data); end if; end "&"; function "&" (Value : String; T : Tag) return Tag is Item : constant Tag_Node_Access := new Tag_Node' (Templates_Parser.Value, T.Data.Head, V => To_Unbounded_String (Value)); begin T.Ref_Count.all := T.Ref_Count.all + 1; Unchecked_Free (T.Data.Tag_Nodes); if T.Data.Head = null then T.Data.all := (T.Data.Count + 1, Min => Natural'Min (T.Data.Min, 1), Max => Natural'Max (T.Data.Max, 1), Nested_Level => 1, Separator => To_Unbounded_String (Default_Separator), Head => Item, Last => Item, Tag_Nodes => null, Values => null); return (Ada.Finalization.Controlled with T.Ref_Count, T.Data); else T.Data.all := (T.Data.Count + 1, Min => Natural'Min (T.Data.Min, 1), Max => Natural'Max (T.Data.Max, 1), Nested_Level => T.Data.Nested_Level, Separator => T.Data.Separator, Head => Item, Last => T.Data.Last, Tag_Nodes => null, Values => null); return (Ada.Finalization.Controlled with T.Ref_Count, T.Data); end if; end "&"; function "&" (T : Tag; Value : Tag) return Tag is Item : constant Tag_Node_Access := new Tag_Node'(Value_Set, null, new Tag'(Value)); T_Size : constant Natural := Size (Value); begin T.Ref_Count.all := T.Ref_Count.all + 1; Unchecked_Free (T.Data.Tag_Nodes); if T.Data.Head = null then T.Data.all := (T.Data.Count + 1, Min => Natural'Min (T.Data.Min, T_Size), Max => Natural'Max (T.Data.Max, T_Size), Nested_Level => Value.Data.Nested_Level + 1, Separator => To_Unbounded_String ((1 => ASCII.LF)), Head => Item, Last => Item, Tag_Nodes => null, Values => null); return (Ada.Finalization.Controlled with T.Ref_Count, T.Data); else T.Data.Last.Next := Item; T.Data.all := (T.Data.Count + 1, Min => Natural'Min (T.Data.Min, T_Size), Max => Natural'Max (T.Data.Max, T_Size), Nested_Level => Positive'Max (T.Data.Nested_Level, Value.Data.Nested_Level + 1), Separator => T.Data.Separator, Head => T.Data.Head, Last => Item, Tag_Nodes => null, Values => null); return (Ada.Finalization.Controlled with T.Ref_Count, T.Data); end if; end "&"; function "&" (T : Tag; Value : Character) return Tag is begin return T & String'(1 => Value); end "&"; function "&" (T : Tag; Value : Boolean) return Tag is begin return T & Boolean'Image (Value); end "&"; function "&" (T : Tag; Value : Unbounded_String) return Tag is begin return T & To_String (Value); end "&"; function "&" (T : Tag; Value : Integer) return Tag is begin return T & Utils.Image (Value); end "&"; function "&" (Value : Character; T : Tag) return Tag is begin return String'(1 => Value) & T; end "&"; function "&" (Value : Boolean; T : Tag) return Tag is begin return Boolean'Image (Value) & T; end "&"; function "&" (Value : Unbounded_String; T : Tag) return Tag is begin return To_String (Value) & T; end "&"; function "&" (Value : Integer; T : Tag) return Tag is begin return Utils.Image (Value) & T; end "&"; function "&" (Left : Association; Right : Association) return Translate_Set is T : Translate_Set; begin Insert (T, Left); Insert (T, Right); return T; end "&"; function "&" (Set : Translate_Set; Item : Association) return Translate_Set is T : Translate_Set := Set; begin Insert (T, Item); return T; end "&"; --------- -- "+" -- --------- function "+" (Value : String) return Tag is Item : constant Tag_Node_Access := new Tag_Node'(Templates_Parser.Value, null, V => To_Unbounded_String (Value)); begin return (Ada.Finalization.Controlled with Ref_Count => new Integer'(1), Data => new Tag_Data' (Count => 1, Min => 1, Max => 1, Nested_Level => 1, Separator => To_Unbounded_String (Default_Separator), Head => Item, Last => Item, Tag_Nodes => null, Values => null)); end "+"; function "+" (Value : Character) return Tag is begin return +String'(1 => Value); end "+"; function "+" (Value : Boolean) return Tag is begin return +Boolean'Image (Value); end "+"; function "+" (Value : Unbounded_String) return Tag is begin return +To_String (Value); end "+"; function "+" (Value : Integer) return Tag is begin return +Utils.Image (Value); end "+"; function "+" (Value : Tag) return Tag is Result : Tag; begin Result := Result & Value; -- This is an embedded tag, set separator to LF Set_Separator (Result, (1 => ASCII.LF)); return Result; end "+"; function "+" (Item : Association) return Translate_Set is T : Translate_Set; begin Insert (T, Item); return T; end "+"; ------------ -- Adjust -- ------------ overriding procedure Adjust (Set : in out Translate_Set) is begin Templates_Parser_Tasking.Lock; if Set.Ref_Count = null then -- This is a not yet initialized null set. This case happens when -- assigning Null_Set to a Translate_Set variable for example. Initialize (Set); else Set.Ref_Count.all := Set.Ref_Count.all + 1; end if; Templates_Parser_Tasking.Unlock; end Adjust; overriding procedure Adjust (T : in out Tag) is begin Templates_Parser_Tasking.Lock; T.Ref_Count.all := T.Ref_Count.all + 1; Templates_Parser_Tasking.Unlock; end Adjust; ------------ -- Append -- ------------ procedure Append (T : in out Tag; Value : Tag) is Item : constant Tag_Node_Access := new Tag_Node'(Value_Set, null, new Tag'(Value)); T_Size : constant Natural := Size (Value); begin if T.Data.Head = null then T.Data.Nested_Level := Value.Data.Nested_Level + 1; T.Data.Separator := To_Unbounded_String ((1 => ASCII.LF)); T.Data.Head := Item; else T.Data.Last.Next := Item; T.Data.Nested_Level := Positive'Max (T.Data.Nested_Level, Value.Data.Nested_Level + 1); end if; Unchecked_Free (T.Data.Tag_Nodes); T.Data.Tag_Nodes := null; T.Data.Count := T.Data.Count + 1; T.Data.Min := Natural'Min (T.Data.Min, T_Size); T.Data.Max := Natural'Max (T.Data.Max, T_Size); T.Data.Last := Item; end Append; procedure Append (T : in out Tag; Value : Unbounded_String) is Item : constant Tag_Node_Access := new Tag_Node'(Templates_Parser.Value, null, Value); begin if T.Data.Head = null then T.Data.Head := Item; T.Data.Nested_Level := 1; T.Data.Separator := To_Unbounded_String (Default_Separator); else T.Data.Last.Next := Item; end if; Unchecked_Free (T.Data.Tag_Nodes); T.Data.Tag_Nodes := null; T.Data.Count := T.Data.Count + 1; T.Data.Min := Natural'Min (T.Data.Min, 1); T.Data.Max := Natural'Max (T.Data.Max, 1); T.Data.Last := Item; end Append; procedure Append (T : in out Tag; Value : String) is begin Append (T, To_Unbounded_String (Value)); end Append; procedure Append (T : in out Tag; Value : Character) is begin Append (T, To_Unbounded_String (String'(1 => Value))); end Append; procedure Append (T : in out Tag; Value : Boolean) is begin Append (T, To_Unbounded_String (Boolean'Image (Value))); end Append; procedure Append (T : in out Tag; Value : Integer) is begin Append (T, To_Unbounded_String (Utils.Image (Value))); end Append; ----------- -- Assoc -- ----------- function Assoc (Variable : String; Value : String) return Association is begin return Association' (Std, Variable => To_Unbounded_String (Variable), Value => To_Unbounded_String (Value)); end Assoc; function Assoc (Variable : String; Value : Ada.Strings.Unbounded.Unbounded_String) return Association is begin return Assoc (Variable, To_String (Value)); end Assoc; function Assoc (Variable : String; Value : Integer) return Association is begin return Assoc (Variable, Utils.Image (Value)); end Assoc; function Assoc (Variable : String; Value : Boolean) return Association is begin if Value then return Assoc (Variable, "TRUE"); else return Assoc (Variable, "FALSE"); end if; end Assoc; function Assoc (Variable : String; Value : Tag; Separator : String := Default_Separator) return Association is T : Tag := Value; begin if Separator /= Default_Separator then Set_Separator (T, Separator); end if; return Association' (Composite, Variable => To_Unbounded_String (Variable), Comp_Value => T); end Assoc; ---------------------------- -- Build_Include_Pathname -- ---------------------------- function Build_Include_Pathname (Filename, Include_Filename : String) return String is Dir_Seps : constant Maps.Character_Set := Maps.To_Set ("/\"); begin if Include_Filename'Length > 1 and then Maps.Is_In (Include_Filename (Include_Filename'First), Dir_Seps) then -- Include filename is an absolute path, return it without the -- leading directory separator. return Include_Filename (Include_Filename'First + 1 .. Include_Filename'Last); elsif Include_Filename'Length > 2 and then Include_Filename (Include_Filename'First) = '.' and then Maps.Is_In (Include_Filename (Include_Filename'First + 1), Dir_Seps) then return Include_Filename; else declare K : constant Natural := Fixed.Index (Filename, Dir_Seps, Going => Strings.Backward); begin if K = 0 then return Include_Filename; else return Filename (Filename'First .. K) & Include_Filename; end if; end; end if; end Build_Include_Pathname; ------------------ -- Cached_Files -- ------------------ package body Cached_Files is separate; ----------- -- Macro -- ----------- package body Macro is separate; ---------------- -- Simplifier -- ---------------- package body Simplifier is separate; ----------- -- Clear -- ----------- procedure Clear (T : in out Tag) is NT : Tag; begin -- Here we just separate current vector from the new one T := NT; end Clear; ----------- -- Clone -- ----------- function Clone (T : Tree) return Tree is procedure Clone (Included : in out Included_File_Info); -- Clone the fields in Included procedure Clone (Included : in out Included_File_Info) is begin Included.Filename := Data.Clone (Included.Filename); Included.Params := new Data.Parameter_Set'(Included.Params.all); for K in Included.Params'Range loop Included.Params (K) := Data.Clone (Included.Params (K)); end loop; end Clone; N : Tree; begin if T /= null then N := new Node'(T.all); case N.Kind is when Text => N.Text := Data.Clone (N.Text); when Info => N.I_File := Clone (N.I_File); when If_Stmt => N.Cond := Expr.Clone (N.Cond); N.N_True := Clone (N.N_True); N.N_False := Clone (N.N_False); when Table_Stmt => N.Blocks := Clone (N.Blocks); when Extends_Stmt => N.N_Extends := Clone (N.N_Extends); Clone (N.E_Included); when Block_Stmt => N.N_Block := Clone (N.N_Block); when Section_Block => N.Common := Clone (N.Common); N.Sections := Clone (N.Sections); when Section_Stmt => N.N_Section := Clone (N.N_Section); when Inline_Stmt => N.I_Block := Clone (N.I_Block); when Set_Stmt => N.Def := Definitions.Clone (N.Def); when Include_Stmt => Clone (N.I_Included); when C_Info => null; end case; N.Next := Clone (N.Next); end if; return N; end Clone; --------------- -- Composite -- --------------- function Composite (T : Tag; N : Positive) return Tag is Result : Tag; Found : Boolean; begin Field (T, N, Result, Found); if Found then return Result; else raise Constraint_Error; end if; end Composite; ---------- -- Data -- ---------- package body Data is separate; ----------------- -- Definitions -- ----------------- package body Definitions is separate; ------------ -- Exists -- ------------ function Exists (Set : Translate_Set; Variable : String) return Boolean is begin return Set.Set.Contains (Variable); end Exists; ---------- -- Expr -- ---------- package body Expr is separate; ----------- -- Field -- ----------- procedure Field (T : Tag; N : Positive; Result : out Tag_Node_Access; Found : out Boolean) is begin Found := True; -- First check that the array access is present if T.Data.Tag_Nodes = null then T.Data.Tag_Nodes := new Tag_Node_Arr (1 .. T.Data.Count); declare P : Tag_Node_Access := T.Data.Head; begin for K in T.Data.Tag_Nodes'Range loop T.Data.Tag_Nodes (K) := P; P := P.Next; end loop; end; end if; if N > T.Data.Count then -- No such item for this position Result := null; Found := False; else Result := T.Data.Tag_Nodes (N); end if; end Field; procedure Field (T : Tag; N : Positive; Result : out Tag; Found : out Boolean) is R : Tag_Node_Access; begin Field (T, N, R, Found); if Found and then R.Kind = Value_Set then -- There is a Tag at this position, return it Result := R.VS.all; else Found := False; end if; end Field; procedure Field (T : Tag; Cursor : Indices; Up_Value : Natural; Result : out Unbounded_String; Found : out Boolean) is function Image (T : Tag) return Unbounded_String; -- Returns T string representation ----------- -- Image -- ----------- function Image (T : Tag) return Unbounded_String is function Image (N : Tag_Node) return Unbounded_String; -- Returns N string representation ----------- -- Image -- ----------- function Image (N : Tag_Node) return Unbounded_String is begin if N.Kind = Value then return N.V; else return Image (N.VS.all); end if; end Image; Result : Unbounded_String; N : Tag_Node_Access := T.Data.Head; begin while N /= null loop if Result /= Null_Unbounded_String then Append (Result, T.Data.Separator); end if; Append (Result, Image (N.all)); N := N.Next; end loop; return Result; end Image; C : Natural := 0; P : Natural := 0; R : Tag_Node_Access; Inlined : Boolean := False; begin Found := True; if Cursor'Length <= Up_Value then -- The current cursor length is smaller than the up_level attribute -- in this case we just inline the tag. Inlined := True; elsif Cursor'Length > T.Data.Nested_Level then C := Cursor'Last - T.Data.Nested_Level + 1 - Up_Value; P := Cursor (C); elsif Cursor'Length /= 0 then C := Cursor'First; P := Cursor (C); end if; if Inlined then Result := Image (T); else Field (T, P, R, Found); end if; if R /= null then -- We have found something at this indice if C + Up_Value = Cursor'Last then -- This is the last position if R.Kind = Value then -- Found a leaf, just return the value Result := R.V; else Result := Image (R.VS.all); end if; else -- There is more position to look for in the cursor if R.Kind = Value then -- This is a leaf, there is nothing more to look for Found := False; Result := Null_Unbounded_String; else -- Look into next dimension Field (R.VS.all, Cursor (C + 1 .. Cursor'Last), Up_Value, Result, Found); end if; end if; else Found := False; end if; end Field; ------------ -- Filter -- ------------ package body Filter is separate; -------------- -- Finalize -- -------------- overriding procedure Finalize (Set : in out Translate_Set) is procedure Unchecked_Free is new Unchecked_Deallocation (Association_Map.Map, Map_Access); Ref_Count : Integer_Access := Set.Ref_Count; begin -- Ensure call is idempotent Set.Ref_Count := null; if Ref_Count /= null then Templates_Parser_Tasking.Lock; Ref_Count.all := Ref_Count.all - 1; if Ref_Count.all = 0 then Unchecked_Free (Ref_Count); Unchecked_Free (Set.Set); end if; Templates_Parser_Tasking.Unlock; end if; end Finalize; overriding procedure Finalize (T : in out Tag) is Ref_Count : Integer_Access := T.Ref_Count; begin -- Ensure call is idempotent T.Ref_Count := null; if Ref_Count /= null then Templates_Parser_Tasking.Lock; Ref_Count.all := Ref_Count.all - 1; if Ref_Count.all = 0 then Templates_Parser_Tasking.Unlock; declare procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Tag_Node, Tag_Node_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Tag, Tag_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Tag_Data, Tag_Data_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Tag_Values.Set, Tag_Values_Access); P, N : Tag_Node_Access; begin P := T.Data.Head; while P /= null loop N := P.Next; if P.Kind = Value_Set then Unchecked_Free (P.VS); end if; Unchecked_Free (P); P := N; end loop; T.Data.Head := null; T.Data.Last := null; Unchecked_Free (Ref_Count); Unchecked_Free (T.Data.Tag_Nodes); Unchecked_Free (T.Data.Values); Unchecked_Free (T.Data); end; else Templates_Parser_Tasking.Unlock; end if; end if; end Finalize; --------------------------- -- For_Every_Association -- --------------------------- procedure For_Every_Association (Set : Translate_Set) is Pos : Association_Map.Cursor; Quit : Boolean := False; begin Pos := Set.Set.First; while Association_Map.Has_Element (Pos) loop Action (Association_Map.Element (Pos), Quit); exit when Quit; Pos := Association_Map.Next (Pos); end loop; end For_Every_Association; --------- -- Get -- --------- function Get (Set : Translate_Set; Name : String) return Association is Pos : Association_Map.Cursor; begin Pos := Set.Set.all.Find (Name); if Association_Map.Has_Element (Pos) then return Association_Map.Element (Pos); else return Null_Association; end if; end Get; function Get (Assoc : Association) return Tag is begin if Assoc.Kind = Composite then return Assoc.Comp_Value; else raise Constraint_Error; end if; end Get; function Get (Assoc : Association) return String is begin if Assoc.Kind = Std then return To_String (Assoc.Value); else raise Constraint_Error; end if; end Get; -------------------- -- Get_Parameters -- -------------------- function Get_Parameters (Parameters : String) return Parameter_Set is function Get (Count : Natural) return Parameter_Set; -- Load the Count parameters from Parameters string function Next (Char : Character; From : Positive) return Natural; -- Returns the position of the next character Char starting from -- position From. Returns 0 if the character is not found. This routine -- skips characters inside quoted string. --------- -- Get -- --------- function Get (Count : Natural) return Parameter_Set is procedure Get_Named_Parameters (Parameters : String); -- Load parameters specified with a name: -- (param_a, 5 => param_b, 3 => param_c) -- Set Result variable accordingly. procedure Get_Next_Parameter (Parameters : String; First : in out Positive; Last : out Natural; Next_Last : out Natural); -- Look for next parameter starting at position First, set First and -- Last to the index of this parameter. Next_Last is set to the next -- value to assigned to last. Result : Parameter_Set (1 .. Count); Index : Positive := Result'First; First, Last : Natural := 0; Next_Last : Natural; -------------------------- -- Get_Named_Parameters -- -------------------------- procedure Get_Named_Parameters (Parameters : String) is procedure Parse (Parameter : String); -- Parse one parameter Named : Boolean := False; First, Last : Natural; ----------- -- Parse -- ----------- procedure Parse (Parameter : String) is Sep : constant Natural := Strings.Fixed.Index (Parameter, "=>"); Ind : Natural; begin if Sep = 0 then -- A positional parameter, this is valid only if we have not -- yet found a named parameter. if Named then raise Internal_Error with "Can't have a positional parameter after a named one"; else Result (Index) := To_Unbounded_String (Parameter); Index := Index + 1; end if; else -- A named parameter, get index Named := True; declare Ind_Str : constant String := Strings.Fixed.Trim (Parameter (Parameter'First .. Sep - 1), Strings.Both); First, Last : Natural; Next_Last : Natural; pragma Unreferenced (Next_Last); begin if Is_Number (Ind_Str) then Ind := Natural'Value (Ind_Str); if Result (Ind) = Null_Unbounded_String then -- This parameter has not yet been found First := Sep + 2; Get_Next_Parameter (Parameter, First, Last, Next_Last); Result (Ind) := To_Unbounded_String (Parameter (First .. Last)); else raise Internal_Error with "Parameter" & Natural'Image (Ind) & " defined multiple time"; end if; else raise Internal_Error with "Wrong number in named parameter"; end if; end; end if; end Parse; begin if Parameters (Parameters'Last) /= ')' then raise Internal_Error with "Missing closing parenthesis in named include parameters"; end if; First := Parameters'First + 1; -- Skip the parenthesis loop Last := Strings.Fixed.Index (Parameters (First .. Parameters'Last), ","); exit when Last = 0; Parse (Strings.Fixed.Trim (Parameters (First .. Last - 1), Strings.Both)); First := Last + 1; end loop; -- Handle last parameter Parse (Strings.Fixed.Trim (Parameters (First .. Parameters'Last - 1), Strings.Both)); end Get_Named_Parameters; ------------------------ -- Get_Next_Parameter -- ------------------------ procedure Get_Next_Parameter (Parameters : String; First : in out Positive; Last : out Natural; Next_Last : out Natural) is begin -- Skip blanks while First < Parameters'Last and then (Parameters (First) = ' ' or else Parameters (First) = ASCII.HT) loop First := First + 1; end loop; -- Look for end of parameter Next_Last := First + 1; if Parameters (First) = '"' then -- Look for closing quote while Next_Last < Parameters'Last and then Parameters (Next_Last) /= '"' loop Next_Last := Next_Last + 1; end loop; if Parameters (Next_Last) /= '"' then raise Internal_Error with "Missing closing quote in include parameters"; end if; -- Skip quotes First := First + 1; Last := Next_Last - 1; else -- Look for end of word while Next_Last < Parameters'Last and then Parameters (Next_Last) /= ' ' and then Parameters (Next_Last) /= ASCII.HT loop Next_Last := Next_Last + 1; end loop; if Next_Last /= Parameters'Last then Last := Next_Last - 1; else Last := Next_Last; end if; end if; end Get_Next_Parameter; begin First := Parameters'First; while First <= Parameters'Last loop -- Skip blanks while First < Parameters'Last and then (Parameters (First) = ' ' or else Parameters (First) = ASCII.HT) loop First := First + 1; end loop; -- Check if parameters are specified with a name if Index = 1 and then Parameters (First) = '(' then -- Stop current processing, load as named parameters Get_Named_Parameters (Parameters (First .. Parameters'Last)); return Result; end if; Get_Next_Parameter (Parameters, First, Last, Next_Last); Result (Index) := To_Unbounded_String (Parameters (First .. Last)); Index := Index + 1; Last := Next_Last; First := Last + 1; end loop; return Result; end Get; ---------- -- Next -- ---------- function Next (Char : Character; From : Positive) return Natural is In_Quote : Boolean := False; Index : Natural := 0; begin for K in From .. Parameters'Last loop if Parameters (K) = '"' then In_Quote := not In_Quote; elsif Parameters (K) = Char and then not In_Quote then Index := K; exit; end if; end loop; return Index; end Next; Count : Natural := 0; Index : Natural := Parameters'First - 1; begin -- Count parameters if Parameters'First <= Parameters'Last then Count := 1; if Parameters (Parameters'First) = '(' then -- We are using the parentherized form with parameters separated -- with coma and possibly using the named notation. -- Count positional parameters loop Index := Next (',', Index + 1); exit when Index = 0; Count := Count + 1; end loop; -- Then check for named ones declare SP, EP : Natural; Sep : Natural := Parameters'First; begin loop Sep := Strings.Fixed.Index (Parameters, "=>", From => Sep); exit when Sep = 0; EP := Sep - 1; -- Skip spaces while EP > Parameters'First and then Parameters (EP) = ' ' loop EP := EP - 1; end loop; SP := EP; -- Get number while SP > Parameters'First and then Strings.Maps.Is_In (Parameters (SP - 1), Strings.Maps.Constants.Decimal_Digit_Set) loop SP := SP - 1; end loop; if Parameters (EP) in '0' .. '9' then Count := Natural'Max (Count, Natural'Value (Parameters (SP .. EP))); end if; Sep := Sep + 1; end loop; end; else -- We are using the standard form, parameters are separated by -- spaces. loop Index := Next (' ', Index + 1); exit when Index = 0; -- Skip multiple spaces while Index < Parameters'Last and then Parameters (Index + 1) = ' ' loop Index := Index + 1; end loop; Count := Count + 1; end loop; end if; end if; return Get (Count); end Get_Parameters; ---------------- -- Initialize -- ---------------- overriding procedure Initialize (Set : in out Translate_Set) is begin Set.Ref_Count := new Integer'(1); Set.Set := new Association_Map.Map; end Initialize; overriding procedure Initialize (T : in out Tag) is begin T.Ref_Count := new Integer'(1); T.Data := new Tag_Data; T.Data.Count := 0; T.Data.Min := Natural'Last; T.Data.Max := 0; T.Data.Nested_Level := 1; end Initialize; ------------ -- Insert -- ------------ procedure Insert (Set : in out Translate_Set; Item : Association) is begin Set.Set.Include (To_String (Item.Variable), Item); end Insert; procedure Insert (Set : in out Translate_Set; Items : Translate_Set) is Pos : Association_Map.Cursor; begin if Items.Set = null then return; end if; Pos := Items.Set.First; while Association_Map.Has_Element (Pos) loop Insert (Set, Association_Map.Element (Pos)); Pos := Association_Map.Next (Pos); end loop; end Insert; --------------- -- Is_Number -- --------------- function Is_Number (S : String) return Boolean is use Strings.Maps; begin return S'Length > 0 and then Is_Subset (To_Set (S), Constants.Decimal_Digit_Set or To_Set ("-")); end Is_Number; ---------- -- Item -- ---------- function Item (T : Tag; N : Positive) return String is Result : Unbounded_String; Found : Boolean; begin Field (T, (1 => N), 0, Result, Found); if not Found then raise Constraint_Error; else return To_String (Result); end if; end Item; ---------- -- Load -- ---------- function Load (Filename : String; Cached : Boolean := False; Include_File : Boolean := False) return Static_Tree is File : Input.File_Type; -- file beeing parsed Buffer : String (1 .. 2_048); -- current line content Last : Natural; -- index of last characters read in buffer First : Natural; -- first non blank characters in buffer Line : Natural := 0; I_File : Tree; -- list of includes Error_Include_Message : Unbounded_String; -- Message as reported while parsing the include file -- Line handling procedure Fatal_Error (Message : String) with No_Return; -- raise Template_Error exception with message function Get_Next_Line return Boolean; -- Get new line in File and set Buffer, Last and First. Returns True if -- end of file reached. function Get_First_Parameter return Unbounded_String; -- Get first parameter in current line (second word), words being -- separated by a set of blank characters (space or horizontal -- tabulation). function Get_All_Parameters (At_Least_One : Boolean := True) return String; -- Get all parameters on the current line function Get_Tag_Attributes_Count return Natural; -- Returns the number of tag attributes present function Get_Tag_Attribute (N : Positive) return String; -- Returns the Nth tag attribute function Get_Tag_Attribute_Parameter_Count (Attribute_Number : Positive) return Natural; -- Returns the number of tag attribute parameters for the given -- attribute number. function Get_Tag_Attribute_Parameter (Attribute_Number, N : Positive) return String; -- Returns the Nth attribute's parameter for the given attribute number function Get_Tag_Attribute_Parameter_Internal (Attribute_Number, N : Positive; Count : out Natural) return String; -- Returns both the number of attribute parameter's and the Nth -- parameter. function Get_Tag_Parameter (N : Positive) return String; -- Returns the Nth tag parameter found between parenthesis function Get_Tag_Parameter_Count return Natural; -- Returns the number of parameter function Is_Stmt (Stmt : String; Extended : Boolean := False) return Boolean with Inline; -- Returns True if Stmt is found at the begining of the current line -- ignoring leading blank characters. If Extended is True it recognize -- statement attributes or parameter. function EOF return Boolean with Inline; -- Returns True if the end of file has been reach type Parse_Mode is (Parse_Std, -- in standard line Parse_If, -- in a if statement Parse_Elsif, -- in elsif part of a if statement Parse_Else, -- in else part of a if statement Parse_Extends, -- in an extends statement Parse_Block, -- in an extends' block statement Parse_Table, -- in a table statement Parse_Table_Block, -- in a table block statement Parse_Section, -- in new section Parse_Section_Content, -- in section content Parse_Inline, -- in an inline block statement Parse_Macro -- in a macro definition ); function Parse (Mode : Parse_Mode; In_If : Boolean; No_Read : Boolean := False) return Tree; -- Get a line in File and returns the Tree --------- -- EOF -- --------- function EOF return Boolean is begin return Last = 0; end EOF; ----------------- -- Fatal_Error -- ----------------- procedure Fatal_Error (Message : String) is begin if Message (Message'Last) /= '.' then raise Template_Error with Message & ", in " & Filename & " at line" & Natural'Image (Line); else raise Template_Error with Message & ", included from " & Filename & " at line" & Natural'Image (Line); end if; end Fatal_Error; ------------------------ -- Get_All_Parameters -- ------------------------ function Get_All_Parameters (At_Least_One : Boolean := True) return String is Start : Natural; Offset : Natural := 0; begin -- Skip first word (tag statement, or include file name) if First < Last and then Buffer (First .. First + 1) = "@@" then Start := Strings.Fixed.Index (Buffer (First + 2 .. Last), "@@"); Offset := 2; else Start := Strings.Fixed.Index (Buffer (First .. Last), Blank); end if; if Start = 0 or else Start + Offset >= Last then if At_Least_One then Fatal_Error ("missing parameter"); else Start := Last + 1; end if; else Start := Start + Offset; end if; if Buffer (Last) = ASCII.CR then -- Last character is a DOS CR (certainly because the template -- file is in DOS format), ignore it as this is not part of the -- parameter. Last := Last - 1; end if; return Strings.Fixed.Trim (Buffer (Start .. Last), Left => Blank, Right => Blank); end Get_All_Parameters; ------------------------- -- Get_First_Parameter -- ------------------------- function Get_First_Parameter return Unbounded_String is Start, Stop : Natural; Offset : Natural := 0; begin if First < Last and then Buffer (First .. First + 1) = "@@" then Start := Strings.Fixed.Index (Buffer (First + 2 .. Last), "@@"); Offset := 2; else Start := Strings.Fixed.Index (Buffer (First .. Last), Blank); end if; if Start = 0 or else Start + Offset >= Last then return Null_Unbounded_String; else Start := Start + Offset; end if; Start := Strings.Fixed.Index (Buffer (Start .. Last), Blank, Outside); if Start = 0 then -- We have only spaces after the first word, there is no -- parameter in this case. return Null_Unbounded_String; end if; Stop := Strings.Fixed.Index (Buffer (Start .. Last), Blank); if Stop = 0 then Stop := Last; else Stop := Stop - 1; end if; return To_Unbounded_String (Buffer (Start .. Stop)); end Get_First_Parameter; ------------------- -- Get_Next_Line -- ------------------- function Get_Next_Line return Boolean is use type Maps.Character_Set; Skip_End : constant Maps.Character_Set := Blank or Maps.To_Set (ASCII.CR); begin if Input.End_Of_File (File) then Last := 0; return True; else loop Line := Line + 1; Input.Get_Line (File, Buffer, Last); First := Strings.Fixed.Index (Buffer (1 .. Last), Blank, Outside); exit when First + 3 > Last or else (First >= Buffer'First and then Buffer (First .. First + 3) /= "@@--"); if Input.End_Of_File (File) then -- We have reached the end of file, exit now Last := 0; return True; end if; end loop; if First = 0 then -- There is only spaces on this line, this is an empty line -- we just have to skip it. Last := 0; return False; end if; -- Skip ending comments declare C : Natural; begin C := Strings.Fixed.Index (Buffer (First .. Last), "@@--"); if C /= 0 then Last := C - 1; end if; end; Last := Strings.Fixed.Index (Buffer (First .. Last), Skip_End, Outside, Strings.Backward); return False; end if; end Get_Next_Line; ----------------------- -- Get_Tag_Attribute -- ----------------------- function Get_Tag_Attribute (N : Positive) return String is S : Positive := First + 2; L : constant Natural := Strings.Fixed.Index (Buffer (S .. Last), "@@"); E : Natural; begin for I in 1 .. N loop S := Strings.Fixed.Index (Buffer (S + 1 .. L), "'"); end loop; -- Check for the end of this attribute declare E1 : constant Natural := Strings.Fixed.Index (Buffer (S + 1 .. L), "'"); E2 : constant Natural := Strings.Fixed.Index (Buffer (S + 1 .. L), "("); begin if E1 > 0 and then (E1 < E2 or else E2 = 0) then E := E1; else E := E2; end if; end; if E = 0 then E := L; end if; return Buffer (S + 1 .. E - 1); end Get_Tag_Attribute; --------------------------------- -- Get_Tag_Attribute_Parameter -- --------------------------------- function Get_Tag_Attribute_Parameter (Attribute_Number, N : Positive) return String is Count : Natural := 0; begin return Get_Tag_Attribute_Parameter_Internal (Attribute_Number, N, Count); end Get_Tag_Attribute_Parameter; --------------------------------------- -- Get_Tag_Attribute_Parameter_Count -- --------------------------------------- function Get_Tag_Attribute_Parameter_Count (Attribute_Number : Positive) return Natural is Count : Natural := 0; A : constant String := Get_Tag_Attribute_Parameter_Internal (Attribute_Number, 1, Count) with Unreferenced; begin return Count; end Get_Tag_Attribute_Parameter_Count; ------------------------------------------ -- Get_Tag_Attribute_Parameter_Internal -- ------------------------------------------ function Get_Tag_Attribute_Parameter_Internal (Attribute_Number, N : Positive; Count : out Natural) return String is Attribute : constant String := Get_Tag_Attribute (Attribute_Number); Start : constant Positive := Strings.Fixed.Index (Buffer (First .. Last), Attribute) + Attribute'Length + 1; In_Param : Boolean := False; S, E : Positive; -- parameter is between S and E begin Count := 0; Check_Parameters : for K in Start .. Last loop if Buffer (K) = '"' then if In_Param then In_Param := False; -- End of param being looked for if Count = N then E := K - 1; end if; else In_Param := True; Count := Count + 1; -- New parameter is the one looked for, record start if Count = N then S := K + 1; end if; end if; elsif not In_Param and then Buffer (K) = ')' then exit Check_Parameters; elsif not In_Param and then Buffer (K) not in ' ' | ',' then Fatal_Error ("expecting coma between parameters"); end if; end loop Check_Parameters; return Buffer (S .. E); end Get_Tag_Attribute_Parameter_Internal; ------------------------------- -- Get_Tag_Attributes_Count -- ------------------------------- function Get_Tag_Attributes_Count return Natural is K : constant Natural := Strings.Fixed.Index (Buffer (First + 2 .. Last), "@@"); begin return Strings.Fixed.Count (Buffer (First + 2 .. K), "'"); end Get_Tag_Attributes_Count; ----------------------- -- Get_Tag_Parameter -- ----------------------- function Get_Tag_Parameter (N : Positive) return String is I_Last : constant Natural := Strings.Fixed.Index (Buffer (First .. Last), ")@@"); function Find_Matching (From : Natural; Char : Character) return Natural; -- Returns the position of Char in Buffer, handle escaped characters ------------------- -- Find_Matching -- ------------------- function Find_Matching (From : Natural; Char : Character) return Natural is K : Natural := From; Level : Integer; Escape : Integer := 0; begin if Char = ')' and then Buffer (K) = '(' then Level := 0; elsif Char = '(' then Level := -1; else Level := 1; end if; Look_For_Char : while K < I_Last loop if Buffer (K) = '\' and then Escape = 0 then Escape := 2; end if; if Escape = 0 then if Buffer (K) = '(' then Level := Level + 1; elsif Buffer (K) = ')' then Level := Level - 1; end if; exit Look_For_Char when Buffer (K) = Char and then Level = 0; else Escape := Escape - 1; end if; K := K + 1; end loop Look_For_Char; return K; end Find_Matching; F, L : Natural; begin if I_Last = 0 then Fatal_Error ("No tag parameter"); else F := First; L := First - 1; for K in 1 .. N loop F := Find_Matching (L + 1, '('); if F = 0 then Fatal_Error ("Missing parenthesis in tag command"); else -- Look for matching closing parenthesis L := Find_Matching (F, ')'); if Buffer (L) /= ')' then Fatal_Error ("Missing closing parenthesis in tag command"); end if; end if; end loop; return Buffer (F + 1 .. L - 1); end if; end Get_Tag_Parameter; ----------------------------- -- Get_Tag_Parameter_Count -- ----------------------------- function Get_Tag_Parameter_Count return Natural is I_Last : constant Natural := Strings.Fixed.Index (Buffer (First .. Last), ")@@"); Count : Natural := 0; Level : Natural := 0; Escape : Integer := 0; begin if I_Last = 0 then return 0; else for K in First .. I_Last loop if Buffer (K) = '\' and then Escape = 0 then Escape := 2; end if; if Escape = 0 then if Buffer (K) = '(' then if Level = 0 then Count := Count + 1; end if; Level := Level + 1; elsif Buffer (K) = ')' then Level := Level - 1; end if; else Escape := Escape - 1; end if; end loop; return Count; end if; end Get_Tag_Parameter_Count; ------------- -- Is_Stmt -- ------------- function Is_Stmt (Stmt : String; Extended : Boolean := False) return Boolean is Offset : Natural := 0; begin if Extended then Offset := 2; end if; return Last >= First + Stmt'Length - 1 and then Buffer (First .. First + Stmt'Length - 1 - Offset) = Stmt (Stmt'First .. Stmt'Last - Offset) and then (not Extended or else (Buffer (First + Stmt'Length - Offset) = ''' or else Buffer (First + Stmt'Length - Offset) = '(' or else Buffer (First + Stmt'Length - Offset) = '@')); end Is_Stmt; ----------- -- Parse -- ----------- function Parse (Mode : Parse_Mode; In_If : Boolean; No_Read : Boolean := False) return Tree is use type Data.NKind; use type Data.Tree; function Count_Sections (T : Tree) return Natural with Inline; -- Returns the number of sections in T (Section_Stmt) function Count_Blocks (T : Tree) return Natural with Inline; -- Returns the number of sections in T (Table_Stmt) procedure Rewrite_Inlined_Block (T : Tree); -- Simplify the inline block by triming spaces. This is only the -- first step, the simplification will save some CPU cycle for each -- template rendering and makes the final inlining a bit more simple. procedure Parse_Included_File (Included : in out Included_File_Info; Error : out Boolean); -- Parse the include file and parameters for a @@INCLUDE@@ or -- @@EXTENDS@@ statement ------------------ -- Count_Blocks -- ------------------ function Count_Blocks (T : Tree) return Natural is C : Natural := 0; S : Tree := T; begin while S /= null loop C := C + 1; S := S.Next; end loop; return C; end Count_Blocks; -------------------- -- Count_Sections -- -------------------- function Count_Sections (T : Tree) return Natural is C : Natural := 0; S : Tree := T; begin while S /= null loop C := C + 1; S := S.N_Section; end loop; return C; end Count_Sections; ------------------------- -- Parse_Included_File -- ------------------------- procedure Parse_Included_File (Included : in out Included_File_Info; Error : out Boolean) is File : constant String := To_String (Get_First_Parameter); begin Error := False; Included.Filename := Data.Parse (File, Line); if Included.Filename.Kind = Data.Text and then Included.Filename.Next = null then -- In the case of static strings we load the include file -- now. declare I_Filename : constant String := Build_Include_Pathname (Filename, File); begin Included.File := Load (I_Filename, Cached, True); exception when IO_Exceptions.Name_Error => -- File not found, this is an error only if we are not -- inside a conditional. if not In_If then Error_Include_Message := To_Unbounded_String ("Include file " & I_Filename & " not found."); Error := True; return; end if; when E : others => -- Error while parsing the include file, record this -- error. Let the parser exit properly from the -- recursion to be able to release properly the memory -- before raising an exception. Error_Include_Message := To_Unbounded_String (Exception_Message (E)); Error := True; return; end; -- We do not need to keep reference to the include file in -- this case. The filename is static and already loaded. Data.Release (Included.Filename); end if; -- Move past @@INCLUDE@@ First := First + 11; while First < Last and then Buffer (First) = ' ' loop First := First + 1; end loop; declare P_Set : constant Parameter_Set := (0 => To_Unbounded_String (File)) & Get_Parameters (Get_All_Parameters (At_Least_One => False)); begin Included.Params := Data.To_Data_Parameters (P_Set); end; end Parse_Included_File; --------------------------- -- Rewrite_Inlined_Block -- --------------------------- procedure Rewrite_Inlined_Block (T : Tree) is procedure Rewrite (T : Tree); -- Last is set to True if we are checking the last node ------------- -- Rewrite -- ------------- procedure Rewrite (T : Tree) is N : Tree := T; D : Data.Tree; begin while N /= null loop case N.Kind is when Text => D := N.Text; -- Trim leading blanks if D /= null and then D.Kind = Data.Text then Trim (D.Value, Side => Left); end if; when If_Stmt => Rewrite (N.N_True); Rewrite (N.N_False); when Table_Stmt => Rewrite (N.Blocks); when Section_Block => Rewrite (N.Common); Rewrite (N.Sections); when Section_Stmt => Rewrite (N.N_Section); when others => null; end case; N := N.Next; end loop; end Rewrite; begin Rewrite (T); end Rewrite_Inlined_Block; T : Tree; Error : Boolean; begin if not No_Read and then Mode /= Parse_Section and then Mode /= Parse_Elsif and then Mode /= Parse_Table_Block then if Get_Next_Line then return null; end if; end if; -- Check for Utf8 BOM, this can only occurs at the first line if Line = 1 and then Last > Utils.BOM_Utf8'Length and then Buffer (1 .. Utils.BOM_Utf8'Length) = Utils.BOM_Utf8 then T := new Node (Text); T.Line := Line; T.Text := Data.Parse (Buffer (1 .. Utils.BOM_Utf8'Length), Line); -- Removes BOM from buffer Buffer (1 .. Last - Utils.BOM_Utf8'Length) := Buffer (1 + Utils.BOM_Utf8'Length .. Last); Last := Last - Utils.BOM_Utf8'Length; -- Continued parsing the remaining of the line T.Next := Parse (Mode, In_If, No_Read => True); return T; end if; case Mode is when Parse_Std => if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found outside an @@IF@@ statement"); end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found outside a @@TABLE@@ statement"); end if; if Is_Stmt (End_Inline_Token) then Fatal_Error ("@@END_INLINE@@ found outside an @@INLINE@@ statement"); end if; if Is_Stmt (End_Token) then Fatal_Error ("@@END@@ found outside a @@BEGIN@@ block statement"); end if; if Is_Stmt (End_Macro_Token) then Fatal_Error ("@@END_MACRO@@ found outside a @@MACRO@@ statement"); end if; when Parse_Extends => if Is_Stmt (End_Extends_Token) then return null; end if; when Parse_Block => if Is_Stmt (End_Block_Token) then return null; end if; when Parse_If => if Is_Stmt (Else_Token) or else Is_Stmt (Elsif_Token) or else Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; when Parse_Elsif => if Is_Stmt (Else_Token) or else Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; when Parse_Else => if Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; if Is_Stmt (Elsif_Token) then Fatal_Error ("@@ELSIF@@ found after @@ELSE@@"); end if; when Parse_Table_Block => if Is_Stmt (End_Table_Token) then return null; end if; T := new Node (Section_Block); T.Line := Line; declare Tmp : Tree; begin Tmp := Parse (Parse_Section, In_If); if Tmp = null then -- This section is empty return null; end if; if Is_Stmt (Begin_Token) then -- It means that the section parsed above was common T.Common := Tmp.Next; -- Now free the Section_Stmt container Unchecked_Free (Tmp); T.Sections := Parse (Parse_Section, In_If); else T.Common := null; T.Sections := Tmp; end if; end; -- Count the number of section T.Sections_Count := Count_Sections (T.Sections); if T.Sections_Count = 1 and then T.Common = null then -- A single section and no common section, rewrite it as a -- simple common section. T.Common := T.Sections.Next; Unchecked_Free (T.Sections); T.Sections_Count := 0; end if; if Is_Stmt (End_Table_Token) then T.Next := null; else T.Next := Parse (Parse_Table_Block, In_If); end if; return T; when Parse_Section => if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; T := new Node (Section_Stmt); T.Line := Line; T.Next := Parse (Parse_Section_Content, In_If); if Is_Stmt (End_Table_Token) and then T.Next = null then -- Check if this section was empty, this happen when -- we parse a section after @@END@@ followed by the end -- of the table. Unchecked_Free (T); return null; end if; if Is_Stmt (End_Table_Token) or else Is_Stmt (Begin_Token) or else Is_Stmt (End_Token) then T.N_Section := null; elsif EOF then Fatal_Error ("EOF found, @@END_TABLE@@ expected"); else T.N_Section := Parse (Parse_Section, In_If); end if; return T; when Parse_Section_Content => if Is_Stmt (Section_Token) or else Is_Stmt (End_Table_Token) or else Is_Stmt (Begin_Token) or else Is_Stmt (End_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; when Parse_Table => if Is_Stmt (End_Table_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; when Parse_Inline => if Is_Stmt (End_Inline_Token) then return null; end if; when Parse_Macro => if Is_Stmt (End_Macro_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_MACRO@@ expected"); end if; end case; if Is_Stmt (If_Token) or else Is_Stmt (Elsif_Token) then T := new Node (If_Stmt); T.Line := Line; T.Cond := Expr.Parse (Get_All_Parameters, Line); T.N_True := Parse (Parse_If, In_If => True); if Is_Stmt (End_If_Token) then T.N_False := null; elsif Is_Stmt (Elsif_Token) then T.N_False := Parse (Parse_Elsif, In_If => True); elsif EOF then Fatal_Error ("EOF found, @@END_IF@@ expected"); else T.N_False := Parse (Parse_Else, In_If => True); end if; T.Next := Parse (Mode, In_If); return T; elsif Is_Stmt (Extends_Token) then T := new Node (Extends_Stmt); T.Line := Line; Parse_Included_File (T.E_Included, Error); if Error then Unchecked_Free (T); return null; end if; I_File := new Node' (Kind => Extends_Stmt, Next => I_File, Line => Line, N_Extends => null, E_Included => T.E_Included); T.N_Extends := Parse (Parse_Extends, In_If => In_If); T.Next := Parse (Mode, In_If); return T; elsif Is_Stmt (Block_Token, Extended => True) then T := new Node (Block_Stmt); T.Line := Line; T.B_Name := To_Unbounded_String (Get_Tag_Parameter (1)); T.N_Block := Parse (Parse_Block, In_If => In_If); T.Next := Parse (Mode, In_If); return T; elsif Is_Stmt (Table_Token, Extended => True) then T := new Node (Table_Stmt); T.Line := Line; T.Terminate_Sections := False; T.Reverse_Index := False; T.Terse := False; -- Check if first parameter is @@TERMINATE_SECTION@@, note that -- this is an obsolescent feature. It is better now to use the -- tag command attributes. declare Param : constant Unbounded_String := Get_First_Parameter; begin if Param = Null_Unbounded_String then T.Terminate_Sections := False; elsif Param = Terminate_Sections_Token then T.Terminate_Sections := True; else Fatal_Error ("Unknown table parameter " & To_String (Param)); end if; end; -- Check attributes for K in 1 .. Get_Tag_Attributes_Count loop declare Att : constant String := Get_Tag_Attribute (K); begin if Att = A_Terminate_Sections_Token then T.Terminate_Sections := True; elsif Att = A_Reverse_Token then T.Reverse_Index := True; elsif Att = A_Terse_Token then T.Terse := True; elsif Att = A_Aligh_On then for P in 1 .. Get_Tag_Attribute_Parameter_Count (K) loop T.Align_On.Append (Get_Tag_Attribute_Parameter (K, P)); end loop; else Fatal_Error ("Unknown table attributes " & Att); end if; end; end loop; T.Blocks := Parse (Parse_Table_Block, In_If); T.Next := Parse (Mode, In_If); T.Blocks_Count := Count_Blocks (T.Blocks); -- Check now that if we have TERMINATE_SECTIONS option set and -- that there is more than one block, all blocks have the same -- number of section. if T.Terminate_Sections and then T.Blocks_Count >= 1 then declare Size : constant Natural := T.Blocks.Sections_Count; Max : Natural := Size; B : Tree := T.Blocks.Next; begin while B /= null loop Max := Natural'Max (Max, B.Sections_Count); if B.Sections_Count /= Size and then B.Sections_Count /= 0 then Fatal_Error ("All sections must have the same size " & "when using TERMINATE_SECTIONS option"); end if; B := B.Next; end loop; -- Check wether we have sections with the TERMINATE_SECTION -- attribute. if Max = 0 then Fatal_Error ("TERMINATE_SECTIONS attribute given, but no section" & " defined"); end if; end; end if; return T; elsif Is_Stmt (Include_Token) then T := new Node (Include_Stmt); T.Line := Line; Parse_Included_File (T.I_Included, Error); if Error then Unchecked_Free (T); return null; end if; I_File := new Node' (Kind => Include_Stmt, Next => I_File, Line => Line, I_Included => T.I_Included); T.Next := Parse (Mode, In_If); return T; elsif Is_Stmt (Macro_Token, Extended => True) then -- Parse a macro definition and register it declare Name : constant String := Get_Tag_Parameter (1); T : constant Tree := Parse (Parse_Macro, In_If); procedure Move_To_Last (T : in out Tree); -- Move to last node procedure Rewrite (T : in out Tree); -- Rewrite this node, this is used to remove all CR/LF for -- the last lines which could be output for this tree. ------------------ -- Move_To_Last -- ------------------ procedure Move_To_Last (T : in out Tree) is begin while T.Next /= null loop T := T.Next; end loop; end Move_To_Last; ------------- -- Rewrite -- ------------- procedure Rewrite (T : in out Tree) is D : Data.Tree; begin if T /= null then Move_To_Last (T); case T.Kind is when Text => -- A text node D := T.Text; -- Move to the end of this line while D.Next /= null loop D := D.Next; end loop; if D.Kind = Data.Text then Strings.Unbounded.Trim (D.Value, Left => Maps.Null_Set, Right => Maps.To_Set (ASCII.CR & ASCII.LF)); end if; when If_Stmt => Rewrite (T.N_True); Rewrite (T.N_False); when others => null; end case; end if; end Rewrite; N : Tree := T; begin -- We want to trim CR/LF from the last text node Rewrite (N); Macro.Register (Name, T); end; -- Then continue parsing the remaining of the file return Parse (Mode, In_If); elsif Is_Stmt (Set_Token) then -- We want to handle multiple SET lines to avoid deep recursion declare Root, N : Tree; begin loop N := new Node (Set_Stmt); if Root = null then Root := N; else T.Next := N; end if; T := N; T.Line := Line; T.Def := Definitions.Parse (Get_All_Parameters); if Get_Next_Line then -- Nothing more, returns the result now return Root; end if; -- If this is not a SET statement, just call the parsing -- routine and return the root note. if not Is_Stmt (Set_Token) then T.Next := Parse (Mode, In_If, No_Read => True); return Root; end if; end loop; end; elsif Is_Stmt (Inline_Token, Extended => True) then T := new Node (Inline_Stmt); declare function Inline_Parameter (Index : Positive) return Unbounded_String; -- Returns Inline_Parameter with the given index ---------------------- -- Inline_Parameter -- ---------------------- function Inline_Parameter (Index : Positive) return Unbounded_String is P : constant String := Get_Tag_Parameter (Index); N : Natural := P'First; R : String (P'Range); K : Natural := R'First - 1; begin while N <= P'Last loop if P (N) = '\' and then N < P'Last then case P (N + 1) is when '\' => K := K + 1; R (K) := '\'; N := N + 1; when 'n' => if Utils.Is_Windows then K := K + 2; R (K - 1 .. K) := (ASCII.CR, ASCII.LF); else K := K + 1; R (K) := ASCII.LF; end if; N := N + 1; when 'r' => K := K + 1; R (K) := ASCII.LF; N := N + 1; when others => K := K + 1; R (K) := P (N + 1); N := N + 1; end case; else K := K + 1; R (K) := P (N); end if; N := N + 1; end loop; return To_Unbounded_String (R (R'First .. K)); end Inline_Parameter; begin case Get_Tag_Parameter_Count is when 0 => T.Sep := To_Unbounded_String (" "); when 1 => T.Sep := Inline_Parameter (1); when 3 => T.Before := Inline_Parameter (1); T.Sep := Inline_Parameter (2); T.After := Inline_Parameter (3); when others => Fatal_Error ("Wrong number of tag parameters for INLINE " & "command (0, 1 or 3)"); end case; end; T.I_Block := Parse (Parse_Inline, In_If); Rewrite_Inlined_Block (T.I_Block); T.Next := Parse (Mode, In_If); return T; else declare Root, N : Tree; begin loop N := new Node (Text); if Root = null then Root := N; else T.Next := N; end if; T := N; T.Line := Line; if Input.LF_Terminated (File) and then (not Input.End_Of_File (File) or else Include_File) then -- Add a LF if the read line is terminated by a LF. Do -- not add this LF if we reach the end of file except for -- included files. T.Text := Data.Parse (Buffer (1 .. Last) & ASCII.LF, Line); else T.Text := Data.Parse (Buffer (1 .. Last), Line); end if; if Get_Next_Line then -- Nothing more, returns the result now return Root; end if; -- If this is a statement just call the parsing routine if Is_Stmt (If_Token) or else Is_Stmt (Elsif_Token) or else Is_Stmt (Else_Token) or else Is_Stmt (End_If_Token) or else Is_Stmt (Include_Token) or else Is_Stmt (Table_Token, Extended => True) or else Is_Stmt (Section_Token) or else Is_Stmt (End_Table_Token) or else Is_Stmt (End_Extends_Token) or else Is_Stmt (End_Block_Token) or else Is_Stmt (Extends_Token) or else Is_Stmt (Block_Token, Extended => True) or else Is_Stmt (Begin_Token) or else Is_Stmt (End_Token) or else Is_Stmt (Set_Token) or else Is_Stmt (Inline_Token, Extended => True) or else Is_Stmt (End_Inline_Token) or else Is_Stmt (Macro_Token, Extended => True) or else Is_Stmt (End_Macro_Token) then T.Next := Parse (Mode, In_If, No_Read => True); return Root; end if; end loop; end; end if; end Parse; T : Static_Tree; New_T : Tree; Old : Tree; begin Templates_Parser_Tasking.Lock; if Cached then Cached_Files.Get (Filename, Result => T); if T /= Null_Static_Tree then pragma Assert (T.C_Info /= null); Templates_Parser_Tasking.Unlock; return T; end if; end if; Input.Open (File, Filename, Form => "shared=no"); begin New_T := Parse (Parse_Std, False); Simplifier.Run (New_T); Input.Close (File); exception when others => Input.Close (File); raise; end; -- T is the tree file, add two nodes (Info and C_Info) in front of -- the tree. -- Add second node (cache info) Old := new Node'(Kind => C_Info, Next => New_T, Line => 0, Obsolete => False, Used => 1); -- Add first node (info about tree) New_T := new Node'(Kind => Info, Next => Old, Line => 0, Filename => To_Unbounded_String (Filename), Timestamp => Configuration.File_Time_Stamp (Filename), I_File => I_File); if Error_Include_Message /= Null_Unbounded_String then -- An include filename was not found, release the memory now and -- raise a fatal error. Release (New_T); Fatal_Error (To_String (Error_Include_Message)); end if; if Cached then Cached_Files.Add (Filename, New_T, Old); pragma Assert (Old /= null); end if; Templates_Parser_Tasking.Unlock; return Static_Tree'(New_T, Old); exception when E : Internal_Error => Templates_Parser_Tasking.Unlock; Fatal_Error (Exceptions.Exception_Message (E)); when others => Templates_Parser_Tasking.Unlock; raise; end Load; -------------- -- No_Quote -- -------------- function No_Quote (Str : String) return String is begin if Str'Length > 1 and then Str (Str'First) = '"' and then Str (Str'Last) = '"' then return Str (Str'First + 1 .. Str'Last - 1); else return Str; end if; end No_Quote; ----------- -- Parse -- ----------- function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return String is begin return To_String (Parse (Filename, Translations, Cached, Keep_Unknown_Tags, Lazy_Tag, Cursor_Tag, Report)); end Parse; function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return Unbounded_String is begin return Parse (Filename, To_Set (Translations), Cached, Keep_Unknown_Tags, Lazy_Tag, Cursor_Tag, Report); end Parse; function Parse (Filename : String; Translations : Translate_Set; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return String is begin return To_String (Parse (Filename, Translations, Cached, Keep_Unknown_Tags, Lazy_Tag, Cursor_Tag, Report)); end Parse; function Parse (Filename : String; Translations : Translate_Set; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False; Lazy_Tag : Dyn.Lazy_Tag_Access := Dyn.Null_Lazy_Tag; Cursor_Tag : Dyn.Cursor_Tag_Access := Dyn.Null_Cursor_Tag; Report : access procedure (Tag_Name : String; Filename : String := ""; Line : Natural := 0; Reason : Reason_Kind) := null) return Unbounded_String is package Name_Set is new Containers.Indefinite_Ordered_Sets (String); Max_Nested_Levels : constant := 10; -- The maximum number of table nested levels type Block_State is record Section_Number : Positive; Section : Tree; end record; Empty_Block_State : constant Block_State := (1, null); type Parse_State; type Parse_State_Access is access constant Parse_State; type Parse_State (P_Size : Natural) is record Cursor : Indices (1 .. Max_Nested_Levels); Max_Lines : Natural; Max_Expand : Natural; Reverse_Index : Boolean; Table_Level : Natural; Inline_Sep : Unbounded_String; Filename : Unbounded_String; Line : Natural; Blocks_Count : Natural; I_Params : Data.Parameters; F_Params : Parameter_Set (1 .. P_Size); Block : Block_State; Terse_Table : Boolean; Parent : Parse_State_Access; end record; Empty_State : constant Parse_State := (0, (1 .. Max_Nested_Levels => 0), 0, 0, False, 0, Null_Unbounded_String, Null_Unbounded_String, 0, 0, null, No_Parameter, Empty_Block_State, False, null); Results : Unbounded_String := Null_Unbounded_String; Buffer : String (1 .. 4 * 1_024); Last : Natural := 0; -- Cache to avoid too many reallocation using Append on Results above Now : Calendar.Time; D_Map : Definitions.Map; Lazy_Set : Translate_Set; Output : Boolean; Named_Blocks : Tree_Map.Map; -- The blocks for @@EXTENDS@@ In_Extends : Natural := 0; -- nesting level of @@EXTENDS@@ block we are analyzing. 0 outside -- such a block. Unused_Variables : Name_Set.Set; procedure Flush with Inline; -- Flush buffer to Results procedure Analyze (T : Tree; State : Parse_State); -- Parse T and build results file. State is needed for Vector_Tag and -- Matrix_Tag expansion. ------------- -- Analyze -- ------------- procedure Analyze (T : Tree; State : Parse_State) is use type Data.Tree; function NS (State : Parse_State; Line : Natural) return Parse_State with Inline; -- Returns a new Parse_State with just the line updated function Analyze (E : Expr.Tree) return String; -- Analyse the expression tree and returns the result as a boolean -- The conditional expression must be equal to either TRUE or -- FALSE. Note that a string is True if it is equal to string "TRUE" -- and False otherwise. procedure Analyze (D : Data.Tree); -- Analyse the data tree and replace all variables by the -- correspinding value specified in Translations. This procedure -- catenate the result into Results variable. procedure Analyze (Included : in out Included_File_Info); -- Analyze the imported file procedure Get_Max (T : Tree; Max_Lines : out Natural; Max_Expand : out Natural); -- Returns the maximum number of lines (Max_Lines) into the -- table. This correspond to the length of the shortest vector tag -- into the table or the shortest number of lines in sub-table -- matrix tag. -- Returns also the number of time the table will be expanded -- (Max_Expand), this is equal to Max_Lines + offset to terminate -- the sections. function Translate (Var : Data.Tag_Var; State : Parse_State; Is_Composite : access Boolean) return String; -- Translate Tag variable using Translation table and apply all -- Filters and Atribute recorded for this variable. function I_Translate (Var : Data.Tag_Var; State : Parse_State) return String; -- As above but for an include variable procedure Add (S : String); -- Add S into Results (using Buffer cache if possible). If Sep is -- true S is a separator. We keep track of this as we do not want to -- have two separators side by side. function Get_Mark return Natural with Inline; -- Get a mark on the current text buffer function Get_Marked_Text (Mark : Natural) return String; -- Returns the text from the mark to the end of the buffer function Get_Association (Var : Data.Tag_Var; Line : Natural) return Association; -- Returns association for Name or Null_Association if not found. -- This routine also handles lazy tags by calling the appropriate -- callback routine. Lazy tag values are then recorded into Lazy_Set. procedure Rollback (Activate : Boolean; Mark : Natural) with Inline; -- Commit or rollback added texts for terse output. If no text added -- from the vector tag we rollback to the previous mark otherwise the -- current result stays. The mark is cleared. function Flatten_Parameters (I : Data.Parameter_Set) return Parameter_Set; -- Returns a flat representation of the include parameters, only the -- name or the value are kept. The tree are replaced by an empty -- value. function Flatten_Parameters (I : Data.Parameters) return Parameter_Set; -- As above but for an access to a Parameter_Set function Inline_Cursor_Tag (Cursor_Tag : Dynamic.Cursor_Tag_Access; Var_Name : String; Dim : Positive; Path : Dynamic.Path) return Unbounded_String; -- Returns the Cursor_Tag Var_Name inlined for all dimensions -- starting from Path. function Align_On (Seps : String_Set.Vector; Text : String) return String; -- Align text given the State.Align_On separators function Rewrite_Inlined_Block (T : Tree; Block : String) return String; -- Do inline the block, add the Before and After strings and Sep -- after each line. L_State : aliased constant Parse_State := State; --------- -- Add -- --------- procedure Add (S : String) is begin if Last + S'Length > Buffer'Last then -- Not enough cache space, flush buffer Flush; end if; if S'Length >= Buffer'Length then Append (Results, S); else Buffer (Last + 1 .. Last + S'Length) := S; Last := Last + S'Length; end if; end Add; -------------- -- Align_On -- -------------- function Align_On (Seps : String_Set.Vector; Text : String) return String is Cols : array (Positive range 1 .. Positive (Seps.Length)) of Natural := (others => 0); LS : Positive := Text'First; -- line start LE : Natural := 0; -- line end Result : Unbounded_String; -- Text aligned begin -- Look for columns in Text and set the separators column in Cols Check_Cols : while LS < Text'Last loop -- Check for line start .. end LE := Strings.Fixed.Index (Text, String'(1 => ASCII.LF), LS); if LE = 0 then LE := Text'Last; end if; -- Check for separators Update_Cols : declare I : Positive := Cols'First; P : Positive := LS; Loc : Natural; NP : Natural; Ofs : Natural := 0; begin for S of Seps loop Loc := Strings.Fixed.Index (Text (LS .. LE), S, P); if Loc > 0 then P := Loc; NP := P - LS + 1 + Ofs; -- new pos -- We have a previous position recorded if Cols (I) /= 0 then if NP > Cols (I) then -- The new position is above the current -- one. This is going to be the new value -- and so we need to shift all columns of -- the corresponding offset. for K in I + 1 .. Cols'Last loop Cols (K) := Cols (K) + (NP - Cols (I)); end loop; elsif NP < Cols (I) then -- Increase offset of the current line as we -- need to add spaces before the separator for -- it to be aligned with the current column. Ofs := Ofs + (Cols (I) - NP); end if; end if; -- And finally update this columns Cols (I) := Natural'Max (Cols (I), NP); P := P + S'Length; end if; I := I + 1; end loop; end Update_Cols; LS := LE + 1; end loop Check_Cols; -- Add necessary spaces to align elements in columns LS := Text'First; Set_Cols : while LS < Text'Last loop -- Check for line start .. end LE := Strings.Fixed.Index (Text, String'(1 => ASCII.LF), LS); if LE = 0 then LE := Text'Last; end if; -- Check for separators declare use Strings.Fixed; Line : Unbounded_String := To_Unbounded_String (Text (LS .. LE)); I : Positive := Cols'First; P : Positive := LS; Loc : Natural; Spaces : Natural := 0; Offset : Natural := 0; begin for S of Seps loop Loc := Index (Text (LS .. LE), S, P); if Loc > 0 and then Cols (I) - Loc + LS - Offset > 0 then P := Loc; Spaces := Cols (I) - P + LS - Offset - 1; if Spaces > 0 then Insert (Source => Line, Before => Offset + P - LS + 1, New_Item => String'(Spaces * ' ')); Offset := Offset + Spaces; end if; P := P + S'Length; end if; I := I + 1; end loop; Append (Result, Line); end; LS := LE + 1; end loop Set_Cols; return To_String (Result); end Align_On; ------------- -- Analyze -- ------------- procedure Analyze (D : Data.Tree) is T : Data.Tree := D; begin while T /= null loop case T.Kind is when Data.Text => Add (To_String (T.Value)); when Data.Var => if Data.Is_Include_Variable (T.Var) then Add (I_Translate (T.Var, State)); else declare use Strings.Fixed; use type Data.Attribute; Is_Composite : aliased Boolean; Value : constant String := Translate (T.Var, NS (State, T.Line), Is_Composite'Access); begin -- Only adds to the buffer if variable value is not -- empty. This is needed as we want to track empty -- values to be able to rollback if necessary on -- the terse mode. Note that we handle only -- composite tags which are part of the table -- expansion. if Value /= "" then if T.Col = 1 or else T.Var.Attribute.Attr /= Data.Indent or else Index (Value, String'(1 => ASCII.LF)) = 0 then Add (Value); else -- We have some LF into the string and the -- tag is not placed at the start of the -- line, we need to indent the content. declare Spaces : constant Positive := T.Col - 1; V : Unbounded_String := To_Unbounded_String (Value); P : Natural := 1; begin Indent_Content : loop P := Index (V, String'(1 => ASCII.LF), P); exit Indent_Content when P = 0; P := P + 1; Insert (V, Before => P, New_Item => String'(Spaces * ' ')); P := P + Spaces; end loop Indent_Content; Add (To_String (V)); end; end if; Output := Is_Composite; end if; end; end if; end case; T := T.Next; end loop; end Analyze; ------------- -- Analyze -- ------------- function Analyze (E : Expr.Tree) return String is type Ops_Fct is access function (L, R : Expr.Tree) return String; function F_And (L, R : Expr.Tree) return String; function F_Or (L, R : Expr.Tree) return String; function F_Xor (L, R : Expr.Tree) return String; function F_Sup (L, R : Expr.Tree) return String; function F_Esup (L, R : Expr.Tree) return String; function F_Einf (L, R : Expr.Tree) return String; function F_Inf (L, R : Expr.Tree) return String; function F_Equ (L, R : Expr.Tree) return String; function F_Diff (L, R : Expr.Tree) return String; function F_In (L, R : Expr.Tree) return String; function F_Cat (L, R : Expr.Tree) return String; type U_Ops_Fct is access function (N : Expr.Tree) return String; function F_Not (N : Expr.Tree) return String; ----------- -- F_And -- ----------- function F_And (L, R : Expr.Tree) return String is begin if Expr.Is_True (Analyze (L)) and then Expr.Is_True (Analyze (R)) then return "TRUE"; else return "FALSE"; end if; end F_And; ----------- -- F_Cat -- ----------- function F_Cat (L, R : Expr.Tree) return String is begin return Analyze (L) & Analyze (R); end F_Cat; ------------ -- F_Diff -- ------------ function F_Diff (L, R : Expr.Tree) return String is begin if Analyze (L) /= Analyze (R) then return "TRUE"; else return "FALSE"; end if; end F_Diff; ------------ -- F_Einf -- ------------ function F_Einf (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if Utils.Is_Number (LV) and then Is_Number (RV) then if Integer'Value (LV) <= Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV <= RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Einf; ----------- -- F_Equ -- ----------- function F_Equ (L, R : Expr.Tree) return String is begin if Analyze (L) = Analyze (R) then return "TRUE"; else return "FALSE"; end if; end F_Equ; ------------ -- F_Esup -- ------------ function F_Esup (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if Utils.Is_Number (LV) and then Is_Number (RV) then if Integer'Value (LV) >= Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV >= RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Esup; ---------- -- F_In -- ---------- function F_In (L, R : Expr.Tree) return String is use type Expr.NKind; procedure Build_Set (Data : in out Tag_Data); -- Returns TRUE or FALSE depending if Value is found in the tag --------------- -- Build_Set -- --------------- procedure Build_Set (Data : in out Tag_Data) is procedure Process (N : Tag_Node_Access); -- Insert all values pointed to by N ------------- -- Process -- ------------- procedure Process (N : Tag_Node_Access) is L : Tag_Node_Access := N; begin while L /= null loop if L.Kind = Templates_Parser.Value then Data.Values.Include (To_String (L.V)); elsif L.Kind = Value_Set then Process (L.VS.Data.Head); end if; L := L.Next; end loop; end Process; begin Process (Data.Head); end Build_Set; begin if R.Kind = Expr.Var then declare LL : constant String := Analyze (L); Tk : constant Association := Get_Association (R.Var, R.Line); begin case Tk.Kind is when Std => if LL = To_String (Tk.Value) then return "TRUE"; else return "FALSE"; end if; when Composite => if Tk.Comp_Value.Data.Values = null then -- Build map of values for fast test Tk.Comp_Value.Data.Values := new Tag_Values.Set; Build_Set (Tk.Comp_Value.Data.all); end if; if Tk.Comp_Value.Data.Values.Contains (LL) then return "TRUE"; else return "FALSE"; end if; end case; end; else raise Template_Error with "in operator right operand must be a tag"; end if; end F_In; ----------- -- F_Inf -- ----------- function F_Inf (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if Utils.Is_Number (LV) and then Is_Number (RV) then if Integer'Value (LV) < Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV < RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Inf; ----------- -- F_Not -- ----------- function F_Not (N : Expr.Tree) return String is begin if Expr.Is_True (Analyze (N)) then return "FALSE"; else return "TRUE"; end if; end F_Not; ---------- -- F_Or -- ---------- function F_Or (L, R : Expr.Tree) return String is begin if Expr.Is_True (Analyze (L)) or else Expr.Is_True (Analyze (R)) then return "TRUE"; else return "FALSE"; end if; end F_Or; ----------- -- F_Sup -- ----------- function F_Sup (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if Utils.Is_Number (LV) and then Is_Number (RV) then if Integer'Value (LV) > Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV > RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Sup; ----------- -- F_Xor -- ----------- function F_Xor (L, R : Expr.Tree) return String is begin if Expr.Is_True (Analyze (L)) xor Expr.Is_True (Analyze (R)) then return "TRUE"; else return "FALSE"; end if; end F_Xor; Op_Table : constant array (Expr.Ops) of Ops_Fct := (Expr.O_And => F_And'Access, Expr.O_Or => F_Or'Access, Expr.O_Xor => F_Xor'Access, Expr.O_Sup => F_Sup'Access, Expr.O_Inf => F_Inf'Access, Expr.O_Esup => F_Esup'Access, Expr.O_Einf => F_Einf'Access, Expr.O_Equal => F_Equ'Access, Expr.O_Diff => F_Diff'Access, Expr.O_In => F_In'Access, Expr.O_Cat => F_Cat'Access); U_Op_Table : constant array (Expr.U_Ops) of U_Ops_Fct := (Expr.O_Not => F_Not'Access); Is_Composite : aliased Boolean; begin case E.Kind is when Expr.Value => return To_String (E.V); when Expr.Var => if Data.Is_Include_Variable (E.Var) then return I_Translate (E.Var, State); else return Translate (E.Var, NS (State, E.Line), Is_Composite'Access); end if; when Expr.Op => return Op_Table (E.O) (E.Left, E.Right); when Expr.U_Op => return U_Op_Table (E.U_O) (E.Next); end case; end Analyze; ------------- -- Analyze -- ------------- procedure Analyze (Included : in out Included_File_Info) is begin if Included.Filename /= null then -- This is a deferred include file load as the name of the -- include file was not a static string. Flush; Analyze (Included.Filename); declare Filename : constant String := Buffer (1 .. Last); S_File : Static_Tree; begin Last := 0; -- Removes include filename from the buffer S_File := Load (Build_Include_Pathname (To_String (State.Filename), Filename), Cached, True); if S_File /= Included.File then if Cached then if Included.File.C_Info /= null then Cached_Files.Release (Included.File); end if; else Release (Included.File.Info); end if; end if; Included.File := S_File; end; end if; Analyze (Included.File.Info, Parse_State'(Included.Params'Length, Cursor => State.Cursor, Max_Lines => State.Max_Lines, Max_Expand => State.Max_Expand, Reverse_Index => State.Reverse_Index, Table_Level => State.Table_Level, Inline_Sep => State.Inline_Sep, Filename => Included.File.Info.Filename, Line => State.Line, Blocks_Count => State.Blocks_Count, I_Params => Included.Params, F_Params => Flatten_Parameters (Included.Params), Block => State.Block, Terse_Table => State.Terse_Table, Parent => L_State'Unchecked_Access)); end Analyze; ------------------------ -- Flatten_Parameter -- ------------------------ function Flatten_Parameters (I : Data.Parameter_Set) return Parameter_Set is F : Parameter_Set (I'Range); Is_Composite : aliased Boolean; begin for K in I'Range loop if I (K) = null then F (K) := Null_Unbounded_String; else case I (K).Kind is when Data.Text => F (K) := I (K).Value; when Data.Var => F (K) := To_Unbounded_String (Translate (I (K).Var, NS (State, I (K).Line), Is_Composite'Access)); end case; end if; end loop; return F; end Flatten_Parameters; function Flatten_Parameters (I : Data.Parameters) return Parameter_Set is use type Data.Parameters; begin if I = null then return No_Parameter; else return Flatten_Parameters (I.all); end if; end Flatten_Parameters; --------------------- -- Get_Association -- --------------------- function Get_Association (Var : Data.Tag_Var; Line : Natural) return Association is use type Data.Internal_Tag; use type Dynamic.Lazy_Tag_Access; Name : constant String := To_String (Var.Name); Pos : Association_Map.Cursor; begin Pos := Translations.Set.Find (Name); if Association_Map.Has_Element (Pos) then Unused_Variables.Exclude (Name); return Association_Map.Element (Pos); elsif Lazy_Tag /= Dynamic.Null_Lazy_Tag and then not Filter.Is_No_Dynamic (Var.Filters) and then Var.Internal = Data.No then -- Look into the Lazy_Set for the cached value Pos := Lazy_Set.Set.Find (Name); if Association_Map.Has_Element (Pos) then return Association_Map.Element (Pos); else -- Check for Lazy tag Dynamic.Value (Lazy_Tag, Name, Lazy_Set); return Get (Lazy_Set, Name); end if; else if Report /= null then Report (Name, To_String (State.Filename), Line, Undefined); end if; return Null_Association; end if; end Get_Association; -------------- -- Get_Mark -- -------------- function Get_Mark return Natural is begin Output := False; return Length (Results) + Last; end Get_Mark; --------------------- -- Get_Marked_Text -- --------------------- function Get_Marked_Text (Mark : Natural) return String is Len : constant Natural := Length (Results) + Last - Mark; begin if Len > 0 then if Last >= Len then -- Enough data into the buffer return Buffer (Last - Len + 1 .. Last); else -- Get part from result return Slice (Results, Low => Length (Results) - Len + Last + 1, High => Length (Results)) & Buffer (1 .. Last); end if; else return ""; end if; end Get_Marked_Text; ------------- -- Get_Max -- ------------- procedure Get_Max (T : Tree; Max_Lines : out Natural; Max_Expand : out Natural) is function Get_Max_Lines (T : Tree; N : Positive) return Natural; -- Recursivelly descends the tree and compute the max lines that -- will be displayed into the table. N is the variable embedded -- level regarding the table statement. N=1 means that the -- variable is just under the analysed table. N=2 means that the -- variable is found inside a nested table statement. And so on. ------------------- -- Get_Max_Lines -- ------------------- function Get_Max_Lines (T : Tree; N : Positive) return Natural is function Check (T : Data.Tree) return Natural; -- Returns the length of the largest vector tag found on the -- subtree. function Check (T : Expr.Tree) return Natural; -- Idem for an expression subtree as found in a condition function Check (T : Data.Tag_Var) return Natural; -- Returns the length of Tag T for the current context function Check (I : not null access Data.Parameter_Set) return Natural; -- Returns the length of the largest vector tag found on the -- include parameters. function Get_Max_Lines (Included : Included_File_Info; N : Positive) return Natural; -- Return the max lines for Included ----------- -- Check -- ----------- function Check (T : Data.Tag_Var) return Natural is Table_Level : constant Positive := State.Table_Level + 1; -- This is the current table level, State.Table_Level is -- not yet updated when calling this routine hence the +1. Var_Level : constant Natural := State.Table_Level + N; -- This is the variable nested table level. O means that the -- variable is not inside a table statement. function Max (T : Tag; N : Natural) return Natural; -- Returns the maximum number of items for the Nth Tag level function Max (Name : String; N : Natural; Path : Dynamic.Path) return Natural; -- Idem for a Cursor_Tag --------- -- Max -- --------- function Max (T : Tag; N : Natural) return Natural is Result : Natural := 0; P : Tag_Node_Access := T.Data.Head; begin while P /= null loop if P.Kind = Value_Set then if N = 1 then Result := Natural'Max (Result, P.VS.Data.Count); else Result := Natural'Max (Result, Max (P.VS.all, N - 1)); end if; end if; P := P.Next; end loop; return Result; end Max; function Max (Name : String; N : Natural; Path : Dynamic.Path) return Natural is use type Dynamic.Path; Result : Natural := 0; L : Natural; begin L := Dynamic.Length (Cursor_Tag, Name, Path); for K in 1 .. L loop if Path'Length = N then Result := Natural'Max (Result, Dynamic.Length (Cursor_Tag, Name, Path & K)); else Result := Natural'Max (Result, Max (Name, N, Path & K)); end if; end loop; return Result; end Max; begin declare use type Dynamic.Cursor_Tag_Access; Tk : constant Association := Get_Association (T, State.Line); begin if Tk = Null_Association then if Cursor_Tag /= Dynamic.Null_Cursor_Tag then -- Check the Cursor_Tag declare Name : constant String := To_String (T.Name); D, K : Natural; L1 : Natural; begin D := Dynamic.Dimension (Cursor_Tag, Name); if N > D then -- Ignore this variable as it is deeper than -- its dimension. return 0; elsif D /= 0 then -- This is a Cursor_Tag K := D - N + 1; -- K is the variable indice for which -- the number of items is looked for. if D > Table_Level then -- The variable dimensions is bigger than -- the current table level. This means -- that the index needs to be updated so -- that the outer table tag statement will -- be the first var index. K := K - (D - Var_Level); end if; L1 := Dynamic.Length (Cursor_Tag, Name, Path => (1 => 1)); if D = 1 and then L1 = 1 then -- Not a composite tag return 0; elsif K = 1 then return L1; else return Max (Name, K - 1, (1 => 1)); end if; end if; end; end if; else if Tk.Kind = Composite then if N > Tk.Comp_Value.Data.Nested_Level then -- Ignore this variable as it is deeper than -- its nested level. return 0; end if; -- We look first at two common cases to handle -- more efficiently tag into a single or two -- table statements. if Table_Level = 1 or else Tk.Comp_Value.Data.Nested_Level = 1 then -- First table level, or flat composite, the -- number of iterations corresponds to the -- number of item into this tag. return Size (Tk.Comp_Value); elsif Table_Level = 2 and then N = 1 then -- Table level 2 while looking to nested -- variable. return Tk.Comp_Value.Data.Max; else -- All other cases here declare K : constant Positive := Tk.Comp_Value.Data.Nested_Level - N + 1; -- K is the variable indice for which -- the number of items is looked for. begin if K = 1 then return Size (Tk.Comp_Value); elsif K = 2 then return Tk.Comp_Value.Data.Max; else return Max (Tk.Comp_Value, K - 1); end if; end; end if; end if; end if; end; return 0; end Check; function Check (T : Data.Tree) return Natural is use type Data.Attribute; use type Data.NKind; Iteration : Natural := Natural'First; D : Data.Tree := T; begin while D /= null loop if D.Kind = Data.Var and then D.Var.Attribute.Attr = Data.Nil then Iteration := Natural'Max (Iteration, Check (D.Var)); end if; D := D.Next; end loop; return Iteration; end Check; function Check (T : Expr.Tree) return Natural is begin case T.Kind is when Expr.Var => return Natural'Max (0, Check (T.Var)); when Expr.Op => return Natural'Max (Check (T.Left), Check (T.Right)); when Expr.U_Op => return Natural'Max (0, Check (T.Next)); when Expr.Value => return 0; end case; end Check; function Check (I : not null access Data.Parameter_Set) return Natural is Iteration : Natural := Natural'First; begin for K in I'Range loop if I (K) /= null then Iteration := Natural'Max (Iteration, Check (I (K))); end if; end loop; return Iteration; end Check; function Get_Max_Lines (Included : Included_File_Info; N : Positive) return Natural is begin return Natural'Max (Get_Max_Lines (Included.File.Info, N), Check (Included.Params)); end Get_Max_Lines; begin if T = null then return Natural'First; end if; case T.Kind is when Info | C_Info | Set_Stmt => return Get_Max_Lines (T.Next, N); when Text => return Natural'Max (Check (T.Text), Get_Max_Lines (T.Next, N)); when If_Stmt => return Natural'Max (Check (T.Cond), Natural'Max (Get_Max_Lines (T.Next, N), Natural'Max (Get_Max_Lines (T.N_True, N), Get_Max_Lines (T.N_False, N)))); when Table_Stmt => return Natural'Max (Get_Max_Lines (T.Blocks, N + 1), Get_Max_Lines (T.Next, N)); when Section_Block => return Natural'Max (Get_Max_Lines (T.Next, N), Natural'Max (Get_Max_Lines (T.Common, N), Get_Max_Lines (T.Sections, N))); when Extends_Stmt => return Natural'Max (Get_Max_Lines (T.E_Included, N), Natural'Max (Get_Max_Lines (T.N_Extends, N), Get_Max_Lines (T.Next, N))); when Block_Stmt => return Natural'Max (Get_Max_Lines (T.Next, N), Get_Max_Lines (T.N_Block, N)); when Section_Stmt => return Natural'Max (Get_Max_Lines (T.Next, N), Get_Max_Lines (T.N_Section, N)); when Include_Stmt => return Natural'Max (Get_Max_Lines (T.I_Included, N), Get_Max_Lines (T.Next, N)); when Inline_Stmt => return Natural'Max (Get_Max_Lines (T.Next, N), Get_Max_Lines (T.I_Block, N)); end case; end Get_Max_Lines; Result : Natural := Get_Max_Lines (T.Blocks, 1); begin pragma Assert (T.Kind = Table_Stmt); Max_Lines := Result; if T.Terminate_Sections then -- ??? This part of code handle properly only table with a -- single block. What should be done if there is multiple -- blocks ? Should all blocks be of the same size ? declare N_Section : constant Natural := T.Blocks.Sections_Count; begin if Result mod N_Section /= 0 then Result := Result + N_Section - (Result mod N_Section); end if; end; end if; Max_Expand := Result; end Get_Max; ----------------- -- I_Translate -- ----------------- function I_Translate (Var : Data.Tag_Var; State : Parse_State) return String is use type Data.Attribute; use type Data.NKind; use type Data.Parameters; begin pragma Assert (Var.N /= -1); if State.I_Params /= null and then Var.N <= State.I_Params'Last and then State.I_Params (Var.N) /= null then declare T : constant Data.Tree := State.I_Params (Var.N); -- T is the data tree that should be evaluated in place -- of the include variable. C : aliased Filter.Filter_Context := (State.F_Params'Length, Translations, Lazy_Tag, State.F_Params); Is_Composite : aliased Boolean; begin if T.Next = null and then T.Kind = Data.Var then -- Here we have a special case where the include -- variable is replaced by a single variable. declare V : Data.Tag_Var := T.Var; begin if V.N = -1 then -- First thing we want to do is to inherit -- attributes from the include variable if we -- have no attribute. if V.Attribute.Attr = Data.Nil then V.Attribute := Var.Attribute; end if; -- Note that below we pass the parent state. This -- is required as if the variable is an alias to -- to an include parameter we need to get the -- value for this variable in parent state. If the -- variable is a standard one (from a translate -- table) the state will not be used. return Data.Translate (Var, Translate (V, State.Parent.all, Is_Composite'Access), C'Access); else -- This variable reference a parent include -- variable. return I_Translate (V, State.Parent.all); end if; end; else -- Here we flush the buffer and then we analyse the -- include parameter. The result is contained into -- the buffer which is large enough for an include -- variable. Flush; Analyze (T); declare L : constant Natural := Last; begin Last := 0; return Data.Translate (Var, Buffer (Buffer'First .. L), C'Access); end; end if; end; else return ""; end if; end I_Translate; ----------------------- -- Inline_Cursor_Tag -- ----------------------- function Inline_Cursor_Tag (Cursor_Tag : Dynamic.Cursor_Tag_Access; Var_Name : String; Dim : Positive; Path : Dynamic.Path) return Unbounded_String is use type Dynamic.Path; Result : Unbounded_String; L : Natural; begin L := Dynamic.Length (Cursor_Tag, Var_Name, 1 & Path); for K in 1 .. L loop if Result /= Null_Unbounded_String then Append (Result, ' '); end if; if Dim = Path'Length + 1 then Append (Result, Dynamic.Value (Cursor_Tag, Var_Name, Path & K)); else Append (Result, Inline_Cursor_Tag (Cursor_Tag, Var_Name, Dim, Path & K)); end if; end loop; return Result; end Inline_Cursor_Tag; -------- -- NS -- -------- function NS (State : Parse_State; Line : Natural) return Parse_State is begin return (Parse_State'(State.P_Size, State.Cursor, State.Max_Lines, State.Max_Expand, State.Reverse_Index, State.Table_Level, State.Inline_Sep, State.Filename, Line, State.Blocks_Count, State.I_Params, State.F_Params, State.Block, State.Terse_Table, State.Parent)); end NS; --------------------------- -- Rewrite_Inlined_Block -- --------------------------- function Rewrite_Inlined_Block (T : Tree; Block : String) return String is Sep : constant String := To_String (T.Sep); Start : Positive := Block'First; Pos : Natural; Offset : Natural; Next : Natural; Result : Unbounded_String := T.Before; begin Next := Strings.Fixed.Index (Block (Start .. Block'Last), String'(1 => ASCII.LF)); -- No end-of-line separator, let's handle the whole line if Next = 0 then Next := Block'Last; end if; -- Add all lines (separator is LF) add Sep after each one loop Pos := Next; exit when Pos = 0; if Pos = Block'First or else Block (Pos) /= ASCII.LF then -- A single character or line without LF Offset := 0; elsif Pos > Block'First and then Block (Pos - 1) = ASCII.CR then -- We have a CR + LF Offset := 2; else -- Just a single LF, standard separator Offset := 1; end if; -- Add line content Append (Result, Block (Start .. Pos - Offset)); Start := Pos + 1; Next := Strings.Fixed.Index (Block (Start .. Block'Last), String'(1 => ASCII.LF)); -- Add Sep or handle the last line if Next = 0 then -- Last line in the INLINE, add the After string and the -- final CR/LF. Append (Result, T.After); Append (Result, Block (Pos - Offset + 1 .. Pos)); else Append (Result, Sep); end if; end loop; return To_String (Result); end Rewrite_Inlined_Block; -------------- -- Rollback -- -------------- procedure Rollback (Activate : Boolean; Mark : Natural) is begin if Activate then -- Rollback Rollback : declare To_Delete : constant Natural := Length (Results) + Last - Mark; begin if To_Delete > 0 then if Last >= To_Delete then -- Enough data into the buffer, remove from it Last := Last - To_Delete; else -- Remove remaining data from results Delete (Results, From => Length (Results) - To_Delete + Last + 1, Through => Length (Results)); -- Clear buffer Last := 0; end if; end if; end Rollback; end if; end Rollback; --------------- -- Translate -- --------------- function Translate (Var : Data.Tag_Var; State : Parse_State; Is_Composite : access Boolean) return String is use type Data.Parameters; use type Filter.Set_Access; C : aliased Filter.Filter_Context := (State.F_Params'Length, Translations, Lazy_Tag, State.F_Params); D_Pos : Definitions.Def_Map.Cursor; Up_Value : Natural := 0; begin Is_Composite.all := False; if Var.Is_Macro then -- Two possibilities, either we have a macro inlined here or a -- user macro. if Var.Def = null then -- A user defined macro, use callback if any if Macro.Callback /= null then declare Name : constant String := To_String (Var.Name); Params : Parameter_Set (Var.Parameters'Range); begin -- Set parameters for K in Params'Range loop Flush; Analyze (Var.Parameters (K)); Params (K) := To_Unbounded_String (Buffer (Buffer'First .. Last)); Last := 0; end loop; return Data.Translate (Var, Macro.Callback (Name, Params), C'Access); end; end if; else declare Mark : constant Natural := Get_Mark; begin Analyze (Var.Def, State); -- Apply filters if any to the result if Var.Filters /= null then declare V : constant String := Get_Marked_Text (Mark); begin Rollback (True, Mark); return Data.Translate (Var, V, C'Access); end; else return ""; end if; end; end if; end if; D_Pos := Definitions.Def_Map.Find (D_Map, To_String (Var.Name)); if Definitions.Def_Map.Has_Element (D_Pos) then -- We have a definition for this variable in the template declare N : constant Definitions.Node := Definitions.Def_Map.Element (D_Pos); V : Data.Tag_Var := Var; begin case N.Kind is when Definitions.Const => return Data.Translate (Var, To_String (N.Value), C'Access); when Definitions.Ref => V.N := N.Ref; return I_Translate (V, State); when Definitions.Ref_Default => if State.I_Params = null or else N.Ref > State.I_Params'Last or else State.I_Params (N.Ref) = null then -- This include parameter does not exist, use -- default value. return Data.Translate (Var, To_String (N.Value), C'Access); else V.N := N.Ref; return I_Translate (V, State); end if; end case; end; end if; declare use type Data.Attribute; use type Dynamic.Cursor_Tag_Access; use type Dynamic.Path; Tk : constant Association := Get_Association (Var, State.Line); begin if Tk = Null_Association then if Cursor_Tag /= Dynamic.Null_Cursor_Tag then -- Check the Cursor_Tag declare Name : constant String := To_String (Var.Name); D, L : Natural; Valid_Cursor : Boolean := True; begin D := Dynamic.Dimension (Cursor_Tag, Name); if D /= 0 then if Var.Attribute.Attr /= Data.Nil then -- ??? Would be nice to remove this restriction raise Template_Error with "Attributes not supported for Cursor_Tag."; end if; -- This is a Cursor_Tag, check that the current -- table cursor is valid for it. for K in 1 .. D loop if State.Cursor (K) > Dynamic.Length (Cursor_Tag, Name, 1 & State.Cursor (1 .. K - 1)) then Valid_Cursor := False; end if; end loop; if Valid_Cursor then L := Dynamic.Length (Cursor_Tag, Name, 1 & State.Cursor (1 .. State.Table_Level - 1)); if D = 1 and then L = 1 then -- A standard tag (single value) return Data.Translate (Var, Dynamic.Value (Cursor_Tag, Name, (1 => 1)), C'Access); else -- A composite tag, check that the dimension -- of the tag correspond to the current table -- nested level. if D = State.Table_Level then return Data.Translate (Var, Dynamic.Value (Cursor_Tag, Name, State.Cursor (1 .. D)), C'Access); else -- Otherwise we inline the structure return To_String (Inline_Cursor_Tag (Cursor_Tag, Name, D, State.Cursor (1 .. State.Table_Level))); end if; end if; end if; end if; end; end if; else case Tk.Kind is when Std => if Var.Attribute.Attr in Data.Nil | Data.Indent then return Data.Translate (Var, To_String (Tk.Value), C'Access); else raise Template_Error with "Attribute not valid on a discrete tag (" & Data.Image (Var) & ')'; end if; when Composite => Is_Composite.all := True; if Tk.Comp_Value.Data.Nested_Level = 1 then -- This is a vector if Var.Attribute.Attr = Data.Length then return Data.Translate (Var, Utils.Image (Tk.Comp_Value.Data.Count), C'Access); elsif Var.Attribute.Attr = Data.Up_Level then Up_Value := Var.Attribute.Value; elsif Var.Attribute.Attr /= Data.Nil then raise Template_Error with "This attribute is not valid for a " & "vector tag (" & Data.Image (Var) & ')'; end if; elsif Tk.Comp_Value.Data.Nested_Level = 2 then if Var.Attribute.Attr = Data.Line then -- 'Line on a matrix return Data.Translate (Var, Utils.Image (Tk.Comp_Value.Data.Count), C'Access); elsif Var.Attribute.Attr = Data.Min_Column then -- 'Min_Column on a matrix return Data.Translate (Var, Utils.Image (Tk.Comp_Value.Data.Min), C'Access); elsif Var.Attribute.Attr = Data.Max_Column then -- 'Max_Column on a matrix return Data.Translate (Var, Utils.Image (Tk.Comp_Value.Data.Max), C'Access); elsif Var.Attribute.Attr /= Data.Nil then raise Template_Error with "This attribute is not valid for a " & "matrix tag (" & Data.Image (Var) & ')'; end if; end if; declare Result : Unbounded_String; Found : Boolean; begin Field (Tk.Comp_Value, State.Cursor (1 .. State.Table_Level), Up_Value, Result, Found); return Data.Translate (Var, To_String (Result), C'Access); end; end case; end if; end; case Var.Internal is when Data.Up_Table_Line => if State.Table_Level < 2 then return Data.Translate (Var, "0", C'Access); else return Data.Translate (Var, Utils.Image (State.Cursor (State.Table_Level - 1)), C'Access); end if; when Data.Table_Line => if State.Table_Level = 0 then return Data.Translate (Var, "0", C'Access); else return Data.Translate (Var, Utils.Image (State.Cursor (State.Table_Level)), C'Access); end if; when Data.Number_Line => return Data.Translate (Var, Utils.Image (State.Max_Lines), C'Access); when Data.Table_Level => return Data.Translate (Var, Utils.Image (State.Table_Level), C'Access); when Data.Now => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%Y-%m-%d %H:%M:%S"), C'Access); when Data.Year => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%Y"), C'Access); when Data.Month => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%m"), C'Access); when Data.Day => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%d"), C'Access); when Data.Hour => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%H"), C'Access); when Data.Minute => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%M"), C'Access); when Data.Second => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%S"), C'Access); when Data.Month_Name => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%B"), C'Access); when Data.Day_Name => return Data.Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%A"), C'Access); when Data.No => null; end case; -- The tag was not found in the Translation_Table, we either -- returns the empty string or we keep the tag as is. if Keep_Unknown_Tags then return Data.Image (Var); else return Data.Translate (Var, "", C'Access); end if; end Translate; begin if T = null then return; end if; case T.Kind is when Info | C_Info => Analyze (T.Next, State); when Text => declare N : Tree := T; begin begin -- Handles all consecutive Text nodes while N /= null and then N.Kind = Text loop Analyze (N.Text); N := N.Next; end loop; exception when E : others => raise Template_Error with Exceptions.Exception_Message (E) & " In " & Filename & " at line" & Natural'Image (N.Line); end; Analyze (N, State); end; when Set_Stmt => declare N : Tree := T; begin begin -- Handles all consecutive Set nodes while N /= null and then N.Kind = Set_Stmt loop Handle_Set : declare Name : constant String := To_String (N.Def.Name); Pos : Definitions.Def_Map.Cursor; Success : Boolean; begin Pos := D_Map.Find (Name); if Definitions.Def_Map.Has_Element (Pos) then D_Map.Replace_Element (Pos, New_Item => N.Def.N); else D_Map.Insert (Name, N.Def.N, Pos, Success); end if; end Handle_Set; N := N.Next; end loop; end; Analyze (N, State); end; when If_Stmt => begin if Expr.Is_True (Analyze (T.Cond)) then Analyze (T.N_True, State); else Analyze (T.N_False, State); end if; exception when E : others => raise Template_Error with Exceptions.Exception_Message (E) & " In " & Filename & " at line" & Natural'Image (T.Line); end; Analyze (T.Next, State); when Table_Stmt => declare Start_Pos : Positive; End_Pos : Natural; Max_Lines, Max_Expand : Natural; begin Get_Max (T, Max_Lines, Max_Expand); if not T.Align_On.Is_Empty then Flush; Start_Pos := Length (Results) + 1; end if; Analyze (T.Blocks, Parse_State'(State.F_Params'Length, State.Cursor, Max_Lines, Max_Expand, T.Reverse_Index, State.Table_Level + 1, State.Inline_Sep, State.Filename, T.Line, T.Blocks_Count, State.I_Params, State.F_Params, Empty_Block_State, T.Terse, L_State'Unchecked_Access)); -- Align_On attribute present if not T.Align_On.Is_Empty then Flush; End_Pos := Length (Results); -- we have some content for the table. Let's align it as -- needed. if Start_Pos < End_Pos then Replace_Slice (Results, Start_Pos, End_Pos, Align_On (T.Align_On, Slice (Results, Start_Pos, End_Pos))); end if; end if; end; Analyze (T.Next, State); when Extends_Stmt => -- Expand all the blocks, and create temporary variables from -- them. In_Extends := In_Extends + 1; Analyze (T.N_Extends, State); In_Extends := In_Extends - 1; Analyze (T.E_Included); -- ??? Should now remove the temporary variables Analyze (T.Next, State); when Block_Stmt => if In_Extends = 0 then declare B : constant Tree_Map.Cursor := Named_Blocks.Find (To_String (T.B_Name)); begin if Tree_Map.Has_Element (B) then Analyze (Tree_Map.Element (B), State); else -- Use default value Analyze (T.N_Block, State); end if; end; else -- add the block's expansion to the variables Named_Blocks.Include (To_String (T.B_Name), T.N_Block); end if; Analyze (T.Next, State); when Section_Block => declare B_State : array (1 .. State.Blocks_Count) of Block_State; B : Positive; Mark : Natural := 0; begin for K in 1 .. State.Max_Expand loop if State.Terse_Table then Mark := Get_Mark; end if; declare New_Cursor : Indices := State.Cursor; Block : Tree := T; begin if State.Reverse_Index then New_Cursor (State.Table_Level) := State.Max_Expand - K + 1; else New_Cursor (State.Table_Level) := K; end if; B := 1; while Block /= null loop -- For all blocks in this table if B_State (B).Section = null or else B_State (B).Section.N_Section = null then B_State (B) := (1, Block.Sections); else B_State (B) := (B_State (B).Section_Number + 1, B_State (B).Section.N_Section); end if; Analyze (Block.Common, Parse_State'(State.F_Params'Length, New_Cursor, State.Max_Lines, State.Max_Expand, State.Reverse_Index, State.Table_Level, State.Inline_Sep, State.Filename, Block.Line, State.Blocks_Count, State.I_Params, State.F_Params, Empty_Block_State, State.Terse_Table, L_State'Unchecked_Access)); Analyze (Block.Sections, Parse_State'(State.F_Params'Length, New_Cursor, State.Max_Lines, State.Max_Expand, State.Reverse_Index, State.Table_Level, State.Inline_Sep, State.Filename, Block.Line, State.Blocks_Count, State.I_Params, State.F_Params, B_State (B), State.Terse_Table, L_State'Unchecked_Access)); Block := Block.Next; B := B + 1; end loop; if State.Terse_Table then Rollback (Activate => Output = False, Mark => Mark); end if; end; end loop; end; when Section_Stmt => Analyze (State.Block.Section.Next, Parse_State'(State.F_Params'Length, State.Cursor, State.Max_Lines, State.Max_Expand, State.Reverse_Index, State.Table_Level, State.Inline_Sep, State.Filename, T.Line, State.Blocks_Count, State.I_Params, State.F_Params, State.Block, State.Terse_Table, L_State'Unchecked_Access)); when Include_Stmt => Analyze (T.I_Included); Analyze (T.Next, State); when Inline_Stmt => declare Start_Pos : Positive; End_Pos : Natural; begin Flush; Start_Pos := Length (Results) + 1; Analyze (T.I_Block, Parse_State'(State.F_Params'Length, Cursor => State.Cursor, Max_Lines => State.Max_Lines, Max_Expand => State.Max_Expand, Reverse_Index => State.Reverse_Index, Table_Level => State.Table_Level, Inline_Sep => T.Sep, Filename => State.Filename, Line => T.Line, Blocks_Count => State.Blocks_Count, I_Params => State.I_Params, F_Params => State.F_Params, Block => State.Block, Terse_Table => State.Terse_Table, Parent => L_State'Unchecked_Access)); Flush; End_Pos := Length (Results); if Start_Pos < End_Pos then Replace_Slice (Results, Start_Pos, End_Pos, Rewrite_Inlined_Block (T, Slice (Results, Start_Pos, End_Pos))); end if; end; Analyze (T.Next, State); end case; end Analyze; ----------- -- Flush -- ----------- procedure Flush is begin Append (Results, Buffer (1 .. Last)); Last := 0; end Flush; T : Static_Tree; begin T := Load (Filename, Cached); Now := Ada.Calendar.Clock; -- Used for the time related variable -- Fill the Unused_Variables set with all variables for A in Translations.Set.Iterate loop Unused_Variables.Include (Association_Map.Key (A)); end loop; declare State : Parse_State := Empty_State; begin State.Filename := To_Unbounded_String (Filename); State.Line := T.Info.Line; Analyze (T.C_Info, State); end; if Cached then Cached_Files.Release (T); else Release (T.Info); end if; -- Flush buffer and return result Flush; -- Now report all unused variables if Report /= null then for V of Unused_Variables loop Report (V, Reason => Unused); end loop; end if; return Results; end Parse; -------------------------- -- Print_Defined_Macros -- -------------------------- procedure Print_Defined_Macros is begin Macro.Print_Defined_Macros; end Print_Defined_Macros; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (T : Tree; Level : Natural := 0) is separate; procedure Print_Tree (Filename : String) is T : Static_Tree; begin T := Load (Filename); Print_Tree (T.Info); Release (T.Info); end Print_Tree; ----------- -- Quote -- ----------- function Quote (Str : String) return String is K : constant Natural := Strings.Fixed.Index (Str, " "); begin if K = 0 and then Str'Length > 0 then return Str; else return '"' & Str & '"'; end if; end Quote; --------------------- -- Register_Filter -- --------------------- procedure Register_Filter (Name : String; Handler : Callback) renames Filter.Register; procedure Register_Filter (Name : String; Handler : Callback_No_Param) renames Filter.Register; procedure Register_Filter (Name : String; Filter : not null access User_Filter'Class) renames Filter.Register; procedure Free_Filters renames Filter.Free_Filters; ----------- -- Macro -- ----------- procedure Register_Macro_Handler (Callback : Macro_Callback) is begin Macro.Callback := Callback; end Register_Macro_Handler; ------------- -- Release -- ------------- procedure Release (T : in out Tree; Include : Boolean := True) is procedure Release (Included : in out Included_File_Info); -- Release for Included ------------- -- Release -- ------------- procedure Release (Included : in out Included_File_Info) is begin if Include then Release (Included.File.Info, Include); for K in Included.Params'Range loop Data.Release (Included.Params (K)); end loop; Data.Unchecked_Free (Included.Params); Data.Release (Included.Filename); end if; end Release; begin if T = null then return; end if; case T.Kind is when Info => declare I : Tree := T.I_File; O : Tree; begin while I /= null loop O := I; I := I.Next; Unchecked_Free (O); end loop; end; Release (T.Next, Include); when C_Info => Release (T.Next, Include); when Text => declare N : Tree := T; Tmp : Tree; begin -- Handles all consecutive Text nodes while N /= null and then N.Kind = Text loop Data.Release (N.Text); Tmp := N; N := N.Next; Unchecked_Free (Tmp); end loop; Release (N, Include); end; T := null; -- T has been freed, we set the pointer to null to avoid double -- deallocation by the call to Free at the end of this routine. when Set_Stmt => Definitions.Release (T.Def); Release (T.Next, Include); when If_Stmt => Expr.Release (T.Cond); Release (T.N_True, Include); Release (T.N_False, Include); Release (T.Next, Include); when Table_Stmt => Release (T.Blocks, Include); Release (T.Next, Include); when Section_Block => Release (T.Sections, Include); Release (T.Common, Include); Release (T.Next, Include); when Extends_Stmt => Release (T.N_Extends, Include); Release (T.E_Included); Release (T.Next, Include); when Block_Stmt => Release (T.N_Block, Include); when Section_Stmt => Release (T.Next, Include); Release (T.N_Section, Include); when Include_Stmt => Release (T.I_Included); Release (T.Next, Include); when Inline_Stmt => Release (T.I_Block, Include); Release (T.Next, Include); end case; Unchecked_Free (T); end Release; ------------------- -- Release_Cache -- ------------------- procedure Release_Cache is begin Cached_Files.Release; end Release_Cache; ------------ -- Remove -- ------------ procedure Remove (Set : in out Translate_Set; Name : String) is begin if Set.Set.Contains (Name) then Set.Set.Delete (Name); end if; end Remove; ------------------- -- Set_Separator -- ------------------- procedure Set_Separator (T : in out Tag; Separator : String) is begin T.Data.Separator := To_Unbounded_String (Separator); end Set_Separator; ------------------------ -- Set_Tag_Separators -- ------------------------ procedure Set_Tag_Separators (Start_With : String := Default_Begin_Tag; Stop_With : String := Default_End_Tag) is begin Begin_Tag := To_Unbounded_String (Start_With); End_Tag := To_Unbounded_String (Stop_With); end Set_Tag_Separators; ---------- -- Size -- ---------- function Size (T : Tag) return Natural is begin return T.Data.Count; end Size; function Size (Set : Translate_Set) return Natural is begin return Natural (Set.Set.Length); end Size; ------------------- -- Tag_From_Name -- ------------------- function Tag_From_Name (Name : String) return String is begin return To_String (Begin_Tag) & Name & To_String (End_Tag); end Tag_From_Name; ------------ -- To_Set -- ------------ function To_Set (Table : Translate_Table) return Translate_Set is Set : Translate_Set; begin for K in Table'Range loop Insert (Set, Table (K)); end loop; return Set; end To_Set; --------------- -- Translate -- --------------- function Translate (Template : String; Translations : Translate_Table := No_Translation) return String is begin return Translate (Template, To_Set (Translations)); end Translate; function Translate (Template : String; Translations : Translate_Set) return String is T : Data.Tree := Data.Parse (Template, 1); P : Data.Tree := T; Results : Unbounded_String; function Translate (Var : Data.Tag_Var) return String; -- Returns translation for Var --------------- -- Translate -- --------------- function Translate (Var : Data.Tag_Var) return String is Pos : Association_Map.Cursor; C : aliased Filter.Filter_Context := (0, Translations, null, No_Parameter); begin -- ??? we should probably handle macros there too Pos := Translations.Set.Find (To_String (Var.Name)); if Association_Map.Has_Element (Pos) then declare Item : constant Association := Association_Map.Element (Pos); begin case Item.Kind is when Std => return Data.Translate (Var, To_String (Item.Value), C'Access); when others => return ""; end case; end; end if; return ""; end Translate; use type Data.Tree; begin while P /= null loop case P.Kind is when Data.Text => Append (Results, P.Value); when Data.Var => Append (Results, Translate (P.Var)); end case; P := P.Next; end loop; Data.Release (T); return To_String (Results); end Translate; ------------- -- Version -- ------------- function Version return String is separate; -- so that it can be generated at build time end Templates_Parser;