-- Abstract : -- -- See spec. -- -- Copyright (C) 2018 - 2023 Free Software Foundation, Inc. -- -- 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 MERCHAN- -- TABILITY 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. pragma License (Modified_GPL); with Ada.Containers; with Ada.Exceptions; with Ada.Streams.Stream_IO; with Ada.Strings.Maps; with Ada.Tags; with GNAT.Traceback.Symbolic; package body WisiToken.Syntax_Trees is -- Body specs, alphabetical, as needed type Visit_Parent_Mode is (Before, After); function Append_Stream_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; State : in Unknown_State_Index) return Terminal_Ref with Post => Tree.Valid_Terminal (Append_Stream_Element'Result); -- Add Node at Stream.Last; if not Shared_Stream, set Stack_Top to -- element containing Node. If Node is from Shared_Stream, it has -- been copied function Child_Index (Parent : in Node; Child : in Valid_Node_Access) return SAL.Peek_Type; procedure Copy_Ancestors (Tree : in out Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; New_Node : in Valid_Node_Access; User_Data : in User_Data_Access_Constant); -- New_Node is a copy of Ref.Ref.Node; copy all ancestors, updating -- child links. function Copy_Node (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Parent : in Node_Access; User_Data : in User_Data_Access_Constant; Copy_Children : in Boolean; Copy_Following_Deleted : in Boolean; New_Error_List : in Error_List_Access := null; Set_Error_List : in Boolean := False; Set_Copied_Node : in Boolean := False) return Valid_Node_Access with Pre => (if Copy_Children then Tree.Parents_Set); -- If Set_Error_List is False, new node has copy of Node.Error_List. -- Otherwise, new node has New_Error_List. function Find_Match (Error_List : in Error_List_Access; Predicate : in Error_Predicate) return Error_Data_Lists.Cursor; procedure First_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Trailing_Non_Grammar : in Boolean) with Pre => Rooted (Ref.Ref) and Ref.Parents.Depth = 0; -- Update Ref to first source terminal in Ref.Node, initialize Ref.Parents. procedure Insert_Stream_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Before : in Stream_Element_Lists.Cursor := Stream_Element_Lists.No_Element); -- If Before is No_Element, add Node after Stream.Stack_Top (at -- beginning of input). Otherwise add Node before Before. -- -- Caller must change Stream.Stack_Top if necessary. function Insert_Stream_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Before : in Stream_Element_Lists.Cursor := Stream_Element_Lists.No_Element) return Rooted_Ref; -- Same as procedure, return new element. function Is_Optimized_List (Productions : in Production_Info_Trees.Vector; ID : in Token_ID) return Boolean; function Last_Source_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return Node_Access; procedure Last_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Trailing_Non_Grammar : in Boolean; Parse_Stream : in Stream_ID) with Pre => Rooted (Ref.Ref) and Ref.Parents.Depth = 0; -- Update Ref to last source terminal in Ref.Node, initialize Ref.Parents. procedure Move_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Ref : in out Stream_Node_Parents; New_Node : in Valid_Node_Access; User_Data : in User_Data_Access_Constant); -- Move Ref to Stream, replacing Ref.Node with New_Node, -- copying all ancestors. Update Ref to point to new stream element -- with copied nodes. procedure Next_Node (Node : in out Node_Access); -- Assumes Tree.Parents_Set. procedure Next_Node (Tree : in Syntax_Trees.Tree; Node : in out Stream_Node_Parents) with Pre => Node.Ref.Node /= Invalid_Node_Access; procedure Next_Non_Grammar (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref); procedure Next_Nonterm (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref); function Next_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Trailing_Non_Grammar : in Boolean) return Stream_Node_Ref; procedure Next_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Trailing_Non_Grammar : in Boolean); procedure Prev_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access; Parents : in out Node_Stacks.Stack); function Process_Tree (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Visit_Parent : in Visit_Parent_Mode; Process_Node : access function (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean) return Boolean; -- Call Process_Node on nodes in tree rooted at Node. Return when -- Process_Node returns False (Process_Tree returns False), or when -- all nodes have been processed (Process_Tree returns True). procedure Replace_Node (Element : in Stream_Index; New_Node : in Valid_Node_Access); procedure Set_Children (Tree : in out Syntax_Trees.Tree; Parent : in out Valid_Node_Access; Children : in Node_Access_Array) with Pre => Tree.Parents_Set; function Subtree_Image (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Node_Numbers : in Boolean := True; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Line_Numbers : in Boolean := False; Level : in Integer := 0) return String; ---------- -- Public and body operations, alphabetical procedure Add_Deleted (Tree : in out Syntax_Trees.Tree; Deleted_Node : in Valid_Node_Access; Prev_Terminal : in out Stream_Node_Parents; User_Data : in User_Data_Access_Constant) is -- We need to copy Prev_Terminal.Node, and replace any links to it. -- It is tempting to attempt to optimize this; if no parsers have -- spawned since Following_Deleted was last edited, we don't need to -- copy Prev_Terminal.Ref.Node again. But that would require a -- reference count on Prev_Terminal.Ref.Node, which would be -- non-incremental in spawn and terminate parser. New_Node : constant Valid_Node_Access := Copy_Node (Tree, Prev_Terminal.Ref.Node, Parent => (if Tree.Parents_Set then Prev_Terminal.Ref.Node else Invalid_Node_Access), User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => True); begin if Prev_Terminal.Parents.Depth = 0 then pragma Assert (Rooted (Prev_Terminal.Ref)); -- There are no child links yet Replace_Node (Prev_Terminal.Ref.Element, New_Node); Prev_Terminal.Ref.Node := New_Node; else -- Need to edit child link, which requires copying parent node, up to -- the element root. Copy_Ancestors (Tree, Prev_Terminal, New_Node, User_Data); end if; Prev_Terminal.Ref.Node.Following_Deleted.Append (Deleted_Node); for Node of Deleted_Node.Following_Deleted loop Prev_Terminal.Ref.Node.Following_Deleted.Append (Node); end loop; Deleted_Node.Following_Deleted.Clear; -- We need to move the non_grammar now, so they are correct for later -- error recover sessions. test_incremental.adb : Edit_String_10 if Trace_Action > WisiToken.Outline then -- Trace_Action to be consistent with messages from user Delete_Token. Tree.Lexer.Trace.Put_Line ("delete token " & Tree.Image (Deleted_Node, Node_Numbers => True, Non_Grammar => True)); if Deleted_Node.Non_Grammar.Length > 0 then Tree.Lexer.Trace.Put_Line (" ... move non_grammar to " & Tree.Image (Prev_Terminal.Ref.Node, Node_Numbers => True, Non_Grammar => True)); end if; end if; Prev_Terminal.Ref.Node.Non_Grammar.Append (Deleted_Node.Non_Grammar); -- We don't do Deleted_Node.Non_Grammar.Clear here; we are not -- editing the shared stream. That is done in Finish_Parse. end Add_Deleted; procedure Add_Errors (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Errors : in Error_Data_Lists.List) is pragma Unreferenced (Stream); -- Only used in precondition. begin if Node.Error_List = null then Node.Error_List := new Error_Data_Lists.List'(Errors); else for Err of Errors loop Node.Error_List.Append (Err); end loop; end if; end Add_Errors; function Add_Error (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Data : in Error_Data'Class; User_Data : in User_Data_Access_Constant) return Valid_Node_Access -- Copy Node, adding Data to its error list. Return new node. is function Copy_Errors return Error_List_Access is begin if Node.Error_List = null then return new Error_Data_Lists.List'(Error_Data_Lists.To_List (Data)); else return Result : constant Error_List_Access := new Error_Data_Lists.List'(Node.Error_List.all) do Result.Append (Data); end return; end if; end Copy_Errors; begin return Copy_Node (Tree, Node, Parent => (if Tree.Parents_Set then Node.Parent else Invalid_Node_Access), User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => True, New_Error_List => Copy_Errors, Set_Error_List => True); end Add_Error; function Add_Errors (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Errors : in Error_Data_Lists.List; User_Data : in User_Data_Access_Constant) return Valid_Node_Access -- Copy Node, adding Errors to its error list. Return new node. is function Copy_Errors return Error_List_Access is begin if Node.Error_List = null then return new Error_Data_Lists.List'(Errors); else return Result : constant Error_List_Access := new Error_Data_Lists.List'(Node.Error_List.all) do for Error of Errors loop Result.Append (Error); end loop; end return; end if; end Copy_Errors; begin return Copy_Node (Tree, Node, Parent => (if Tree.Parents_Set then Node.Parent else Invalid_Node_Access), User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => True, New_Error_List => Copy_Errors, Set_Error_List => True); end Add_Errors; procedure Add_Error_To_Input (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Data : in Error_Data'Class; User_Data : in User_Data_Access_Constant) is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Error_Ref : Stream_Node_Parents := Tree.To_Stream_Node_Parents (if Parse_Stream.Stack_Top = Parse_Stream.Elements.Last then (Tree.Shared_Stream, (Cur => Parse_Stream.Shared_Link), Element (Parse_Stream.Shared_Link).Node) else (Stream, (Cur => Next (Parse_Stream.Stack_Top)), Element (Next (Parse_Stream.Stack_Top)).Node)); begin Tree.First_Terminal (Error_Ref, Following => False); Move_Element (Tree, Stream, Error_Ref, Add_Error (Tree, Error_Ref.Ref.Node, Data, User_Data), User_Data); if Parse_Stream.Elements.Last = Parse_Stream.Stack_Top then Next (Parse_Stream.Shared_Link); end if; end Add_Error_To_Input; procedure Add_Error_To_Stack_Top (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Data : in Error_Data'Class; User_Data : in User_Data_Access_Constant) is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Orig : Stream_Element := Element (Parse_Stream.Stack_Top); begin Orig.Node := Add_Error (Tree, Element (Parse_Stream.Stack_Top).Node, Data, User_Data); Replace_Element (Parse_Stream.Stack_Top, Orig); end Add_Error_To_Stack_Top; procedure Add_Errors (Tree : in out Syntax_Trees.Tree; Error_Ref : in out Stream_Node_Parents; Errors : in Error_Data_Lists.List; User_Data : in User_Data_Access_Constant) is function Copy_Errors return Error_List_Access is begin if Error_Ref.Ref.Node.Error_List = null then return new Error_Data_Lists.List'(Errors); else return Result : constant Error_List_Access := new Error_Data_Lists.List'(Error_Ref.Ref.Node.Error_List.all) do for Err of Errors loop Result.Append (Err); end loop; end return; end if; end Copy_Errors; New_Node : constant Valid_Node_Access := Copy_Node (Tree, Error_Ref.Ref.Node, Parent => (if Tree.Parents_Set then Error_Ref.Ref.Node.Parent else Invalid_Node_Access), User_Data => User_Data, Copy_Children => False, New_Error_List => Copy_Errors, Copy_Following_Deleted => True, Set_Error_List => True); begin Copy_Ancestors (Tree, Error_Ref, New_Node, User_Data); end Add_Errors; function Add_Identifier (Tree : in out Syntax_Trees.Tree; ID : in Token_ID; Identifier : in Identifier_Index) return Valid_Node_Access is begin return Result : constant Valid_Node_Access := new Node' (Label => Virtual_Identifier, Child_Count => 0, ID => ID, Node_Index => -(Tree.Nodes.Last_Index + 1), Identifier => Identifier, others => <>) do Tree.Nodes.Append (Result); end return; end Add_Identifier; function Add_Nonterm_1 (Tree : in out Syntax_Trees.Tree; Production : in WisiToken.Production_ID; Children : in Valid_Node_Access_Array; Clear_Parents : in Boolean; Recover_Conflict : in Boolean) return Valid_Node_Access is Nonterm_Node : constant Valid_Node_Access := new Node' (Label => Syntax_Trees.Nonterm, Child_Count => Children'Last, ID => Production.LHS, Node_Index => -(Tree.Nodes.Last_Index + 1), Children => To_Node_Access (Children), RHS_Index => Production.RHS, Virtual => False, Recover_Conflict => Recover_Conflict, others => <>); begin Tree.Nodes.Append (Nonterm_Node); for Child of Children loop case Child.Label is when Source_Terminal | Virtual_Identifier => null; when Virtual_Terminal => Nonterm_Node.Virtual := True; when Nonterm => if Child.Virtual then Nonterm_Node.Virtual := True; end if; end case; if Child.Parent /= Invalid_Node_Access then if Clear_Parents then declare Other_Parent : constant Node_Access := Child.Parent; Child_Index : constant SAL.Base_Peek_Type := Syntax_Trees.Child_Index (Other_Parent.all, Child); begin Other_Parent.Children (Child_Index) := Invalid_Node_Access; end; else raise SAL.Programmer_Error with "attempt to use children with existing parents"; end if; end if; if Tree.Parents_Set then Child.Parent := Nonterm_Node; end if; end loop; return Nonterm_Node; end Add_Nonterm_1; function Add_Nonterm (Tree : in out Syntax_Trees.Tree; Production : in WisiToken.Production_ID; Children : in Valid_Node_Access_Array; Clear_Parents : in Boolean) return Valid_Node_Access is begin return Add_Nonterm_1 (Tree, Production, Children, Clear_Parents, Recover_Conflict => False); end Add_Nonterm; function Add_Source_Terminal_1 (Tree : in out Syntax_Trees.Tree; Terminal : in WisiToken.Lexer.Token; In_Shared_Stream : in Boolean; Errors : in Error_Data_Lists.List) return Valid_Node_Access is begin return Result : constant Valid_Node_Access := new Node' (Label => Source_Terminal, Child_Count => 0, ID => Terminal.ID, Node_Index => (if In_Shared_Stream then Tree.Next_Terminal_Node_Index else -(Tree.Nodes.Last_Index + 1)), Byte_Region => Terminal.Byte_Region, Char_Region => Terminal.Char_Region, New_Line_Count => New_Line_Count (Terminal.Line_Region), Error_List => (if Errors.Length = 0 then null else new Error_Data_Lists.List'(Errors)), others => <>) do if Terminal.ID = Tree.Lexer.Descriptor.EOI_ID then pragma Assert (In_Shared_Stream); Tree.EOI := Result; Result.Non_Grammar.Append (Terminal); end if; if In_Shared_Stream then Tree.Next_Terminal_Node_Index := @ + 1; end if; Tree.Nodes.Append (Result); end return; end Add_Source_Terminal_1; function Add_Terminal (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Terminal : in WisiToken.Lexer.Token; Errors : in Error_Data_Lists.List) return Single_Terminal_Ref is begin return Append_Stream_Element (Tree, Stream, Add_Source_Terminal_1 (Tree, Terminal, In_Shared_Stream => Stream = Tree.Shared_Stream, Errors => Errors), State => Unknown_State); end Add_Terminal; function Add_Terminal (Tree : in out Syntax_Trees.Tree; Terminal : in WisiToken.Lexer.Token; Errors : in Error_Data_Lists.List) return Valid_Node_Access is begin return Add_Source_Terminal_1 (Tree, Terminal, In_Shared_Stream => False, Errors => Errors); end Add_Terminal; function Add_Terminal (Tree : in out Syntax_Trees.Tree; Terminal : in Token_ID) return Valid_Node_Access is begin return Result : constant Valid_Node_Access := new Node' (Label => Virtual_Terminal, Child_Count => 0, ID => Terminal, Node_Index => -(Tree.Nodes.Last_Index + 1), others => <>) do Tree.Nodes.Append (Result); end return; end Add_Terminal; function Append_Stream_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; State : in Unknown_State_Index) return Terminal_Ref is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); New_Element : constant Stream_Element_Lists.Cursor := Parse_Stream.Elements.Append ((Node => Node, State => State)); begin if Stream = Tree.Shared_Stream then -- Stack_Top is always Invalid_Stream_Element. null; else Parse_Stream.Stack_Top := New_Element; end if; return (Stream, (Cur => New_Element), Node); end Append_Stream_Element; function Augmented (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Augmented_Class_Access is begin return Node.Augmented; end Augmented; function Augmented_Const (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Augmented_Class_Access_Constant is begin return Augmented_Class_Access_Constant (Node.Augmented); end Augmented_Const; procedure Breakdown (Tree : in out Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Productions : in Production_Info_Trees.Vector; User_Data : in Syntax_Trees.User_Data_Access_Constant; First_Terminal : in Boolean) is use Stream_Element_Lists; Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Ref.Ref.Stream.Cur); Cur : Cursor renames Ref.Ref.Element.Cur; Target : Valid_Node_Access renames Ref.Ref.Node; To_Delete : Cursor := Cur; Inverted_Parents : Node_Stacks.Stack := Ref.Parents.Invert; -- Parents from Target to Cur. Inverted_Parents.Peek (1) is -- Ref.Ref.Element.Node, and Inverted_Parents.Peek -- (Inverted_Parents.Depth) is Target parent. -- -- As Breakdown proceeds, Inverted_Parents is popped; -- Inverted_Parents.Peek (1) is always the stream node that is the -- ancestor of Target. procedure Move_Errors -- Move errors on To_Delete.Element.Node to first terminal. Update -- Inverted_Parents. is Node : constant Valid_Node_Access := Element (To_Delete).Node; New_Errors : Error_Data_Lists.List; begin if Node.Error_List = null or else Node.Error_List.Length = 0 then return; else for Err of Node.Error_List.all loop New_Errors.Append (To_Message (Err, Tree, Node)); end loop; -- At this point, To_Delete is still in the stream; the children of -- To_Delete have been pushed on the stream before it; Cur is the -- first of those children. Find the terminal to move errors to, and -- the new stream element containing it. declare First_Terminal : Stream_Node_Parents := Tree.To_Stream_Node_Parents (Tree.To_Rooted_Ref (Ref.Ref.Stream, (Cur => To_Delete))); Modify_Element_Node : Node_Access; Modify_Element : Cursor := Cur; begin Tree.First_Terminal (First_Terminal, Following => False); -- We know To_Delete has at least one terminal, because we don't put -- errors on empty nonterms, we just delete them. pragma Assert (First_Terminal.Ref.Node /= Invalid_Node_Access); -- We are deleting To_Delete; don't include it in -- First_Terminal.Parents, to avoid an unnecessary copy. First_Terminal.Parents.Bottom_Pop; if First_Terminal.Parents.Depth = 0 then -- ada_mode-recover_debbugs_36548.adb Modify_Element_Node := First_Terminal.Ref.Node; else Modify_Element_Node := First_Terminal.Parents.Peek (First_Terminal.Parents.Depth); end if; loop exit when Element (Modify_Element).Node = Modify_Element_Node; Next (Modify_Element); end loop; First_Terminal.Ref.Element := (Cur => Modify_Element); declare Update_Target : constant Boolean := First_Terminal.Ref.Node = Target; -- Inverted_Parents holds the path from To_Delete to Target; if -- Add_Errors copies any of those nodes, update the Inverted_Parents -- value. Update_Parents_Index : SAL.Base_Peek_Type := 0; Inverted_Parents_Index : SAL.Base_Peek_Type := 1; First_Terminal_Parents_Index : SAL.Base_Peek_Type := First_Terminal.Parents.Depth; begin loop exit when First_Terminal_Parents_Index = 0 or Inverted_Parents_Index > Inverted_Parents.Depth; exit when Inverted_Parents.Peek (Inverted_Parents_Index) /= First_Terminal.Parents.Peek (First_Terminal_Parents_Index); Update_Parents_Index := Inverted_Parents_Index; Inverted_Parents_Index := @ + 1; First_Terminal_Parents_Index := @ - 1; end loop; Tree.Add_Errors (First_Terminal, New_Errors, User_Data); for I in 1 .. Update_Parents_Index loop Inverted_Parents.Set (I, Inverted_Parents.Depth, First_Terminal.Parents.Peek (First_Terminal.Parents.Depth - I + 1)); end loop; if Update_Target then Target := First_Terminal.Ref.Node; end if; end; end; end if; end Move_Errors; begin Undo_Reduce_Loop : loop declare Stream_Node : constant Valid_Node_Access := Element (Cur).Node; begin exit Undo_Reduce_Loop when (if First_Terminal then Tree.First_Terminal (Stream_Node) = Target else Stream_Node = Target); pragma Assert (Stream_Node.Label = Nonterm); pragma Assert (Stream_Node.Child_Count > 0); -- otherwise we would not get here. if Is_Optimized_List (Productions, Stream_Node.ID) and Stream_Node.RHS_Index = 1 then -- Split list at list ancestor of Ref.Node -- -- From test_syntax_trees.adb Breakdown_Optimized_List_01, stream looks -- like: -- -- -- -- -32:declarations_1 -- | -30:declarations_1 Split_Node parent 2 -- | | -28:declarations_1 Split_Node parent 1 -- | | | -26:declarations_1 -- | | | | -24:declarations_0 -- | | | | | -23:declaration_0 -- | | | | | | -- | | | | -25:declaration_0 -- | | | | | -- | | | -27:declaration_0 Split_Node -- | | | | -- | | -29:declaration_0 -- | | | -- | -31:declaration_0 -- | | -- -- -- -- Stream_Node is node -32; the top declarations node with RHS_Index -- 1. -- -- Note that if this list has been edited before, it may have top -- nodes with RHS_Index 2; each of those declarations node has two -- declarations children, and are already optimized, so they are -- broken down the same as non-list nodes. Other cases leave -- RHS_Index 2 in lower nodes; test_incremental.adb Recover_08*. declare List_ID : constant Token_ID := Stream_Node.ID; Target_Anc_Index : SAL.Base_Peek_Type := 1; Split_Node : Node_Access; Insert_Following : constant Stream_Element_Lists.Cursor := Next (Cur); -- Insert nodes following Split_Node before this. Insert_Leading : Stream_Element_Lists.Cursor := Cur; -- Insert nodes preceding Split_node before this. procedure Find_Target_Element -- Update Cur to stream element at or after Cur containing Target is Target_Anc_Node : constant Valid_Node_Access := (if Target_Anc_Index = Inverted_Parents.Depth then Target else Inverted_Parents.Peek (Target_Anc_Index + 1)); begin Find_Element : loop exit Find_Element when Element (Cur).Node = Target_Anc_Node; Next (Cur); end loop Find_Element; end Find_Target_Element; procedure Insert_Children (Node : in Valid_Node_Access) -- Insert Node.Children (2 .. Node.Child_Count) into Stream before -- Insert_Following. -- -- There is more than one child when the list has a separator -- (optimized_list_ebnf term, ada_annex_p -- parameter_specification_list, -- ada_mode-incremental_recover_02.adb), or multiple list elements -- (ada_lite_ebnf case_statement_alternative). is begin for I in 2 .. Node.Child_Count loop if I = 2 then Insert_Leading := Stream.Elements.Insert (Insert_Following, (Node.Children (I), Unknown_State)); else Stream.Elements.Insert (Insert_Following, (Node.Children (I), Unknown_State)); end if; Node.Children (I).Parent := Invalid_Node_Access; end loop; end Insert_Children; begin -- Find Split_Node, the first ancestor of Target that is a -- declarations. Start from the tree root, to handle nested lists; -- test_incremental.adb Recover_07. declare Temp : SAL.Base_Peek_Type := 2; begin loop exit when Temp > Inverted_Parents.Depth; exit when Inverted_Parents.Peek (Temp).ID /= List_ID; Target_Anc_Index := Temp; Temp := @ + 1; end loop; end; Split_Node := Inverted_Parents.Peek (Target_Anc_Index); -- Bring Split_Node to the stream, with previous and following list -- nodes each under a single stream element. -- -- Suppose Split_Node is node -27 (test_syntax_trees.adb -- Breakdown_Optimized_List_01 case "c"). The desired stream is: -- -- -- -- -26:declarations_1 -- | -24:declarations_0 -- | | -23:declaration_0 -- | | | -- | -25:declaration_0 -- | | -- -- -27:declaration_0 Split_Node -- | -- -- -35:declarations_1 New node -- | -34:declarations_0 New node -- | | | -29:declaration_0 -- | | | | -- | | -31:declaration_0 -- | | | -- -- -- -- The other test cases in Breakdown_Optimized_List_01 test special -- cases where Split_Node is near or at the beginning or end of the -- list. if Target.ID = List_ID or -- The target is a list node in the list we are breaking down. -- test_incremental.adb Recover_06a .. e. Split_Node.RHS_Index = 0 -- There are no list elements preceding Split_Node; handle separator, -- multi-element list element. test_incremental.adb Edit_Code_18 then Replace_Element (Cur, (Split_Node.Children (1), Unknown_State)); Insert_Children (Split_Node); Find_Target_Element; elsif Split_Node.Children (1).RHS_Index = 0 then -- There is one list element preceding Split_Node Replace_Element (Cur, (Split_Node.Children (1).Children (1), Unknown_State)); Insert_Children (Split_Node.Children (1)); Split_Node.Children (1).Children (1).Parent := Invalid_Node_Access; Insert_Children (Split_Node); Find_Target_Element; else -- There are more than one list elements preceding Split_Node Replace_Element (Cur, (Split_Node.Children (1), Unknown_State)); Insert_Children (Split_Node); Find_Target_Element; end if; Split_Node.Children (1).Parent := Invalid_Node_Access; Split_Node.Parent := Invalid_Node_Access; if Target_Anc_Index - 1 = 0 then -- There are no list elements following Split_node null; elsif Target_Anc_Index - 1 = 1 then -- There is only one list element following Split_Node -- test_syntax_trees.adb Breakdown_Optimized_List_01 case d1 -- -- Or Deleting_Node is an RHS_Index = 2 node, and all of the list -- elements following Split_Node are already under an RHS_Index = 1 -- node; test_incremental.adb Recover_08a. declare Deleting_Node : constant Valid_Node_Access := Inverted_Parents.Pop; begin if Deleting_Node.Error_List /= null then -- FIXME: Move errors. need test case raise SAL.Not_Implemented with "error on optimized_list"; end if; Insert_Children (Deleting_Node); Deleting_Node.Parent := Invalid_Node_Access; Deleting_Node.Children (1).Parent := Invalid_Node_Access; end; else -- Multiple list elements following Split_Node -- -- Split_Node children are now in the stream. Build a new list node -- with content of following nodes, insert it before Insert_Following. declare Following_Node : Node_Access := Invalid_Node_Access; -- The root of the new list. begin for I in reverse 1 .. Target_Anc_Index - 1 loop declare Deleting_Node : constant Valid_Node_Access := Inverted_Parents.Peek (I); begin pragma Assert (Deleting_Node.ID = Stream_Node.ID and Deleting_Node.RHS_Index in 1 | 2); -- test_incremental.adb Recover_08a, b have RHS_Index = 2 here. if Deleting_Node.Error_List /= null then -- FIXME: Move errors. need test case raise SAL.Not_Implemented with "error on optimized_list"; end if; for Child of Deleting_Node.Children loop Child.Parent := Invalid_Node_Access; end loop; if Deleting_Node.RHS_Index = 2 then pragma Assert (Deleting_Node.Children'Length = 2 and Insert_Leading /= Insert_Following); pragma Assert (I /= 1); -- If I = 1 here, Deleting_Node would be Stream_Node, and would be -- handled by the not optimizing_list branch of Undo_Reduce_Loop. if Inverted_Parents.Peek (I + 1) = Deleting_Node.Children (1) then pragma Assert (Following_Node = null); -- Split_Node is under Deleting_Node.Children (1). -- test_incremental.adb Recover_08c. -- Example tree from test_incremental.adb Recover_08c step 3 -- -- 125:declaration_list_1 ; Inverted_Parents.Peek (Target_Anc_Index - 1) -- | 118:declaration_list_2 ; Deleting_Node -- | | 117:declaration_list_1 -- | | | 105:declaration_list_0 ; Split_Node -- | | | | 48 declaration -- | | | | | -- | | | 116:declaration -- | | | | ; b contains by the deleted ';' -- | | 103:declaration_list_1 ; -- | | | 102:declaration_list_0 ; Split_Node -- | | | | ; Insert_Leading -- -- 105:Split_Node children are on the stream, 103 goes in -- Following_Node. Other children of 118 are handled in the -- next iteration of this loop. Following_Node := Add_Nonterm_1 (Tree, (List_ID, 0), Children => (1 => Deleting_Node.Children (2)), Clear_Parents => False, Recover_Conflict => False); else pragma Assert (Following_Node /= null); -- Split_Node is under Deleting_Node.Children (2). -- Example tree from test_incremental.adb Recover_08d step 3 -- -- 118:declaration_list_1 ; Inverted_Parents.Peek (Target_Anc_Index - 1) -- | 111:declaration_list_2 ; Deleting_Node -- | | 110:declaration_list_1 ; -- | | | ; c is followed by the deleted ';' -- | | 103:declaration_list_1 ; -- | | | 102:declaration_list_0 ; Split_Node -- | | | | ; Insert_Leading -- -- 102:Split_Node children are on the stream, rest of children of 103 -- are in Following_Node. 110 goes before Insert_Leading; nothing is -- added to Following_Node. Other children of 118 are handled in the -- next iteration of this loop. Insert_Leading := Stream.Elements.Insert (Insert_Leading, (Deleting_Node.Children (1), Unknown_State)); end if; elsif Following_Node = Invalid_Node_Access then pragma Assert (I = Target_Anc_Index - 1 and Deleting_Node.Children (1).ID = List_ID and Deleting_Node.RHS_Index in 0 | 1); -- Deleting_Node.Children (1).RHS_Index any of 0 .. 2, depending on -- how many nodes were before Split_Node and whether that sublist was -- edited. declare New_Children : Valid_Node_Access_Array (1 .. Deleting_Node.Child_Count - 1) := (others => Dummy_Node); begin for I in New_Children'Range loop -- If the list has a separator, it should go on the stream, not in -- Following. But we can't distinguish that from a multi-item list -- element. And the parser handles both by breaking this down and -- shifting the items individually. test_incremental.adb -- Edit_Code_18. New_Children (I) := Deleting_Node.Children (I + 1); end loop; Following_Node := Add_Nonterm_1 (Tree, (List_ID, 0), Children => New_Children, Clear_Parents => False, Recover_Conflict => False); end; else pragma Assert (Deleting_Node.RHS_Index = 1 and Deleting_Node.Children (1).ID = List_ID and Deleting_Node.Children (1).RHS_Index in 1 | 2); declare New_Children : Valid_Node_Access_Array (1 .. Deleting_Node.Child_Count) := (others => Dummy_Node); begin New_Children (1) := Following_Node; for I in 2 .. New_Children'Last loop New_Children (I) := Deleting_Node.Children (I); end loop; Following_Node := Add_Nonterm_1 (Tree, (List_ID, 1), Children => New_Children, Clear_Parents => False, Recover_Conflict => False); end; end if; end; end loop; Inverted_Parents.Pop (Target_Anc_Index - 1); Stream.Elements.Insert (Insert_Following, (Following_Node, Unknown_State)); end; end if; Inverted_Parents.Pop; -- Split_Node exit Undo_Reduce_Loop when Element (Cur).Node = Target; end; else -- Not an optimized_list node. Bring all children of Node to stream. for I in reverse 1 .. Stream_Node.Child_Count loop Cur := Stream.Elements.Insert (Element => (Node => Stream_Node.Children (I), State => Unknown_State), Before => Cur); Stream_Node.Children (I).Parent := Invalid_Node_Access; end loop; -- We need to do Move_Errors before the children of To_Delete are set -- Invalid. test_incremental.adb Missing_Name_1. Pop To_Delete from -- Inverted_Parents now, to match First_Terminal in Move_Errors. Inverted_Parents.Pop; Move_Errors; Stream.Elements.Delete (To_Delete); -- Find stream element containing Target declare Node : constant Valid_Node_Access := (if Inverted_Parents.Depth = 0 then Target else Inverted_Parents.Peek); begin Find_Element_1 : loop exit Undo_Reduce_Loop when Element (Cur).Node = Target; exit Find_Element_1 when Element (Cur).Node = Node; Next (Cur); end loop Find_Element_1; end; end if; end; To_Delete := Cur; end loop Undo_Reduce_Loop; Ref.Parents := Inverted_Parents.Invert; end Breakdown; procedure Breakdown (Tree : in out Syntax_Trees.Tree; Ref : in out Stream_Node_Ref; Productions : in Production_Info_Trees.Vector; User_Data : in Syntax_Trees.User_Data_Access_Constant; First_Terminal : in Boolean) is Ref_Parents : Stream_Node_Parents := Tree.To_Stream_Node_Parents (Ref); begin Ref := Invalid_Stream_Node_Ref; -- Allow Delete Ref.Element. Breakdown (Tree, Ref_Parents, Productions, User_Data, First_Terminal); Ref := Ref_Parents.Ref; end Breakdown; function Byte_Region (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return WisiToken.Buffer_Region is Prev_Source_Terminal : Node_Access := Invalid_Node_Access; Next_Source_Terminal : Node_Access := Invalid_Node_Access; procedure Set_Prev is begin if Node.ID = Tree.Lexer.Descriptor.SOI_ID then Prev_Source_Terminal := Node; else Prev_Source_Terminal := Tree.Prev_Source_Terminal (Node, Trailing_Non_Grammar => True); end if; end Set_Prev; begin case Node.Label is when Source_Terminal => if Trailing_Non_Grammar and Node.Non_Grammar.Length > 0 then pragma Assert (Node.Byte_Region /= Null_Buffer_Region); return (First => Node.Byte_Region.First, Last => Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last); else return Node.Byte_Region; end if; when Virtual_Terminal | Virtual_Identifier => case Node.Insert_Location is when After_Prev | Between => -- It is tempting to assert Node.Non_Grammar.Length > 0 for between -- (because there should be a new_line), but that is not true for -- "null" when we insert "null;" - it is only true for the last -- virtual token on the line. if Node.Non_Grammar.Length > 0 then return (First => Node.Non_Grammar (Node.Non_Grammar.First_Index).Byte_Region.First, Last => Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last); elsif Tree.Parents_Set then Set_Prev; if Prev_Source_Terminal = Invalid_Node_Access then -- Node is in an all virtual parse stream element. return Null_Buffer_Region; else return (First => Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last, Last => Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last - 1); end if; else return Null_Buffer_Region; end if; when Before_Next => if Node.Non_Grammar.Length > 0 then return (First => Node.Non_Grammar (Node.Non_Grammar.First_Index).Byte_Region.First, Last => Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last); elsif Tree.Parents_Set then if Node.ID = Tree.Lexer.Descriptor.EOI_ID then Next_Source_Terminal := Node; else Next_Source_Terminal := Tree.Next_Source_Terminal (Node, Trailing_Non_Grammar => True); end if; if Next_Source_Terminal = Invalid_Node_Access then -- Node is in an all virtual parse stream element. return Null_Buffer_Region; else return (First => Tree.Byte_Region (Next_Source_Terminal, Trailing_Non_Grammar => True).First, Last => Tree.Byte_Region (Next_Source_Terminal, Trailing_Non_Grammar => True).First - 1); end if; else return Null_Buffer_Region; end if; end case; when Nonterm => if Node.Child_Count = 0 then if Tree.Parents_Set then Set_Prev; if Prev_Source_Terminal = Invalid_Node_Access then -- Node is the root of an empty tree or parse stream element. return Null_Buffer_Region; else declare First : constant Buffer_Pos := Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last + 1; begin return (First, First - 1); end; end if; else return Null_Buffer_Region; end if; else Prev_Source_Terminal := First_Source_Terminal (Tree, Node, Trailing_Non_Grammar => False, Following => False); Next_Source_Terminal := Last_Source_Terminal (Tree, Node, Trailing_Non_Grammar); end if; if Prev_Source_Terminal = Invalid_Node_Access then -- Node.Child_Count > 0, but Node contains no source_terminals; it is -- all virtual. Find best estimate for First. if Tree.Parents_Set then Set_Prev; if Prev_Source_Terminal = Invalid_Node_Access then -- Tree is corrupt return Null_Buffer_Region; else declare First : constant Buffer_Pos := Tree.Char_Region (Prev_Source_Terminal, Trailing_Non_Grammar).First + 1; begin return (First, First - 1); end; end if; else return Null_Buffer_Region; end if; end if; pragma Assert (Prev_Source_Terminal /= Invalid_Node_Access and Next_Source_Terminal /= Invalid_Node_Access); return (First => Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar).First, Last => Tree.Byte_Region (Next_Source_Terminal, Trailing_Non_Grammar).Last); end case; end Byte_Region; function Byte_Region (Tree : in Syntax_Trees.Tree; Index : in Stream_Index) return WisiToken.Buffer_Region is begin return Byte_Region (Tree, Stream_Element_Lists.Element (Index.Cur).Node, Trailing_Non_Grammar => False); end Byte_Region; function Byte_Region (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Trailing_Non_Grammar : in Boolean := False) return WisiToken.Buffer_Region is Prev_Source_Terminal : Terminal_Ref := Invalid_Stream_Node_Ref; Next_Source_Terminal : Terminal_Ref := Invalid_Stream_Node_Ref; begin if Ref.Node = Invalid_Node_Access or else -- Empty nonterm Ref.Node.Label = Nonterm then Prev_Source_Terminal := (Ref.Stream, Ref.Element, First_Source_Terminal (Tree, Ref.Node, Trailing_Non_Grammar, Following => False)); Next_Source_Terminal := (Ref.Stream, Ref.Element, Last_Source_Terminal (Tree, Ref.Node, Trailing_Non_Grammar)); if Prev_Source_Terminal.Node = Invalid_Node_Access then Prev_Source_Terminal := Tree.Prev_Source_Terminal (Ref, Trailing_Non_Grammar); Next_Source_Terminal := Tree.Next_Source_Terminal (Ref, Trailing_Non_Grammar); end if; return (First => Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar).Last, Last => Tree.Byte_Region (Next_Source_Terminal, Trailing_Non_Grammar).First); else case Terminal_Label'(Ref.Node.Label) is when Source_Terminal => if Trailing_Non_Grammar and Ref.Node.Non_Grammar.Length > 0 then pragma Assert (Ref.Node.Byte_Region /= Null_Buffer_Region); return (First => Ref.Node.Byte_Region.First, Last => Ref.Node.Non_Grammar (Ref.Node.Non_Grammar.Last_Index).Byte_Region.Last); else return Ref.Node.Byte_Region; end if; when Virtual_Terminal | Virtual_Identifier => case Ref.Node.Insert_Location is when After_Prev | Between => if Ref.Node.Non_Grammar.Length > 0 then return (First => Ref.Node.Non_Grammar (Ref.Node.Non_Grammar.First_Index).Byte_Region.First, Last => Ref.Node.Non_Grammar (Ref.Node.Non_Grammar.Last_Index).Byte_Region.Last); else Prev_Source_Terminal := Tree.Prev_Source_Terminal (Ref, Trailing_Non_Grammar); return (First => Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last, Last => Tree.Byte_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last - 1); end if; when Before_Next => pragma Assert (Ref.Node.Non_Grammar.Length = 0); Next_Source_Terminal := Tree.Next_Source_Terminal (Ref, Trailing_Non_Grammar); return (First => Tree.Byte_Region (Next_Source_Terminal, Trailing_Non_Grammar => True).First, Last => Tree.Byte_Region (Next_Source_Terminal, Trailing_Non_Grammar => True).First - 1); end case; end case; end if; end Byte_Region; function Byte_Region (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Parents; Parse_Stream : in Stream_ID; Trailing_Non_Grammar : in Boolean := False) return WisiToken.Buffer_Region is Prev_Source_Terminal : Stream_Node_Parents := Invalid_Stream_Node_Parents; Next_Source_Terminal : Stream_Node_Parents := Invalid_Stream_Node_Parents; begin if Ref.Ref.Node = Invalid_Node_Access or else -- Empty nonterm Ref.Ref.Node.Label = Nonterm then Prev_Source_Terminal := Ref; Tree.First_Source_Terminal (Prev_Source_Terminal, Trailing_Non_Grammar); Next_Source_Terminal := Ref; Tree.Last_Source_Terminal (Next_Source_Terminal, Trailing_Non_Grammar, Parse_Stream); if Prev_Source_Terminal.Ref.Node = Invalid_Node_Access then Tree.Prev_Source_Terminal (Prev_Source_Terminal, Parse_Stream, Trailing_Non_Grammar); Tree.Next_Source_Terminal (Next_Source_Terminal, Trailing_Non_Grammar); end if; return (First => Tree.Byte_Region (Prev_Source_Terminal, Parse_Stream, Trailing_Non_Grammar).Last, Last => Tree.Byte_Region (Next_Source_Terminal, Parse_Stream, Trailing_Non_Grammar).First); else case Terminal_Label'(Ref.Ref.Node.Label) is when Source_Terminal => if Trailing_Non_Grammar and Ref.Ref.Node.Non_Grammar.Length > 0 then pragma Assert (Ref.Ref.Node.Byte_Region /= Null_Buffer_Region); return (First => Ref.Ref.Node.Byte_Region.First, Last => Ref.Ref.Node.Non_Grammar (Ref.Ref.Node.Non_Grammar.Last_Index).Byte_Region.Last); else return Ref.Ref.Node.Byte_Region; end if; when Virtual_Terminal | Virtual_Identifier => if Ref.Ref.Node.Non_Grammar.Length > 0 then return (First => Ref.Ref.Node.Non_Grammar (Ref.Ref.Node.Non_Grammar.First_Index).Byte_Region.First, Last => Ref.Ref.Node.Non_Grammar (Ref.Ref.Node.Non_Grammar.Last_Index).Byte_Region.Last); else case Ref.Ref.Node.Insert_Location is when After_Prev | Between => Prev_Source_Terminal := Ref; Tree.Prev_Source_Terminal (Prev_Source_Terminal, Parse_Stream, Trailing_Non_Grammar); return (First => Tree.Byte_Region (Prev_Source_Terminal, Parse_Stream, Trailing_Non_Grammar => True).Last, Last => Tree.Byte_Region (Prev_Source_Terminal, Parse_Stream, Trailing_Non_Grammar => True).Last - 1); when Before_Next => -- It doesn't make sense for Ref.Ref.Node.Non_Grammar.Length > 0 -- here, but we tolerate buggy language-specific code in Insert_Token -- or Delete_Token. Next_Source_Terminal := Ref; Tree.Next_Source_Terminal (Next_Source_Terminal, Trailing_Non_Grammar); return (First => Tree.Byte_Region (Next_Source_Terminal, Parse_Stream, Trailing_Non_Grammar => True).First, Last => Tree.Byte_Region (Next_Source_Terminal, Parse_Stream, Trailing_Non_Grammar => True) .First - 1); end case; end if; end case; end if; end Byte_Region; function Byte_Region (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Buffer_Region is begin if Item.Virtual then return Null_Buffer_Region; elsif Item.Element_Node = Invalid_Node_Access then return Null_Buffer_Region; else case Item.Element_Node.Label is when Source_Terminal => return Item.Element_Node.Byte_Region; when Virtual_Terminal | Virtual_Identifier => return Null_Buffer_Region; when Nonterm => declare First : constant Node_Access := First_Source_Terminal (Tree, Item.Element_Node, Trailing_Non_Grammar => False, Following => False); Last : constant Node_Access := Last_Source_Terminal (Tree, Item.Element_Node, Trailing_Non_Grammar => False); begin if First = Invalid_Node_Access then return Null_Buffer_Region; else return (First.Byte_Region.First, Last.Byte_Region.Last); end if; end; end case; end if; end Byte_Region; function Char_Region (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return Buffer_Region is Prev_Source_Terminal : Node_Access := Invalid_Node_Access; Next_Source_Terminal : Node_Access := Invalid_Node_Access; procedure Set_Prev is begin if Node.ID = Tree.Lexer.Descriptor.SOI_ID then Prev_Source_Terminal := Node; else Prev_Source_Terminal := Tree.Prev_Source_Terminal (Node, Trailing_Non_Grammar => True); end if; end Set_Prev; begin case Node.Label is when Source_Terminal => if Trailing_Non_Grammar and Node.Non_Grammar.Length > 0 then pragma Assert (Node.Char_Region /= Null_Buffer_Region); return (First => Node.Char_Region.First, Last => Node.Non_Grammar (Node.Non_Grammar.Last_Index).Char_Region.Last); else return Node.Char_Region; end if; when Virtual_Terminal | Virtual_Identifier => if Node.Non_Grammar.Length > 0 then return (First => Node.Non_Grammar (Node.Non_Grammar.First_Index).Char_Region.First, Last => Node.Non_Grammar (Node.Non_Grammar.Last_Index).Char_Region.Last); else case Node.Insert_Location is when After_Prev | Between => if Tree.Parents_Set then Set_Prev; if Prev_Source_Terminal = Invalid_Node_Access then -- Node is in an all virtual parse stream element. return Null_Buffer_Region; else return (First => Tree.Char_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last, Last => Tree.Char_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last - 1); end if; else return Null_Buffer_Region; end if; when Before_Next => if Tree.Parents_Set then if Node.ID = Tree.Lexer.Descriptor.EOI_ID then Next_Source_Terminal := Node; else Next_Source_Terminal := Tree.Next_Source_Terminal (Node, Trailing_Non_Grammar => True); end if; if Next_Source_Terminal = Invalid_Node_Access then -- Node is in an all virtual parse stream element. return Null_Buffer_Region; else return (First => Tree.Char_Region (Next_Source_Terminal, Trailing_Non_Grammar => True).First, Last => Tree.Char_Region (Next_Source_Terminal, Trailing_Non_Grammar => True).First - 1); end if; else return Null_Buffer_Region; end if; end case; end if; when Nonterm => if Node.Child_Count = 0 then if Tree.Parents_Set then Set_Prev; if Prev_Source_Terminal = Invalid_Node_Access then -- Node is the root of an empty tree or parse stream element. return Null_Buffer_Region; else declare First : constant Buffer_Pos := Tree.Char_Region (Prev_Source_Terminal, Trailing_Non_Grammar => True).Last + 1; begin return (First, First - 1); end; end if; else return Null_Buffer_Region; end if; else Prev_Source_Terminal := First_Source_Terminal (Tree, Node, Trailing_Non_Grammar => False, Following => False); Next_Source_Terminal := Last_Source_Terminal (Tree, Node, Trailing_Non_Grammar); end if; if Prev_Source_Terminal = Invalid_Node_Access then -- Node.Child_Count > 0, but Node contains no source_terminals; it is -- all virtual. Find best estimate for First. if Tree.Parents_Set then Set_Prev; declare First : constant Buffer_Pos := Tree.Char_Region (Prev_Source_Terminal, Trailing_Non_Grammar).First + 1; begin return (First, First - 1); end; else return Null_Buffer_Region; end if; end if; pragma Assert (Prev_Source_Terminal /= Invalid_Node_Access and Next_Source_Terminal /= Invalid_Node_Access); return (First => Tree.Char_Region (Prev_Source_Terminal, Trailing_Non_Grammar).First, Last => Tree.Char_Region (Next_Source_Terminal, Trailing_Non_Grammar).Last); end case; end Char_Region; function Check_Multi_Line (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Line : in Line_Number_Type; Char_Pos : in out Buffer_Pos; Start_Line : in Line_Number_Type) return Boolean with Pre => Node.Label in Terminal_Label and Tree.Lexer.Can_Contain_New_Line (Node.ID) -- Return True if Node contains the new_line that ends Line - 1; set -- Char_Pos to the character position following the New_Line. -- Start_Line must be the line number at the first char of Node. is Temp : Base_Buffer_Pos := Node.Byte_Region.First; begin for I in Start_Line + 1 .. Line loop Temp := Tree.Lexer.Find_New_Line ((Temp, Node.Byte_Region.Last)); if Temp = Invalid_Buffer_Pos then return False; end if; Temp := @ + 1; end loop; Char_Pos := Temp; return True; end Check_Multi_Line; function Check_Non_Grammar (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Line : in Line_Number_Type; Char_Pos : in out Buffer_Pos) return Boolean with Pre => Node.Label in Terminal_Label -- Return True if Node contains non_grammar that ends Line - 1; set -- Char_Pos to the character position following the New_Line. is begin for Token of Node.Non_Grammar loop if Token.Line_Region.First <= Line - 1 and Token.Line_Region.Last >= Line then declare Temp : constant Base_Buffer_Pos := Tree.Lexer.Line_Begin_Char_Pos (Token, Line); begin if Temp /= Invalid_Buffer_Pos then Char_Pos := Temp; return True; end if; end; end if; end loop; return False; end Check_Non_Grammar; function Child (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Child_Index : in Positive_Index_Type) return Node_Access is begin if Child_Index in Node.Children'Range then return Node.Children (Child_Index); else return Invalid_Node_Access; end if; end Child; function Child_Count (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return SAL.Base_Peek_Type is begin return Node.Child_Count; end Child_Count; function Child_Index (Parent : in Node; Child : in Valid_Node_Access) return SAL.Peek_Type is begin for I in Parent.Children'Range loop if Parent.Children (I) = Child then return I; end if; end loop; raise SAL.Programmer_Error; end Child_Index; function Child_Index (Tree : in Syntax_Trees.Tree; Parent : in Valid_Node_Access; Child : in Valid_Node_Access) return SAL.Peek_Type is pragma Unreferenced (Tree); begin return Child_Index (Parent.all, Child); end Child_Index; function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access_Array is begin return Node.Children; end Children; function Children_Recover_Tokens (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Recover_Token_Array is begin -- WORKAROUND: GNAT Community 2020 doesn't support 'of' here, and it -- hangs if there are any errors in the statement with 'in'. -- return (for I in Node.Children'Range => Tree.Get_Recover_Token (Node.Children (I))); return Result : Recover_Token_Array (1 .. Node.Child_Count) do for I in Node.Children'Range loop Result (I) := Tree.Get_Recover_Token (Node.Children (I)); end loop; end return; end Children_Recover_Tokens; function Children_Recover_Tokens (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Recover_Token_Array is Node : constant Node_Access := Stream_Element_Lists.Element (Element.Cur).Node; begin -- WORKAROUND: GNAT Community 2020 doesn't support 'of' here, and it -- hangs if there are any errors in the statement with 'in'. -- return (for I in Node.Children'Range => Tree.Get_Recover_Token (Node.Children (I))); return Result : Recover_Token_Array (1 .. Node.Child_Count) do for I in Node.Children'Range loop Result (I) := Tree.Get_Recover_Token (Node.Children (I)); end loop; end return; end Children_Recover_Tokens; procedure Clear (Tree : in out Syntax_Trees.Tree; Free_Memory : in Boolean := False) is begin for N of Tree.Nodes loop Free (N.Augmented); Free (N.Error_List); Free (N); end loop; Tree.Nodes.Clear (Free_Memory); -- Clear saved element list cursors in parse streams before freeing -- the element lists, so they don't try to decrement reference counts -- in deallocated elements. We can't rely on cursor Finalize for -- this; that's done in arbitrary order. Loop in reverse order so -- shared stream is last; other streams have links to it. for Stream of reverse Tree.Streams loop Stream.Stack_Top := Stream_Element_Lists.No_Element; Stream.Shared_Link := Stream_Element_Lists.No_Element; if Debug_Mode then Stream.Elements.Check_Ref_Counts; end if; end loop; Tree.Streams.Clear; Tree.Root := Invalid_Node_Access; Tree.SOI := Invalid_Node_Access; Tree.EOI := Invalid_Node_Access; Tree.Next_Stream_Label := Shared_Stream_Label + 1; Tree.Next_Terminal_Node_Index := 1; Tree.Traversing := False; Tree.Parents_Set := False; end Clear; function Cleared (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Streams.Length = 0 and Tree.Nodes.Length = 0; end Cleared; procedure Clear_Augmented (Tree : in Syntax_Trees.Tree) is begin for Node of Tree.Nodes loop Free (Node.Augmented); if Node.Label = Source_Terminal then for N of Node.Following_Deleted loop Free (N.Augmented); end loop; end if; end loop; end Clear_Augmented; procedure Clear_Parent (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Clear_Children : in Boolean) is begin if Node.Parent /= Invalid_Node_Access and Clear_Children then Node.Parent.Children (Child_Index (Node.Parent.all, Node)) := null; if Node.Parent = Tree.Root then Tree.Root := Node; end if; end if; Node.Parent := Invalid_Node_Access; end Clear_Parent; procedure Clear_Parse_Streams (Tree : in out Syntax_Trees.Tree) is use Parse_Stream_Lists; Cur : Cursor := Tree.Streams.First; begin pragma Assert (Cur = Tree.Shared_Stream.Cur); Next (Cur); -- first parse stream loop exit when Cur = No_Element; declare Stream : Parse_Stream renames Tree.Streams (Cur); To_Delete : Cursor := Cur; begin -- Clear saved element list cursors in parse streams before freeing -- the element lists, so they don't try to decrement reference counts -- in deallocated elements. Stream.Stack_Top := Stream_Element_Lists.No_Element; Stream.Shared_Link := Stream_Element_Lists.No_Element; Stream.Elements.Finalize; Next (Cur); Tree.Streams.Delete (To_Delete); end; end loop; Tree.Next_Stream_Label := Shared_Stream_Label + 1; end Clear_Parse_Streams; function Column (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Ada.Text_IO.Count is Char_Region : constant Buffer_Region := Tree.Char_Region (Node, Trailing_Non_Grammar => False); begin if Char_Region = Null_Buffer_Region then return 0; else declare Begin_Char_Pos : constant Buffer_Pos := Line_Begin_Char_Pos (Tree, Line_Region (Tree, Node, Trailing_Non_Grammar => True).First); begin return (if Begin_Char_Pos = Invalid_Buffer_Pos then 0 else Ada.Text_IO.Count (Char_Region.First - Begin_Char_Pos)); end; end if; end Column; function Column (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Stream : in Stream_ID) return Ada.Text_IO.Count is Char_Region : constant Buffer_Region := Tree.Char_Region (Node, Trailing_Non_Grammar => False); begin if Char_Region.First = Invalid_Buffer_Pos then return 0; else declare Begin_Char_Pos : constant Buffer_Pos := Line_Begin_Char_Pos (Tree, Tree.Line_Region (Node, Trailing_Non_Grammar => True).First, Stream); begin return (if Begin_Char_Pos = Invalid_Buffer_Pos then 0 else Ada.Text_IO.Count (Char_Region.First - Begin_Char_Pos)); end; end if; end Column; function Contains (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Token : in Stream_Index) return Boolean is begin return (Tree.Is_Valid (Stream) and Token /= Invalid_Stream_Index) and then Tree.Streams (Stream.Cur).Elements.Contains (Token.Cur); end Contains; function Contains_Error (Tree : in Syntax_Trees.Tree; Error_Node : in Valid_Node_Access; Data : in Error_Data'Class) return Boolean is begin if Error_Node.Error_List = null then return False; else return (for some Err of Error_Node.Error_List.all => Dispatch_Equal (Data, Err)); end if; end Contains_Error; function Contains_Virtual_Terminal (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Boolean is pragma Unreferenced (Tree); begin return (if Item.Virtual then Item.Contains_Virtual_Terminal else (case Item.Element_Node.Label is when Source_Terminal => False, when Virtual_Terminal | Virtual_Identifier => True, when Nonterm => Item.Element_Node.Virtual)); end Contains_Virtual_Terminal; function Contains_Virtual_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return (case Node.Label is when Source_Terminal => False, when Virtual_Terminal | Virtual_Identifier => True, when Nonterm => Node.Virtual); end Contains_Virtual_Terminal; function Copied_Node (Node : in Valid_Node_Access) return Node_Access is begin return Node.Copied_Node; end Copied_Node; procedure Copy_Ancestors (Tree : in out Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; New_Node : in Valid_Node_Access; User_Data : in User_Data_Access_Constant) -- Replace Ref.Node with New_Node, copying all parents thru -- Ref.Element, updating Ref.Element and Ref.Parents to match. is Temp : Valid_Node_Access := New_Node; Old_Child : Valid_Node_Access := Ref.Ref.Node; New_Stack : Node_Stacks.Stack; begin Ref.Ref.Node := New_Node; if Ref.Parents.Depth = 0 then -- ada_mode-recover_debbugs_36548.adb return; end if; loop declare Old_Parent : constant Valid_Node_Access := Ref.Parents.Pop; New_Child : constant Valid_Node_Access := Temp; Child_Index : constant SAL.Peek_Type := Syntax_Trees.Child_Index (Parent => Old_Parent.all, Child => Old_Child); begin Temp := Copy_Node (Tree, Old_Parent, Parent => (if Tree.Parents_Set then Old_Parent.Parent else Invalid_Node_Access), User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => True); Temp.Children (Child_Index) := New_Child; Old_Child.Parent := Invalid_Node_Access; if Tree.Parents_Set then New_Child.Parent := Temp; end if; New_Stack.Push (Temp); if Ref.Parents.Depth = 0 then if Old_Parent = Tree.Root then Tree.Root := Temp; end if; exit; end if; Old_Child := Old_Parent; end; end loop; Replace_Node (Ref.Ref.Element, New_Stack.Peek); loop Ref.Parents.Push (New_Stack.Pop); exit when New_Stack.Depth = 0; end loop; end Copy_Ancestors; function Copy_Augmented (User_Data : in User_Data_Type; Augmented : in not null Augmented_Class_Access) return Augmented_Class_Access is begin raise SAL.Programmer_Error; return null; end Copy_Augmented; function Copy_Node (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Parent : in Node_Access; User_Data : in User_Data_Access_Constant; Copy_Children : in Boolean; Copy_Following_Deleted : in Boolean; New_Error_List : in Error_List_Access := null; Set_Error_List : in Boolean := False; Set_Copied_Node : in Boolean := False) return Valid_Node_Access is use all type Error_Data_Lists.List; New_Node : Node_Access; Actual_Error_List : constant Error_List_Access := (if Set_Error_List then New_Error_List else (if Node.Error_List = null then null else new Error_Data_Lists.List'(Node.Error_List.all))); begin case Node.Label is when Source_Terminal => New_Node := new Syntax_Trees.Node' (Label => Source_Terminal, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Node.ID, Node_Index => Tree.Next_Terminal_Node_Index, Byte_Region => Node.Byte_Region, Char_Region => Node.Char_Region, New_Line_Count => Node.New_Line_Count, Parent => Parent, Augmented => (if Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Node.Augmented)), Error_List => Actual_Error_List, Non_Grammar => Node.Non_Grammar, Sequential_Index => Node.Sequential_Index, Following_Deleted => Valid_Node_Access_Lists.Empty_List); if Copy_Following_Deleted then if Copy_Children then for Deleted_Node of Node.Following_Deleted loop New_Node.Following_Deleted.Append (Copy_Node (Tree, Deleted_Node, New_Node, User_Data, Copy_Children => False, Copy_Following_Deleted => False)); end loop; else New_Node.Following_Deleted := Node.Following_Deleted; end if; end if; Tree.Next_Terminal_Node_Index := @ + 1; when Virtual_Terminal => New_Node := new Syntax_Trees.Node' (Label => Virtual_Terminal, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Node.ID, Node_Index => -(Tree.Nodes.Last_Index + 1), Parent => Parent, Augmented => (if Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Node.Augmented)), Error_List => Actual_Error_List, Non_Grammar => Node.Non_Grammar, Sequential_Index => Node.Sequential_Index, Insert_Location => Node.Insert_Location); when Virtual_Identifier => New_Node := new Syntax_Trees.Node' (Label => Virtual_Identifier, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Node.ID, Node_Index => -(Tree.Nodes.Last_Index + 1), Parent => Parent, Augmented => (if Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Node.Augmented)), Error_List => Actual_Error_List, Non_Grammar => Node.Non_Grammar, Sequential_Index => Node.Sequential_Index, Identifier => Node.Identifier, Insert_Location => Node.Insert_Location); when Nonterm => -- Copy children first to preserve Node_Index order = parse order in a batch parsed tree. declare New_Children : Node_Access_Array (Node.Children'Range); begin if Copy_Children then for I in New_Children'Range loop New_Children (I) := Copy_Node (Tree, Node.Children (I), Invalid_Node_Access, User_Data, Copy_Children, Copy_Following_Deleted => True); end loop; else New_Children := Node.Children; end if; New_Node := new Syntax_Trees.Node' (Label => Nonterm, Copied_Node => Invalid_Node_Access, Child_Count => Node.Child_Count, ID => Node.ID, Node_Index => -(Tree.Nodes.Last_Index + 1), Parent => Parent, Augmented => (if Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Node.Augmented)), Error_List => Actual_Error_List, Virtual => Node.Virtual, Recover_Conflict => Node.Recover_Conflict, RHS_Index => Node.RHS_Index, Name_Offset => Node.Name_Offset, Name_Length => Node.Name_Length, Children => New_Children); if Copy_Children then pragma Assert (Tree.Parents_Set); for Child of New_Node.Children loop Child.Parent := New_Node; end loop; else if Tree.Parents_Set then Set_Children (Tree, New_Node, Node.Children); else New_Node.Children := Node.Children; end if; end if; end; end case; Tree.Nodes.Append (New_Node); if Set_Copied_Node then Node.Copied_Node := New_Node; end if; return New_Node; end Copy_Node; function Copy_Subtree (Tree : in out Syntax_Trees.Tree; Root : in Node_Access; User_Data : in User_Data_Access_Constant) return Node_Access is begin if Root = Invalid_Node_Access then return Invalid_Node_Access; else return Copy_Node (Tree, Root, Invalid_Node_Access, User_Data, Copy_Children => True, Copy_Following_Deleted => True); end if; end Copy_Subtree; procedure Copy_Tree (Source : in Tree; Destination : out Tree; User_Data : in User_Data_Access_Constant) is Next_Terminal_Node_Index : Node_Index := 0; function Copy_Node (Source_Node : in Valid_Node_Access; Dest_Parent : in Node_Access) return Valid_Node_Access is New_Dest_Node : Node_Access; function Copy_Errors return Error_List_Access is (if Source_Node.Error_List = null then null else new Error_Data_Lists.List'(Source_Node.Error_List.all)); begin case Source_Node.Label is when Source_Terminal => if Next_Terminal_Node_Index = 0 and Source_Node.ID /= Source.Lexer.Descriptor.SOI_ID then -- SOI is normally the first terminal seen. Next_Terminal_Node_Index := @ + 1; end if; New_Dest_Node := new Syntax_Trees.Node' (Label => Source_Terminal, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Source_Node.ID, Node_Index => Next_Terminal_Node_Index, Parent => Dest_Parent, Augmented => (if Source_Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Source_Node.Augmented)), Error_List => Copy_Errors, Byte_Region => Source_Node.Byte_Region, Char_Region => Source_Node.Char_Region, New_Line_Count => Source_Node.New_Line_Count, Non_Grammar => Source_Node.Non_Grammar, Sequential_Index => Source_Node.Sequential_Index, Following_Deleted => Valid_Node_Access_Lists.Empty_List); Next_Terminal_Node_Index := @ + 1; if New_Dest_Node.ID = Source.Lexer.Descriptor.SOI_ID then Destination.SOI := New_Dest_Node; elsif New_Dest_Node.ID = Source.Lexer.Descriptor.EOI_ID then Destination.EOI := New_Dest_Node; end if; for Deleted of Source_Node.Following_Deleted loop New_Dest_Node.Following_Deleted.Append (Copy_Node (Deleted, New_Dest_Node)); end loop; when Virtual_Terminal => New_Dest_Node := new Syntax_Trees.Node' (Label => Virtual_Terminal, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Source_Node.ID, Node_Index => -(Destination.Nodes.Last_Index + 1), Parent => Dest_Parent, Augmented => (if Source_Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Source_Node.Augmented)), Error_List => Copy_Errors, Non_Grammar => Source_Node.Non_Grammar, Sequential_Index => Source_Node.Sequential_Index, Insert_Location => Source_Node.Insert_Location); when Virtual_Identifier => New_Dest_Node := new Syntax_Trees.Node' (Label => Virtual_Identifier, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Source_Node.ID, Node_Index => -(Destination.Nodes.Last_Index + 1), Parent => Dest_Parent, Augmented => (if Source_Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Source_Node.Augmented)), Error_List => Copy_Errors, Non_Grammar => Source_Node.Non_Grammar, Sequential_Index => Source_Node.Sequential_Index, Identifier => Source_Node.Identifier, Insert_Location => Source_Node.Insert_Location); when Nonterm => -- Copy children first to preserve Node_Index order = parse order in a batch parsed tree. declare New_Children : Node_Access_Array (Source_Node.Children'Range); begin for I in New_Children'Range loop New_Children (I) := Copy_Node (Source_Node.Children (I), Dummy_Node); end loop; New_Dest_Node := new Syntax_Trees.Node' (Label => Nonterm, Copied_Node => Invalid_Node_Access, Child_Count => Source_Node.Child_Count, ID => Source_Node.ID, Node_Index => -(Destination.Nodes.Last_Index + 1), Parent => Dest_Parent, Augmented => (if Source_Node.Augmented = null or User_Data = null then null else Copy_Augmented (User_Data.all, Source_Node.Augmented)), Error_List => Copy_Errors, Virtual => Source_Node.Virtual, Recover_Conflict => Source_Node.Recover_Conflict, RHS_Index => Source_Node.RHS_Index, Name_Offset => Source_Node.Name_Offset, Name_Length => Source_Node.Name_Length, Children => New_Children); for Child of New_Dest_Node.Children loop Child.Parent := New_Dest_Node; end loop; end; end case; Source_Node.Copied_Node := New_Dest_Node; Destination.Nodes.Append (New_Dest_Node); return New_Dest_Node; end Copy_Node; begin Destination.Clear (Free_Memory => False); Destination.Lexer := Source.Lexer; Destination.Next_Terminal_Node_Index := Source.Next_Terminal_Node_Index; Destination.Traversing := False; Destination.Parents_Set := True; Destination.Root := Copy_Node (Source.Root, Invalid_Node_Access); for Err in Destination.Error_Iterate loop Error_Data_Lists.Variable_Ref (Err.Error).Adjust_Copy; end loop; for Node of Source.Nodes loop Node.Copied_Node := Invalid_Node_Access; end loop; end Copy_Tree; function Correct_Stream_Node (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Boolean is begin return Ref = Invalid_Stream_Node_Ref or else (Ref.Element /= Invalid_Stream_Index and then (Ref.Node = Invalid_Node_Access or else (not Tree.Parents_Set or else Tree.Subtree_Root (Ref.Node) = Tree.Get_Node (Ref.Stream, Ref.Element)))); end Correct_Stream_Node; function Count_IDs (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID) return SAL.Base_Peek_Type is begin return Result : SAL.Base_Peek_Type := 0 do if Node.ID = ID then Result := 1; end if; case Node.Label is when Nonterm => for I of Node.Children loop -- We don't check for deleted child here; encountering one indicates -- an error in the user algorithm. Result := @ + Count_IDs (Tree, I, ID); end loop; when others => null; end case; end return; end Count_IDs; function Count_Terminals (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Natural -- Count_Terminals must return Integer for Get_Terminals, -- Positive_Index_Type for Get_Terminal_IDs. is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => return 1; when Nonterm => return Result : Natural := 0 do for C of Node.Children loop -- This can be called to build a debugging image while editing the tree if C /= null then Result := Result + Count_Terminals (Tree, C); end if; end loop; end return; end case; end Count_Terminals; function Current_Error_Ref_No_Search (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Terminal_Predicate : in Error_Predicate; Nonterm_Predicate : in Error_Predicate) return Stream_Error_Ref is -- IMPROVEME: move Parse_Error etc into syntax_trees so we don't have -- to pass predicates here. use Stream_Element_Lists; use all type Error_Data_Lists.Cursor; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin return Result : Stream_Error_Ref do -- First look in Parse_Stream input. Result.Ref.Ref.Stream := Stream; Result.Ref.Ref.Element := (Cur => Next (Parse_Stream.Stack_Top)); if Result.Ref.Ref.Element.Cur /= No_Element then Result.Ref.Ref.Node := Element (Result.Ref.Ref.Element.Cur).Node; if Result.Ref.Ref.Node.Label = Nonterm then Tree.First_Terminal (Result.Ref, Following => False); end if; Result.Error := Find_Match (Result.Ref.Ref.Node.Error_List, Terminal_Predicate); end if; if Result.Error = Error_Data_Lists.No_Element then -- Try Shared_Stream Result.Ref.Ref := (Stream => Tree.Shared_Stream, Element => (Cur => Parse_Stream.Shared_Link), Node => Element (Parse_Stream.Shared_Link).Node); if Result.Ref.Ref.Node.Label = Nonterm then Tree.First_Terminal (Result.Ref, Following => False); end if; Result.Error := Find_Match (Result.Ref.Ref.Node.Error_List, Terminal_Predicate); end if; if Result.Error = Error_Data_Lists.No_Element then -- Must be an In_Parse_Error on the last reduce. Result.Ref.Ref := (Stream, (Cur => Parse_Stream.Stack_Top), Element (Parse_Stream.Stack_Top).Node); if Result.Ref.Ref.Node /= Syntax_Trees.Invalid_Node_Access then Result.Error := Find_Match (Result.Ref.Ref.Node.Error_List, Nonterm_Predicate); end if; end if; if Result.Error = Error_Data_Lists.No_Element then raise SAL.Programmer_Error with "current_error_ref: no matching error found"; end if; end return; end Current_Error_Ref_No_Search; function Current_Error_Ref (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Terminal_Predicate : in Error_Predicate; Nonterm_Predicate : in Error_Predicate; Error_Node_Features : in Syntax_Trees.Error_Node_Features := (others => <>)) return Stream_Error_Ref is -- IMPROVEME: move Parse_Error etc into syntax_trees so we don't have -- to pass predicates here. use Stream_Element_Lists; use all type Error_Data_Lists.Cursor; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Last_Terminal : Stream_Node_Parents; First_Terminal : Stream_Node_Parents; -- Of the current search node Target_Seq_Index : constant Base_Sequential_Index := (if Error_Node_Features.Deleted then Error_Node_Features.Prev_Term_Seq_Index else Error_Node_Features.Seq_Index); Last_Step_Towards_EOI : Boolean; procedure Step (Ref : in out Stream_Node_Parents; Towards_EOI : in Boolean) -- Step Ref.Ref.Element in direction given by Towards_EOI, skipping empty nonterms. is begin Last_Step_Towards_EOI := Towards_EOI; loop if Towards_EOI then Next (Ref.Ref.Element.Cur); if Ref.Ref.Element.Cur = Stream_Element_Lists.No_Element then if Ref.Ref.Stream /= Tree.Shared_Stream then -- Try Shared_Stream Ref.Ref.Stream := Tree.Shared_Stream; Ref.Ref.Element := (Cur => Parse_Stream.Shared_Link); else raise SAL.Programmer_Error with "current_error_ref: no matching error found"; end if; end if; else Previous (Ref.Ref.Element.Cur); if Ref.Ref.Element.Cur = Stream_Element_Lists.No_Element then raise SAL.Programmer_Error with "current_error_ref: no matching error found"; end if; end if; Ref.Ref.Node := Element (Ref.Ref.Element.Cur).Node; Ref.Parents := Node_Stacks.Empty_Stack; Last_Terminal := Ref; Tree.Last_Sequential_Terminal (Last_Terminal, Stream, Preceding => False); exit when Last_Terminal.Ref.Node /= Invalid_Node_Access; end loop; First_Terminal := Ref; Tree.First_Sequential_Terminal (First_Terminal, Following => False); end Step; function Handle_Deleted (Result : in out Stream_Error_Ref) return Boolean is begin if Result.Ref.Ref.Node.Label = Source_Terminal and then Result.Ref.Ref.Node.Sequential_Index = Error_Node_Features.Prev_Term_Seq_Index then for Cur in Result.Ref.Ref.Node.Following_Deleted.Iterate loop declare Node : Valid_Node_Access renames Result.Ref.Ref.Node.Following_Deleted (Cur); begin if Node.Sequential_Index = Error_Node_Features.Seq_Index then Result.Error := Find_Match (Node.Error_List, Terminal_Predicate); Result.Deleted := Cur; return True; end if; end; end loop; return True; else return False; end if; end Handle_Deleted; procedure Set_First_Last (Ref : in Stream_Node_Parents) -- Set First_, Last_Terminal; null if Ref.Ref.Node is an empty nonterm. is begin Last_Terminal := Ref; Tree.Last_Sequential_Terminal (Last_Terminal, Stream, Preceding => False); First_Terminal := Ref; Tree.First_Sequential_Terminal (First_Terminal, Following => False); end Set_First_Last; function First_Child (Ref : in out Stream_Node_Parents) return Boolean with Pre => Ref.Ref.Node.Label = Nonterm -- If Ref.Ref.Node is an empty nonterm, return False. Otherwise, -- update Ref first child of Ref.Ref.Node, return True. is begin if Ref.Ref.Node.Child_Count = 0 then return False; end if; Ref.Parents.Push (Ref.Ref.Node); Ref.Ref.Node := Ref.Ref.Node.Children (1); return True; end First_Child; function Next_Sibling (Ref : in out Stream_Node_Parents) return Boolean -- Step Ref to next sibling of Ref.Ref.Node. If Ref.Ref.Node is last -- child of parent, leave Ref at next sibling of parent. Do not step -- Ref.Ref.Element. Return True if there is such a sibling, False -- when not (ie ref.parents is or becomes empty). is begin loop if Ref.Parents.Is_Empty then return False; end if; declare Child_Index : constant SAL.Peek_Type := Syntax_Trees.Child_Index (Parent => Ref.Parents.Peek.all, Child => Ref.Ref.Node); begin if Child_Index = Ref.Parents.Peek.Child_Count then Ref.Ref.Node := Ref.Parents.Pop; else Ref.Ref.Node := Ref.Parents.Peek.Children (Child_Index + 1); return True; end if; end; end loop; end Next_Sibling; begin if Error_Node_Features.Seq_Index = Invalid_Sequential_Index then return Current_Error_Ref_No_Search (Tree, Stream, Terminal_Predicate, Nonterm_Predicate); end if; return Result : Stream_Error_Ref do -- In the worst case, the error node can be anywhere in the stack or -- stream input. In the stack, it can be on an arbitrary descendent -- of the element root. In the stream input, it can be on the first -- terminal of a nonterm. -- -- So we assume the worst case, and use first/last terminal -- sequential_index to guide the search when descending a subtree. Result.Ref.Ref := (Stream, (Cur => Parse_Stream.Stack_Top), Element (Parse_Stream.Stack_Top).Node); Last_Terminal := Result.Ref; Tree.Last_Sequential_Terminal (Last_Terminal, Stream, Preceding => False); if Last_Terminal.Ref.Node = Invalid_Node_Access then Step (Result.Ref, Towards_EOI => False); else First_Terminal := Result.Ref; Tree.First_Sequential_Terminal (First_Terminal, Following => False); end if; Search_Stream : loop if Target_Seq_Index < First_Terminal.Ref.Node.Sequential_Index then Step (Result.Ref, Towards_EOI => False); elsif Target_Seq_Index > Last_Terminal.Ref.Node.Sequential_Index then Step (Result.Ref, Towards_EOI => True); else Search_Subtree : loop case Error_Node_Features.Label is when Terminal_Label => exit Search_Stream when Error_Node_Features.Deleted and then Handle_Deleted (Result); if Result.Ref.Ref.Node.Label = Error_Node_Features.Label and then Result.Ref.Ref.Node.Sequential_Index = Target_Seq_Index then Result.Error := Find_Match (Result.Ref.Ref.Node.Error_List, Terminal_Predicate); exit Search_Stream; end if; when Nonterm => if Result.Ref.Ref.Node.Label = Error_Node_Features.Label and then First_Terminal.Ref.Node.Sequential_Index = Target_Seq_Index then Result.Error := Find_Match (Result.Ref.Ref.Node.Error_List, Nonterm_Predicate); exit Search_Stream when Result.Error /= Error_Data_Lists.No_Element; end if; end case; -- Continue searching case Result.Ref.Ref.Node.Label is when Terminal_Label => exit Search_Subtree when not Next_Sibling (Result.Ref); when Nonterm => if First_Child (Result.Ref) then Find_Child : loop Set_First_Last (Result.Ref); if Last_Terminal.Ref.Node /= Invalid_Node_Access and then Target_Seq_Index <= Last_Terminal.Ref.Node.Sequential_Index then -- Search this child exit Find_Child; else exit Search_Subtree when not Next_Sibling (Result.Ref); end if; end loop Find_Child; else exit Search_Subtree when not Next_Sibling (Result.Ref); end if; end case; end loop Search_Subtree; Step (Result.Ref, Last_Step_Towards_EOI); end if; end loop Search_Stream; if Result.Error = Error_Data_Lists.No_Element then raise SAL.Programmer_Error with "current_error_ref: no matching error found"; end if; end return; end Current_Error_Ref; function Current_Token (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Rooted_Ref is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin if Parse_Stream.Stack_Top = Parse_Stream.Elements.Last then return (Stream => Tree.Shared_Stream, Element => (Cur => Parse_Stream.Shared_Link), Node => Stream_Element_Lists.Element (Parse_Stream.Shared_Link).Node); else declare El : constant Stream_Element_Lists.Cursor := Stream_Element_Lists.Next (Parse_Stream.Stack_Top); begin return (Stream => Stream, Element => (Cur => El), Node => Stream_Element_Lists.Element (El).Node); end; end if; end Current_Token; procedure Delete_Current_Token (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID) is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin if Parse_Stream.Stack_Top = Parse_Stream.Elements.Last then -- Input is Shared_Link Stream_Element_Lists.Next (Parse_Stream.Shared_Link); else -- Input is Stream input. declare use Stream_Element_Lists; To_Delete : Cursor := Next (Parse_Stream.Stack_Top); begin -- Any Non_Grammar on To_Delete should be moved in Delete_Token, called -- by Execute_Actions after parse is complete. Parse_Stream.Elements.Delete (To_Delete); end; end if; end Delete_Current_Token; procedure Delete_Error (Tree : in out Syntax_Trees.Tree; Error : in out Error_Ref) is Error_Node : constant Valid_Node_Access := (if Error.Deleted = Valid_Node_Access_Lists.No_Element then Error.Node else Error.Node.Following_Deleted (Error.Deleted)); To_Delete : Error_Data_Lists.Cursor := Error.Error; begin Tree.Next_Error (Error); Error_Node.Error_List.Delete (To_Delete); if Error_Node.Error_List.Length = 0 then Free (Error_Node.Error_List); end if; end Delete_Error; procedure Delete_Error (Tree : in out Syntax_Trees.Tree; Error : in out Stream_Error_Ref) is Error_Node : constant Valid_Node_Access := (if Error.Deleted = Valid_Node_Access_Lists.No_Element then Error.Ref.Ref.Node else Error.Ref.Ref.Node.Following_Deleted (Error.Deleted)); To_Delete : Error_Data_Lists.Cursor := Error.Error; begin Tree.Next_Error (Error); Error_Node.Error_List.Delete (To_Delete); if Error_Node.Error_List.Length = 0 then Free (Error_Node.Error_List); end if; end Delete_Error; procedure Delete_Errors_In_Input (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Predicate : in Error_Predicate; User_Data : in User_Data_Access_Constant) is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Error_Ref : Stream_Node_Parents := Tree.To_Stream_Node_Parents (if Parse_Stream.Stack_Top = Parse_Stream.Elements.Last then (Stream => Tree.Shared_Stream, Element => (Cur => Parse_Stream.Shared_Link), Node => Element (Parse_Stream.Shared_Link).Node) else (Stream => Stream, Element => (Cur => Next (Parse_Stream.Stack_Top)), Node => Element (Next (Parse_Stream.Stack_Top)).Node)); procedure Delete_Errors -- Delete errors matching Predicate from Error_Ref.Ref.Node is function Edit_Error_List return Error_List_Access is begin return Result : Error_List_Access := new Error_Data_Lists.List'(Error_Ref.Ref.Node.Error_List.all) do declare use Error_Data_Lists; Cur : Error_Data_Lists.Cursor := Result.First; To_Delete : Error_Data_Lists.Cursor; begin loop exit when Cur = Error_Data_Lists.No_Element; if Predicate (Cur) then To_Delete := Cur; Next (Cur); Result.Delete (To_Delete); else Next (Cur); end if; end loop; end; if Result.Length = 0 then Free (Result); end if; end return; end Edit_Error_List; begin if Error_Ref.Ref.Node.Error_List /= null and then Error_Ref.Ref.Node.Error_List.Length > 0 then declare New_Node : constant Valid_Node_Access := Copy_Node (Tree, Error_Ref.Ref.Node, Parent => (if Tree.Parents_Set then Error_Ref.Ref.Node.Parent else Invalid_Node_Access), User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => True, New_Error_List => Edit_Error_List, Set_Error_List => True); begin Move_Element (Tree, Stream, Error_Ref, New_Node, User_Data); end; end if; case Error_Ref.Ref.Node.Label is when Terminal_Label => null; when Nonterm => declare Children : constant Node_Access_Array := Error_Ref.Ref.Node.Children; begin for Child of Children loop Error_Ref.Parents.Push (Error_Ref.Ref.Node); Error_Ref.Ref.Node := Child; Delete_Errors; end loop; end; end case; if Error_Ref.Parents.Depth > 0 then Error_Ref.Ref.Node := Error_Ref.Parents.Pop; end if; end Delete_Errors; begin -- IMPROVEME incremental: This algorithm is not incremental, and a -- waste of time on almost all nonterms; cache Has_Errors Boolean in -- each nonterm. Delete_Errors; end Delete_Errors_In_Input; procedure Delete_Stream (Tree : in out Syntax_Trees.Tree; Stream : in out Stream_ID) is use Parse_Stream_Lists; begin declare Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin Parse_Stream.Stack_Top := Stream_Element_Lists.No_Element; Parse_Stream.Shared_Link := Stream_Element_Lists.No_Element; end; Tree.Streams.Delete (Stream.Cur); end Delete_Stream; procedure Delete_Subtree (Tree : in out Syntax_Trees.Tree; Root : in out Node_Access) is procedure Delete_Node (Tree : in out Syntax_Trees.Tree; Node : in out Node_Access) is begin Free (Node.Augmented); Free (Node.Error_List); case Node.Label is when Source_Terminal => Node.Following_Deleted.Clear; when Virtual_Terminal | Virtual_Identifier => null; when Nonterm => for I in Node.Children'Range loop Delete_Node (Tree, Node.Children (I)); end loop; end case; Free (Node); end Delete_Node; begin if Root = Invalid_Node_Access then null; else Delete_Node (Tree, Root); end if; end Delete_Subtree; function Editable (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Parents_Set and Tree.Streams.Length = 0 and Tree.Shared_Stream.Cur = Parse_Stream_Lists.No_Element; end Editable; function Element_ID (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Token_ID is pragma Unreferenced (Tree); begin return (if Item.Virtual then Item.ID else Item.Element_Node.ID); end Element_ID; function Element_Is_Terminal (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Boolean is begin if Item.Virtual then return Is_Terminal (Item.ID, Tree.Lexer.Descriptor.all); else return Tree.Label (Item.Element_Node) in Terminal_Label; end if; end Element_Is_Terminal; function Empty_Line (Tree : in Syntax_Trees.Tree; Non_Grammar : in Lexer.Token_Arrays.Vector; Line : in Line_Number_Type) return Boolean with Pre => (for some Token of Non_Grammar => Contains (Token.Line_Region, Line) and New_Line_Count (Token.Line_Region) > 0) -- Return True if Line in Non_Grammar contains no non_grammar tokens -- other than New_Line or EOI. is begin for I in Non_Grammar.First_Index .. Non_Grammar.Last_Index loop if Contains (Non_Grammar (I).Line_Region, Line) and New_Line_Count (Non_Grammar (I).Line_Region) > 0 then declare Line_Begin_Char_Pos : constant Base_Buffer_Pos := Tree.Lexer.Line_Begin_Char_Pos (Non_Grammar (I), Line); begin if Line_Begin_Char_Pos /= Invalid_Buffer_Pos then if Non_Grammar (I).Char_Region.Last + 1 > Line_Begin_Char_Pos then return True; else pragma Assert (Non_Grammar (I).Char_Region.Last + 1 = Line_Begin_Char_Pos); return I < Non_Grammar.Last_Index and then not (Non_Grammar (I + 1).ID in Tree.Lexer.Descriptor.New_Line_ID | Tree.Lexer.Descriptor.EOI_ID); end if; end if; end; end if; end loop; -- Getting here violates the precondition raise SAL.Programmer_Error; end Empty_Line; procedure Enable_Ref_Count_Check (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Enable : in Boolean) is begin Tree.Streams (Stream.Cur).Elements.Enable_Ref_Count_Check (Enable); end Enable_Ref_Count_Check; function EOI (Tree : in Syntax_Trees.Tree) return Node_Access is begin return Tree.EOI; end EOI; function Error (Item : in Error_Ref) return Error_Data'Class is begin return Error_Data_Lists.Element (Item.Error); end Error; function Error (Item : in Stream_Error_Ref) return Error_Data'Class is begin return Error_Data_Lists.Element (Item.Error); end Error; function Error (Item : in Stream_Error_Cursor) return Stream_Error_Ref is begin return Item.SER; end Error; function Error_Count (Tree : in Syntax_Trees.Tree) return Ada.Containers.Count_Type is Error : Error_Ref := Tree.First_Error; begin return Result : Ada.Containers.Count_Type := 0 do loop exit when Error.Node = Invalid_Node_Access; Result := @ + 1; Tree.Next_Error (Error); end loop; end return; end Error_Count; function Error_Count (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Ada.Containers.Count_Type is begin return Result : Ada.Containers.Count_Type := 0 do for Cur in Tree.Stream_Error_Iterate (Stream) loop Result := @ + 1; end loop; end return; end Error_Count; function Error_Deleted (Error : in Stream_Error_Ref) return Valid_Node_Access_Lists.Cursor is begin return Error.Deleted; end Error_Deleted; function Error_Iterate (Tree : aliased in Syntax_Trees.Tree) return Error_Iterator_Interfaces.Forward_Iterator'Class is begin return Error_Iterator'(Tree => Tree'Access); end Error_Iterate; function Error_List (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Error_Data_List_Const_Ref is begin return Error_Data_List_Const_Ref' (List => (if Node.Error_List = null then Empty_Error_List'Access else Node.Error_List), Dummy => 1); end Error_List; function Error_Message_1 (Tree : in Syntax_Trees.Tree; Prev_Non_Grammar : in WisiToken.Lexer.Token_Arrays.Vector; First_Terminal : in Node_Access; Message : in String) return String is Line : Line_Number_Type := Line_Number_Type'First; Column : Ada.Text_IO.Count := Ada.Text_IO.Count'First; begin if Prev_Non_Grammar.Length > 0 then Line := Prev_Non_Grammar (Prev_Non_Grammar.Last_Index).Line_Region.Last; if First_Terminal /= Invalid_Node_Access then if First_Terminal.Label = Source_Terminal and then First_Terminal.Char_Region.First /= Invalid_Buffer_Pos then declare Begin_Char_Pos : constant Buffer_Pos := (if Tree.Editable then Tree.Line_Begin_Char_Pos (Line) else Tree.Line_Begin_Char_Pos (Line, Tree.Shared_Stream)); begin Column := (if Begin_Char_Pos = Invalid_Buffer_Pos or First_Terminal.Char_Region.First < Begin_Char_Pos then 0 else Ada.Text_IO.Count (First_Terminal.Char_Region.First - Begin_Char_Pos)); end; end if; else -- No char_pos, so no column null; end if; else -- No line information, so also no column. null; end if; return WisiToken.Error_Message (Tree.Lexer.File_Name, Line, Column, Message); end Error_Message_1; function Error_Message (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Message : in String) return String is Non_Grammar : Node_Access := Invalid_Node_Access; Null_Non_Grammar : WisiToken.Lexer.Token_Arrays.Vector; begin if Tree.Parents_Set then begin -- Tolerate broken trees where Prev_Non_Grammar doesn't find SOI, or -- raises an exception. Non_Grammar := Tree.Prev_Non_Grammar (Node); exception when others => null; end; end if; return Error_Message_1 (Tree, (if Non_Grammar = Invalid_Node_Access then Null_Non_Grammar else Non_Grammar.Non_Grammar), Tree.First_Terminal (Node), Message); end Error_Message; function Error_Message (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Message : in String) return String is begin if Tree.Parents_Set then declare Non_Grammar : Stream_Node_Ref := Ref; First_Terminal : Stream_Node_Ref := Ref; begin Tree.Prev_Non_Grammar (Non_Grammar); Tree.First_Terminal (First_Terminal); return Error_Message_1 (Tree, Non_Grammar.Node.Non_Grammar, First_Terminal.Node, Message); end; elsif Rooted (Ref) then declare Non_Grammar : Stream_Node_Parents := (Ref, Parents => <>); First_Terminal : Stream_Node_Parents := (Ref, Parents => <>); begin Tree.Prev_Non_Grammar (Non_Grammar, Parse_Stream => Invalid_Stream_ID); Tree.First_Terminal (First_Terminal, Following => True); return Error_Message_1 (Tree, Non_Grammar.Ref.Node.Non_Grammar, First_Terminal.Ref.Node, Message); end; else declare Non_Grammar : constant Node_Access := Tree.First_Non_Grammar (Ref.Node); First_Terminal : constant Node_Access := Tree.First_Terminal (Ref.Node); begin return Error_Message_1 (Tree, (if Non_Grammar = Invalid_Node_Access then Lexer.Token_Arrays.Empty_Vector else Non_Grammar.Non_Grammar), First_Terminal, Message); end; end if; end Error_Message; function Error_Node (Error : in Error_Ref) return Valid_Node_Access is begin if Valid_Node_Access_Lists.Has_Element (Error.Deleted) then pragma Assert (Error.Node.Label = Source_Terminal); return Error.Node.Following_Deleted (Error.Deleted); else return Error.Node; end if; end Error_Node; function Error_Node (Tree : in Syntax_Trees.Tree; Error : in Error_Ref) return Valid_Node_Access is pragma Unreferenced (Tree); begin return Error_Node (Error); end Error_Node; function Error_Node (Error : in Stream_Error_Ref) return Valid_Node_Access is begin return Error_Node (Error_Ref' (Node => Error.Ref.Ref.Node, Deleted => Error.Deleted, Error => Error.Error)); end Error_Node; function Error_Node (Tree : in Syntax_Trees.Tree; Error : in Stream_Error_Ref) return Valid_Node_Access is pragma Unreferenced (Tree); begin return Error_Node (Error); end Error_Node; function Error_Stream_Node_Ref (Tree : in Syntax_Trees.Tree; Error : in Stream_Error_Ref) return Stream_Node_Ref is begin return (Stream => Error.Ref.Ref.Stream, Element => Error.Ref.Ref.Element, Node => Tree.Error_Node (Error_Ref' (Node => Error.Ref.Ref.Node, Deleted => Error.Deleted, Error => Error.Error))); end Error_Stream_Node_Ref; overriding procedure Finalize (Tree : in out Syntax_Trees.Tree) is begin Clear (Tree, Free_Memory => True); -- Tree.* array memory is freed by SAL Vectors Finalize. end Finalize; function Find_Ancestor (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID; Max_Parent : in Boolean := False) return Node_Access is N : Node_Access := Node; Last_Parent : Node_Access := Invalid_Node_Access; begin loop N := N.Parent; exit when N = Invalid_Node_Access; Last_Parent := N; exit when ID = N.ID; end loop; return (if Max_Parent then Last_Parent else N); end Find_Ancestor; function Find_Ancestor (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; IDs : in Token_ID_Array; Max_Parent : in Boolean := False) return Node_Access is N : Node_Access := Node; Last_Parent : Node_Access := Invalid_Node_Access; begin loop N := N.Parent; exit when N = Invalid_Node_Access; Last_Parent := N; exit when (for some ID of IDs => ID = N.ID); end loop; return (if Max_Parent then Last_Parent else N); end Find_Ancestor; function Find_Byte_Pos (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Byte_Pos : in Buffer_Pos; Trailing_Non_Grammar : in Boolean) return Node_Access -- Return terminal node in subtree under Node that contains -- (including non_grammar if Trailing_Non_Grammar) or is after -- Byte_Pos. Invalid_Node_Access if byte_Pos is after all of Node. is begin case Node.Label is when Source_Terminal => if Byte_Pos <= Node.Byte_Region.Last then return Node; elsif (Trailing_Non_Grammar and Node.Non_Grammar.Length > 0) and then Byte_Pos <= Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last then return Node; elsif Node.ID = Tree.Lexer.Descriptor.EOI_ID and Byte_Pos = Node.Byte_Region.First then return Node; else return Invalid_Node_Access; end if; when Virtual_Terminal | Virtual_Identifier => if (Trailing_Non_Grammar and Node.Non_Grammar.Length > 0) and then Byte_Pos <= Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last then return Node; else return Invalid_Node_Access; end if; when Nonterm => for Child of Node.Children loop declare Region : constant Buffer_Region := Tree.Byte_Region (Child, Trailing_Non_Grammar); begin if Region = Null_Buffer_Region then -- Child is empty or virtual; try next null; elsif Byte_Pos <= Region.First then return Tree.First_Terminal (Child); elsif Byte_Pos <= Region.Last then return Find_Byte_Pos (Tree, Child, Byte_Pos, Trailing_Non_Grammar); else null; -- try next child end if; end; end loop; -- Byte_Pos is after last child return Invalid_Node_Access; end case; end Find_Byte_Pos; function Find_Byte_Pos (Tree : in Syntax_Trees.Tree; Byte_Pos : in Buffer_Pos; Trailing_Non_Grammar : in Boolean) return Node_Access is Node : constant Node_Access := Root (Tree); Byte_Region : constant Buffer_Region := (First => Tree.SOI.Non_Grammar (1).Byte_Region.First, Last => Tree.EOI.Non_Grammar (1).Byte_Region.First); begin if Byte_Pos <= Byte_Region.First then return Tree.First_Terminal (Node); elsif Byte_Pos > Byte_Region.Last then return Invalid_Node_Access; else return Find_Byte_Pos (Tree, Node, Byte_Pos, Trailing_Non_Grammar); end if; end Find_Byte_Pos; function Find_Byte_Pos (Tree : in Syntax_Trees.Tree; Byte_Pos : in Buffer_Pos; Trailing_Non_Grammar : in Boolean; Start_At : in Terminal_Ref; Stream : in Stream_ID := Invalid_Stream_ID) return Terminal_Ref is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (if Start_At = Invalid_Stream_Node_Ref then Stream.Cur else Start_At.Stream.Cur); function Find_Parent return Stream_Node_Ref is Node : Node_Access := Start_At.Node; begin loop if Node.Parent = null then declare Cur : constant Stream_Element_Lists.Cursor := Stream_Element_Lists.Next (Start_At.Element.Cur); begin if Stream_Element_Lists.Has_Element (Cur) then return Tree.To_Rooted_Ref (Start_At.Stream, (Cur => Cur)); else return Invalid_Stream_Node_Ref; end if; end; elsif Contains (Tree.Byte_Region (Node.Parent, Trailing_Non_Grammar => False), Byte_Pos) then return (Start_At.Stream, Start_At.Element, Node.Parent); else Node := Node.Parent; end if; end loop; end Find_Parent; Result : Stream_Node_Ref := (if Start_At = Invalid_Stream_Node_Ref then (Stream, (Cur => Parse_Stream.Elements.First), null) else Find_Parent); begin loop exit when Result.Element.Cur = No_Element; Result.Node := Find_Byte_Pos (Tree, Stream_Element_Lists.Element (Result.Element.Cur).Node, Byte_Pos, Trailing_Non_Grammar); if Result.Node = Invalid_Node_Access then -- Try next stream element Result.Element.Cur := Next (Result.Element.Cur); else return Result; end if; end loop; -- end of stream reached; Byte_Pos is after all of Stream return Result; end Find_Byte_Pos; function Find_Char_Pos (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Char_Pos : in Buffer_Pos; Include_Non_Grammar : in Boolean; After : in Boolean) return Node_Access is begin case Node.Label is when Source_Terminal => if Contains (Node.Char_Region, Char_Pos) then return Node; elsif After and Char_Pos <= Node.Char_Region.Last then return Node; elsif (Include_Non_Grammar and Node.Non_Grammar.Length > 0) and then Char_Pos <= Node.Non_Grammar (Node.Non_Grammar.Last_Index).Char_Region.Last then return Node; else return Invalid_Node_Access; end if; when Virtual_Terminal | Virtual_Identifier => if (Include_Non_Grammar and Node.Non_Grammar.Length > 0) and then Char_Pos <= Node.Non_Grammar (Node.Non_Grammar.Last_Index).Char_Region.Last then return Node; else return Invalid_Node_Access; end if; when Nonterm => for Child of Node.Children loop declare Region : constant Buffer_Region := Tree.Char_Region (Child, Include_Non_Grammar); begin if Length (Region) = 0 then -- Child is empty or all virtual; try next null; elsif Char_Pos <= Region.Last then declare Result : constant Node_Access := Find_Char_Pos (Tree, Child, Char_Pos, Include_Non_Grammar, After); begin if Tree.ID (Child) = Tree.Lexer.Descriptor.SOI_ID then pragma Assert (Child.Label = Source_Terminal); -- SOI does not have an empty region (see comment in Start_Lex), but -- we define it to not contain any text. EOI does have an empty -- region. if Char_Pos < Child.Char_Region.Last then if After then return Child; else return Invalid_Node_Access; end if; elsif (Include_Non_Grammar and Child.Non_Grammar.Length > 1) and then Char_Pos <= Child.Non_Grammar (Child.Non_Grammar.Last_Index).Char_Region.Last then return Child; else null; -- try next child end if; else return Result; end if; end; else null; -- try next child end if; end; end loop; -- Char_Pos is after last child return Invalid_Node_Access; end case; end Find_Char_Pos; function Find_Char_Pos (Tree : in Syntax_Trees.Tree; Char_Pos : in Buffer_Pos; Trailing_Non_Grammar : in Boolean; After : in Boolean := False) return Node_Access is Node : constant Node_Access := Root (Tree); Char_Region : constant Buffer_Region := Tree.Char_Region (Node, Trailing_Non_Grammar); begin if Char_Pos < Char_Region.First then if After then return Tree.First_Terminal (Node); else return Invalid_Node_Access; end if; elsif Char_Pos > Char_Region.Last then return Invalid_Node_Access; else return Find_Char_Pos (Tree, Node, Char_Pos, Trailing_Non_Grammar, After); end if; end Find_Char_Pos; function Find_Child (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID) return Node_Access is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => return Invalid_Node_Access; when Nonterm => for C of Node.Children loop if C /= null then if ID = C.ID then return C; end if; end if; end loop; return Invalid_Node_Access; end case; end Find_Child; function Find_Descendant (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID) return Node_Access is Found : Node_Access := Invalid_Node_Access; function Process (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin if Node.ID = ID then Found := Node; return False; else return True; end if; end Process; Junk : constant Boolean := Process_Tree (Tree, Node, Before, Process'Access); pragma Unreferenced (Junk); begin return Found; end Find_Descendant; function Find_Descendant (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Predicate : access function (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean) return Node_Access is Found : Node_Access := Invalid_Node_Access; function Process (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin if Predicate (Tree, Node) then Found := Node; return False; else return True; end if; end Process; Junk : constant Boolean := Process_Tree (Tree, Node, Before, Process'Access); pragma Unreferenced (Junk); begin return Found; end Find_Descendant; function Find_Match (Error_List : in Error_List_Access; Predicate : in Error_Predicate) return Error_Data_Lists.Cursor is use Error_Data_Lists; begin if Error_List = null or Predicate = null then return No_Element; else return Result : Cursor := Error_List.First do loop exit when Result = No_Element; exit when Predicate (Result); Next (Result); end loop; end return; end if; end Find_Match; function Find_New_Line (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type; Node : in Node_Access; Char_Pos : out Buffer_Pos) return Node_Access with Pre => Line > Line_Number_Type'First and Tree.Parents_Set -- Return node under Node that contains the non-grammar containing a -- new_line or EOI that ends Line - 1. Update Char_Pos to the -- position of the first character on Line (or EOI). If not found, -- result is Invalid_Node_Access, Char_Pos is Invalid_Buffer_Pos. is begin Char_Pos := Invalid_Buffer_Pos; if Node = Invalid_Node_Access then return Invalid_Node_Access; end if; case Node.Label is when Terminal_Label => if Node.ID = Tree.Lexer.Descriptor.EOI_ID and then -- Handle 'Line' as well as 'Line - 1' to allow returning char_pos -- for the last line. Node.Non_Grammar (Node.Non_Grammar.First_Index).Line_Region.First in Line - 1 | Line then Char_Pos := Node.Char_Region.First; return Node; elsif Check_Non_Grammar (Tree, Node, Line, Char_Pos) then return Node; elsif Tree.Lexer.Can_Contain_New_Line (Node.ID) and then Check_Multi_Line (Tree, Node, Line, Char_Pos, Start_Line => Tree.Prev_New_Line (Node).Line) then return Node; else return Invalid_Node_Access; end if; when Nonterm => declare Node_Line_Region : constant WisiToken.Line_Region := Tree.Line_Region (Node, Trailing_Non_Grammar => True); begin if Node.Child_Count = 0 then -- This must be an empty stream element. return Invalid_Node_Access; elsif Line - 1 in Node_Line_Region.First .. Node_Line_Region.Last then if Line - 1 = Node_Line_Region.Last then -- Faster to check last child first. for I in reverse Node.Children'Range loop declare Temp : constant Node_Access := Find_New_Line (Tree, Line, Node.Children (I), Char_Pos); begin if Temp = Invalid_Node_Access then if I = Node.Children'First then return Invalid_Node_Access; else -- Check next child null; end if; else return Temp; end if; end; end loop; return Invalid_Node_Access; else for I in Node.Children'Range loop declare Temp : constant Node_Access := Find_New_Line (Tree, Line, Node.Children (I), Char_Pos); begin if Temp = Invalid_Node_Access then if I = Node.Children'Last then return Invalid_Node_Access; else -- Check next child null; end if; else return Temp; end if; end; end loop; return Invalid_Node_Access; end if; else return Invalid_Node_Access; end if; end; end case; end Find_New_Line; function Find_New_Line (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type) return Node_Access is Char_Pos : Buffer_Pos; begin return Find_New_Line (Tree, Line, Tree.Root, Char_Pos); end Find_New_Line; function Find_New_Line (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type; Line_Begin_Char_Pos : out Buffer_Pos) return Node_Access is begin if Tree.SOI.Non_Grammar (Tree.SOI.Non_Grammar.First_Index).Line_Region.Last = Line then Line_Begin_Char_Pos := Tree.SOI.Char_Region.First; return Tree.SOI; else return Find_New_Line (Tree, Line, Tree.Root, Line_Begin_Char_Pos); end if; end Find_New_Line; procedure Find_New_Line_1 (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Parse_Stream : in Stream_ID; Line : in Line_Number_Type; Char_Pos : out Buffer_Pos) with Pre => Line > Line_Number_Type'First and Ref.Ref.Element /= Invalid_Stream_Index, Post => Ref.Ref.Element = Ref.Ref.Element'Old and (Ref.Ref.Node = Invalid_Node_Access or else (Ref.Ref.Node.Label in Terminal_Label)) -- Update Ref to node under Ref.Node in Ref.Stream that contains the -- Non_Grammar that ends Line - 1. Set Char_Pos to the position of -- the first character on Line. If not found, Ref.Ref.Node is -- Invalid_Node_Access, Char_Pos is Invalid_Buffer_Pos. is begin Char_Pos := Invalid_Buffer_Pos; if Ref.Ref.Node = Invalid_Node_Access then return; end if; case Ref.Ref.Node.Label is when Terminal_Label => if Ref.Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID and then -- Handle 'Line' as well as 'Line - 1' to allow returning char_pos -- for the last line. Ref.Ref.Node.Non_Grammar (Ref.Ref.Node.Non_Grammar.First_Index).Line_Region.First in Line - 1 | Line then Char_Pos := Ref.Ref.Node.Char_Region.First; return; elsif Check_Non_Grammar (Tree, Ref.Ref.Node, Line, Char_Pos) then return; else Ref.Ref.Node := Invalid_Node_Access; return; end if; when Nonterm => if Ref.Ref.Node.Child_Count = 0 then -- This must be an empty stream element. Ref.Ref.Node := Invalid_Node_Access; return; else declare Node_Line_Region : constant WisiToken.Line_Region := Tree.Line_Region (Ref, Parse_Stream, Trailing_Non_Grammar => True); function Check_Child (I : in SAL.Peek_Type; Forward : in Boolean) return Boolean -- True => return from Find_New_Line; False => check next child. is Temp : Stream_Node_Parents := ((Ref.Ref.Stream, Ref.Ref.Element, Ref.Ref.Node.Children (I)), Ref.Parents); begin Temp.Parents.Push (Ref.Ref.Node); Find_New_Line_1 (Tree, Temp, Parse_Stream, Line, Char_Pos); if Temp.Ref.Node = Invalid_Node_Access then if I = (if Forward then Ref.Ref.Node.Children'Last else Ref.Ref.Node.Children'First) then Ref.Ref.Node := Invalid_Node_Access; return True; else -- Check next child return False; end if; else Ref := Temp; return True; end if; end Check_Child; begin if Contains (Node_Line_Region, Line - 1) then if Line - 1 = Node_Line_Region.Last then -- Faster to check last child first. for I in reverse Ref.Ref.Node.Children'Range loop if Check_Child (I, Forward => False) then return; end if; end loop; else for I in Ref.Ref.Node.Children'Range loop if Check_Child (I, Forward => True) then return; end if; end loop; end if; end if; Ref.Ref.Node := Invalid_Node_Access; return; end; end if; end case; end Find_New_Line_1; procedure Find_New_Line (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Parse_Stream : in Stream_ID; Line : in Line_Number_Type; Char_Pos : out Buffer_Pos) with Pre => Line > Line_Number_Type'First and Ref.Parents.Is_Empty and Ref.Ref.Node = Stream_Element_Lists.Element (Ref.Ref.Element.Cur).Node, Post => Ref.Ref = Invalid_Stream_Node_Ref or else (Ref.Ref.Node.Label in Terminal_Label) -- On entry, Ref.Ref should be Stream_First (Ref.Stream). Update Ref -- to node in Ref.Stream or Tree.Shared_Stream that ends Line - 1 (or -- EOI). Set Char_Pos to the position of the first character on Line -- (or EOI). If not found (ie Line < SOI.Line or Line > EOI.Line), -- Ref.Ref is Invalid_Stream_Node_Ref, Char_Pos is -- Invalid_Buffer_Pos. is Start_Stream : constant Stream_ID := Ref.Ref.Stream; begin loop Find_New_Line_1 (Tree, Ref, Parse_Stream, Line, Char_Pos); if Ref.Ref = Invalid_Stream_Node_Ref then return; elsif Ref.Ref.Node = Invalid_Node_Access then Stream_Next (Tree, Ref, Rooted => True); if Ref.Ref = Invalid_Stream_Node_Ref then if Start_Stream /= Tree.Shared_Stream then declare Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Start_Stream.Cur); begin Ref := (Ref => (Tree.Shared_Stream, (Cur => Parse_Stream.Shared_Link), Invalid_Node_Access), Parents => <>); First_Terminal (Tree, Ref, Following => True); end; else return; end if; end if; else return; end if; end loop; end Find_New_Line; procedure Find_Node (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) is begin for I in Tree.Nodes.First_Index .. Tree.Nodes.Last_Index loop if Tree.Nodes (I) = Node then Tree.Lexer.Trace.Put_Line (I'Image); exit; end if; end loop; end Find_Node; function Find_Sibling (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID) return Node_Access is begin if Node.Parent = Invalid_Node_Access then return Invalid_Node_Access; else case Node.Parent.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => return Invalid_Node_Access; when Nonterm => for C of Node.Parent.Children loop if C /= null then if ID = C.ID then return C; end if; end if; end loop; return Invalid_Node_Access; end case; end if; end Find_Sibling; procedure Finish_Parse (Tree : in out Syntax_Trees.Tree) is begin -- Clear saved element list cursors in parse streams before freeing -- the element lists, so they don't try to decrement reference counts -- in deallocated elements. We can't rely on cursor Finalize for -- this; that's done in arbitrary order. for Stream of Tree.Streams loop Stream.Stack_Top := Stream_Element_Lists.No_Element; Stream.Shared_Link := Stream_Element_Lists.No_Element; end loop; Tree.Shared_Stream.Cur := Parse_Stream_Lists.No_Element; Tree.Streams.Clear; Tree.Next_Stream_Label := Shared_Stream_Label + 1; if not Tree.Parents_Set then Set_Parents (Tree); end if; for Node of Tree.Nodes loop -- Only nodes that have parents are part of the final parse result. -- In an incremental parse, breakdown removes nodes from a parse -- stream, and clears any parent pointers involved. if Node.Parent = null and then Node /= Tree.Root then -- It is tempting to try to enforce that all deleted nonterms have -- Children = (others => Invalid_Node_Access) here. However, that is -- not true when Breakdown is called by the main parser; -- Tree.Parents_Set is false, indicating there might be multiple -- streams, so Breakdown does not clear children. Free (Node); end if; end loop; -- Compact Tree.Nodes declare Free : Node_Index := Tree.Nodes.First_Index - 1; begin for I in Tree.Nodes.First_Index .. Tree.Nodes.Last_Index loop if Free < Tree.Nodes.First_Index then if Tree.Nodes (I) = Invalid_Node_Access then Free := I; end if; else if Tree.Nodes (I) /= Invalid_Node_Access then Tree.Nodes (Free) := Tree.Nodes (I); Free := @ + 1; end if; end if; end loop; if Free > Tree.Nodes.First_Index then Tree.Nodes.Set_First_Last (First => Tree.Nodes.First_Index, Last => Free - 1); end if; end; end Finish_Parse; overriding function First (Object : Error_Iterator) return Error_Ref is begin return First_Error (Object.Tree.all); end First; overriding function First (Object : Stream_Error_Iterator) return Stream_Error_Cursor is begin return (SER => First_Error (Object.Tree.all, (Cur => Object.Stream))); end First; procedure First_Error (Error : in out Error_Ref) with Pre => Error.Node /= Invalid_Node_Access -- Update Error to first error on or following Deleted in Node. is use Valid_Node_Access_Lists; begin loop if not Has_Element (Error.Deleted) and then Error.Node.Error_List /= null then Error.Error := Error.Node.Error_List.First; return; end if; loop exit when not Has_Element (Error.Deleted); declare Deleted_Node : Valid_Node_Access renames Error.Node.Following_Deleted (Error.Deleted); begin if Deleted_Node.Label = Source_Terminal and then Deleted_Node.Error_List /= null then Error.Error := Deleted_Node.Error_List.First; return; end if; end; Next (Error.Deleted); end loop; Next_Node (Error.Node); exit when Error.Node = Invalid_Node_Access; if Error.Node.Error_List /= null then Error.Error := Error.Node.Error_List.First; Error.Deleted := No_Element; return; end if; Error.Deleted := (if Error.Node.Label = Source_Terminal then Error.Node.Following_Deleted.First else No_Element); end loop; end First_Error; procedure First_Error (Tree : in Syntax_Trees.Tree; Error : in out Stream_Error_Ref) with Pre => Error.Ref.Ref.Node /= Invalid_Node_Access -- Update Error to first error on or following -- Error.Ref. On enter, Error.Ref is normally stream SOI. is use Valid_Node_Access_Lists; begin loop if not Has_Element (Error.Deleted) and then Error.Ref.Ref.Node.Error_List /= null then Error.Error := Error.Ref.Ref.Node.Error_List.First; return; end if; loop exit when not Has_Element (Error.Deleted); declare Deleted_Node : Valid_Node_Access renames Error.Ref.Ref.Node.Following_Deleted (Error.Deleted); begin if Deleted_Node.Error_List /= null then Error.Error := Deleted_Node.Error_List.First; return; end if; end; Next (Error.Deleted); end loop; Next_Node (Tree, Error.Ref); if Error.Ref.Ref.Node = Invalid_Node_Access then -- No errors in tree return; end if; Error.Deleted := (if Error.Ref.Ref.Node.Label = Source_Terminal then Error.Ref.Ref.Node.Following_Deleted.First else No_Element); end loop; end First_Error; function First_Error (Tree : in Syntax_Trees.Tree) return Error_Ref is begin return Result : Error_Ref := (Tree.SOI, Tree.SOI.Following_Deleted.First, Error_Data_Lists.No_Element) do First_Error (Result); end return; end First_Error; function First_Error (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Stream_Error_Ref is begin return Result : Stream_Error_Ref := Invalid_Stream_Error_Ref do if Tree.Streams (Stream.Cur).Elements.Length > 1 then Result.Ref := Tree.To_Stream_Node_Parents (Tree.To_Rooted_Ref (Stream, Tree.Stream_First (Stream, Skip_SOI => True))); if Result.Ref.Ref.Node.Label = Source_Terminal then Result.Deleted := Result.Ref.Ref.Node.Following_Deleted.First; end if; First_Error (Tree, Result); end if; end return; end First_Error; function First_Input (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Rooted_Ref is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Cur : constant Cursor := Next (Parse_Stream.Stack_Top); begin return (Stream, (Cur => Cur), Element (Cur).Node); end First_Input; function First_Non_Grammar (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Parents : in out Node_Stacks.Stack) return Node_Access is Result : Node_Access := First_Terminal (Tree, Node, Parents); begin loop exit when Result = Invalid_Node_Access; exit when Result.Non_Grammar.Length > 0; Next_Terminal (Tree, Result, Parents); end loop; return Result; end First_Non_Grammar; function First_Non_Grammar (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is Parents : Node_Stacks.Stack; begin return First_Non_Grammar (Tree, Node, Parents); end First_Non_Grammar; function First_Parse_Stream (Tree : in Syntax_Trees.Tree) return Stream_ID is begin return (Cur => Parse_Stream_Lists.Next (Tree.Shared_Stream.Cur)); end First_Parse_Stream; procedure First_Recover_Conflict (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref) is begin loop exit when Ref = Invalid_Stream_Node_Ref; exit when Ref.Node.Label = Nonterm and then Ref.Node.Recover_Conflict; Next_Nonterm (Tree, Ref); end loop; end First_Recover_Conflict; function First_Recover_Conflict (Tree : in Syntax_Trees.Tree) return Stream_Node_Ref is begin return Result : Stream_Node_Ref := (Stream => Tree.Shared_Stream, Element => (Cur => Tree.Streams (Tree.Shared_Stream.Cur).Elements.First), Node => Tree.SOI) do First_Recover_Conflict (Tree, Result); end return; end First_Recover_Conflict; function First_Source_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean; Following : in Boolean) return Node_Access is -- If not Following, we use a Parents stack to limit Next_Terminal to -- descendants of Node. Parents : Node_Stacks.Stack; Result : Node_Access := (if Following then First_Terminal (Tree, Node) else First_Terminal (Tree, Node, Parents)); begin loop exit when Result = Invalid_Node_Access; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Result.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Result.Non_Grammar.Length > 0) else Result.Label = Source_Terminal); if Following then Next_Terminal (Tree, Result); else Next_Terminal (Tree, Result, Parents); end if; end loop; return Result; end First_Source_Terminal; procedure First_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Trailing_Non_Grammar : in Boolean) is begin Ref.Ref.Node := First_Terminal (Tree, Ref.Ref.Node, Ref.Parents); loop exit when Ref.Ref.Node /= Invalid_Node_Access and then (if Trailing_Non_Grammar then (case Terminal_Label'(Ref.Ref.Node.Label) is when Source_Terminal => True, when Virtual_Terminal => Ref.Ref.Node.Non_Grammar.Length > 0, when Virtual_Identifier => Ref.Ref.Node.Non_Grammar.Length > 0) else Ref.Ref.Node.Label = Source_Terminal); Next_Terminal (Tree, Ref, Following => True); end loop; end First_Source_Terminal; function First_Terminal (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Node_Access is begin return (if Item.Virtual then Item.First_Terminal else First_Terminal (Tree, Item.Element_Node)); end First_Terminal; function First_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => return Node; when Nonterm => for C of Node.Children loop -- This is called from Error_Message; tolerate deleted children if C /= Invalid_Node_Access then declare Term : constant Node_Access := First_Terminal (Tree, C); begin if Term /= Invalid_Node_Access then return Term; end if; end; end if; end loop; return Invalid_Node_Access; end case; end First_Terminal; function First_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Parents : in out Node_Stacks.Stack) return Node_Access is Parent_Depth : constant SAL.Base_Peek_Type := Parents.Depth; begin case Node.Label is when Terminal_Label => return Node; when Nonterm => for C of Node.Children loop -- We tolerate null C here because this function is called while -- printing a tree for debug. if C /= Invalid_Node_Access then Parents.Push (Node); declare First_Term : constant Node_Access := First_Terminal (Tree, C, Parents); begin if First_Term /= Invalid_Node_Access then return First_Term; else Parents.Pop (Parents.Depth - Parent_Depth); -- discard parents from call to First_Terminal. end if; end; end if; end loop; -- All children are empty return Invalid_Node_Access; end case; end First_Terminal; procedure First_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref) is use Stream_Element_Lists; begin Ref.Node := First_Terminal (Tree, Element (Ref.Element.Cur).Node); loop exit when Ref.Node /= Invalid_Node_Access; Stream_Next (Tree, Ref, Rooted => False); exit when not Has_Element (Ref.Element.Cur); end loop; end First_Terminal; function First_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Terminal_Ref is Result : Stream_Node_Ref := Ref; begin First_Terminal (Tree, Result); return Result; end First_Terminal; function First_Terminal_In_Node (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Terminal_Ref is begin return (Ref.Stream, Ref.Element, First_Terminal (Tree, Ref.Node)); end First_Terminal_In_Node; procedure First_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Following : in Boolean) is use Stream_Element_Lists; begin if Ref.Ref.Node = Invalid_Node_Access then -- Ref is an empty nonterm. null; else Ref.Ref.Node := First_Terminal (Tree, Ref.Ref.Node, Ref.Parents); end if; if Following then loop exit when Ref.Ref.Node /= Invalid_Node_Access; Next_Terminal (Tree, Ref, Following); exit when not Has_Element (Ref.Ref.Element.Cur); end loop; elsif Ref.Ref.Node = Invalid_Node_Access then Ref.Parents.Clear; end if; end First_Terminal; function First_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Rooted_Ref) return Stream_Node_Parents is use Stream_Element_Lists; begin -- We'd like the result type to be Terminal_Stream_Node_Parents, but -- the dynamic predicate is checked on assigning the initial value of -- Result, and it fails if Ref is not a terminal. return Result : Stream_Node_Parents := (Ref, Parents => <>) do Result.Ref.Node := First_Terminal (Tree, Element (Result.Ref.Element.Cur).Node, Result.Parents); loop exit when Result.Ref.Node /= Invalid_Node_Access; Next_Terminal (Tree, Result, Following => True); exit when not Has_Element (Result.Ref.Element.Cur); end loop; end return; end First_Terminal; -- FIXME: alphabetize these. procedure First_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access; Parents : in out Node_Stacks.Stack) is begin if Node = Invalid_Node_Access then return; end if; Node := First_Terminal (Tree, Node, Parents); loop exit when Node = Invalid_Node_Access; exit when Node.Sequential_Index /= Invalid_Sequential_Index; Tree.Next_Terminal (Node, Parents); end loop; end First_Sequential_Terminal; function First_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Parents : in out Node_Stacks.Stack) return Node_Access is Result : Node_Access := Node; begin First_Sequential_Terminal (Tree, Result, Parents); return Result; end First_Sequential_Terminal; function First_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in Node_Access) return Node_Access is Parents : Node_Stacks.Stack; begin return Tree.First_Sequential_Terminal (Node, Parents); end First_Sequential_Terminal; procedure First_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Syntax_Trees.Stream_Node_Ref) is begin Tree.First_Terminal (Ref); loop exit when Ref = Invalid_Stream_Node_Ref; exit when Ref.Node /= Invalid_Node_Access and then Tree.Get_Sequential_Index (Ref.Node) /= Invalid_Sequential_Index; Tree.Next_Terminal (Ref); end loop; end First_Sequential_Terminal; function First_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Syntax_Trees.Rooted_Ref) return Terminal_Ref is Ref_Parents : Stream_Node_Parents := (Ref, Parents => <>); begin Tree.First_Sequential_Terminal (Ref_Parents, Following => True); return Ref_Parents.Ref; end First_Sequential_Terminal; procedure First_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Syntax_Trees.Stream_Node_Parents; Following : in Boolean) is begin Tree.First_Terminal (Ref, Following); loop exit when Ref.Ref = Invalid_Stream_Node_Ref; exit when Ref.Ref.Node /= Invalid_Node_Access and then Tree.Get_Sequential_Index (Ref.Ref.Node) /= Invalid_Sequential_Index; exit when not Following and Ref.Ref.Node = Invalid_Node_Access; Tree.Next_Terminal (Ref, Following); end loop; end First_Sequential_Terminal; procedure Free_Augmented (Tree : in Syntax_Trees.Tree) is begin for Node of Tree.Nodes loop Free (Node.Augmented); end loop; end Free_Augmented; function Following_Deleted (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access) return Valid_Node_Access_List_Var_Ref is begin return (List => Node.Following_Deleted'Access, Dummy => 1); end Following_Deleted; function Fully_Parsed (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Root /= Invalid_Node_Access; end Fully_Parsed; procedure Get_IDs (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID; Result : in out Valid_Node_Access_Array; Last : in out SAL.Base_Peek_Type) is begin if Node.ID = ID then Last := Last + 1; Result (Last) := Node; end if; case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => null; when Nonterm => for I of Node.Children loop -- Encountering a deleted child here is an error in the user algorithm. Get_IDs (Tree, I, ID, Result, Last); end loop; end case; end Get_IDs; function Get_IDs (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; ID : in Token_ID) return Valid_Node_Access_Array is Last : SAL.Base_Peek_Type := 0; begin return Result : Valid_Node_Access_Array (1 .. Count_IDs (Tree, Node, ID)) := (others => Dummy_Node) do Get_IDs (Tree, Node, ID, Result, Last); end return; end Get_IDs; function Get_Node (Element : in Stream_Index) return Valid_Node_Access is begin return Stream_Element_Lists.Element (Element.Cur).Node; end Get_Node; function Get_Node (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Valid_Node_Access is begin return Stream_Element_Lists.Element (Element.Cur).Node; end Get_Node; function Get_Node_Index (Node : in Node_Access) return Node_Index is begin return (if Node = Invalid_Node_Access then Invalid_Node_Index else Node.Node_Index); end Get_Node_Index; function Get_Node_Index (Tree : in Syntax_Trees.Tree; Node : in Node_Access) return Node_Index is begin return (if Node = Invalid_Node_Access then Invalid_Node_Index else Node.Node_Index); end Get_Node_Index; function Get_Node_Index (Element : in Stream_Index) return Node_Index is begin return (if Stream_Element_Lists.Has_Element (Element.Cur) then Stream_Element_Lists.Element (Element.Cur).Node.Node_Index else Invalid_Node_Index); end Get_Node_Index; function Get_Node_Index (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Node_Index is begin return Get_Node_Index (Element); end Get_Node_Index; function Get_Recover_Token (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Recover_Token is begin return (Virtual => False, Element_Node => (if Ref.Element = Invalid_Stream_Index then Invalid_Node_Access else Stream_Element_Lists.Element (Ref.Element.Cur).Node), Node => Ref.Node); end Get_Recover_Token; function Get_Recover_Token (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Recover_Token is begin -- Used in McKenzie_Recover.Undo_Reduce, so same value as in Tree.Push (Node) return (Virtual => False, Element_Node => Node, Node => Node); end Get_Recover_Token; function Get_Sequential_Index (Tree : in Syntax_Trees.Tree; Node : in Node_Access) return Base_Sequential_Index is pragma Unreferenced (Tree); begin return (if Node = Invalid_Node_Access then Invalid_Sequential_Index else Node.Sequential_Index); end Get_Sequential_Index; procedure Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Result : in out Valid_Node_Access_Array; Last : in out SAL.Base_Peek_Type) is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => Last := Last + 1; Result (Last) := Node; when Nonterm => for C of Node.Children loop -- This is called to build an edited source image while editing the tree if C /= null then Get_Terminals (Tree, C, Result, Last); end if; end loop; end case; end Get_Terminals; function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Valid_Node_Access_Array is Last : SAL.Base_Peek_Type := 0; begin return Result : Valid_Node_Access_Array (1 .. SAL.Base_Peek_Type (Count_Terminals (Tree, Node))) := (others => Dummy_Node) do Get_Terminals (Tree, Node, Result, Last); end return; end Get_Terminals; procedure Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Result : in out Token_ID_Array; Last : in out SAL.Base_Peek_Type) is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => Last := Last + 1; Result (Integer (Last)) := Node.ID; when Nonterm => for I of Node.Children loop -- Encountering Deleted_Child here is an error in the user algorithm. Get_Terminal_IDs (Tree, I, Result, Last); end loop; end case; end Get_Terminal_IDs; function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Token_ID_Array is Last : SAL.Base_Peek_Type := 0; begin return Result : Token_ID_Array (1 .. Count_Terminals (Tree, Node)) do Get_Terminal_IDs (Tree, Node, Result, Last); end return; end Get_Terminal_IDs; procedure Get_Tree (Tree : in out Syntax_Trees.Tree; File_Name : in String) is use Ada.Streams.Stream_IO; Delims : constant Ada.Strings.Maps.Character_Set := Ada.Strings.Maps.To_Set (" ()," & ASCII.LF); File : File_Type; Stream : Stream_Access; Node_Index_Map : Node_Index_Array_Node_Access.Vector; package Node_Index_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists (Node_Index); type Delayed_Following_Deleted_Type is record Prev_Terminal : Node_Access; List : Node_Index_Lists.List; end record; package Delayed_Following_Deleted_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists (Delayed_Following_Deleted_Type); Delayed_Following_Deleted : Delayed_Following_Deleted_Lists.List; function Next_Value return String is begin return WisiToken.Next_Value (Stream, Delims); end Next_Value; function Input_Buffer_Region return Buffer_Region is begin return Result : Buffer_Region do Result.First := Base_Buffer_Pos'Value (Next_Value); Result.Last := Base_Buffer_Pos'Value (Next_Value); end return; end Input_Buffer_Region; function Input_Line_Region return WisiToken.Line_Region is begin return Result : WisiToken.Line_Region do Result.First := Line_Number_Type'Value (Next_Value); Result.Last := Line_Number_Type'Value (Next_Value); end return; end Input_Line_Region; function Input_Token return WisiToken.Lexer.Token is begin return Result : WisiToken.Lexer.Token do Result.ID := Token_ID'Value (Next_Value); Result.Byte_Region := Input_Buffer_Region; Result.Char_Region := Input_Buffer_Region; Result.Line_Region := Input_Line_Region; end return; end Input_Token; function Input_Non_Grammar return WisiToken.Lexer.Token_Arrays.Vector is Length : constant SAL.Base_Peek_Type := SAL.Base_Peek_Type'Value (Next_Value); begin return Result : WisiToken.Lexer.Token_Arrays.Vector do if Length > 0 then Result.Set_First_Last (1, Length); for I in 1 .. Length loop Result (I) := Input_Token; end loop; end if; end return; end Input_Non_Grammar; function Get_Node_Access return Node_Access is Index : constant Node_Index := Node_Index'Value (Next_Value); begin if Index = Invalid_Node_Index then return Invalid_Node_Access; end if; if Index in Node_Index_Map.First_Index .. Node_Index_Map.Last_Index then return Node_Index_Map (Index); else raise SAL.Programmer_Error; end if; end Get_Node_Access; function Input_Error_List return Error_List_Access is Length : constant Ada.Containers.Count_Type := Ada.Containers.Count_Type'Value (Next_Value); begin if Length = 0 then return null; else return Result : constant Error_List_Access := new Error_Data_Lists.List do for I in 1 .. Length loop Result.Append (Error_Data'Class'Input (Stream)); end loop; end return; end if; end Input_Error_List; procedure Input_Following_Deleted (Node : in Valid_Node_Access) is Length : constant Ada.Containers.Count_Type := Ada.Containers.Count_Type'Value (Next_Value); begin if Length = 0 then return; else -- Following nodes have not been created yet. Need to read node_index -- list, cache it somewhere, finish this after they are read. declare Item : Delayed_Following_Deleted_Type; begin Item.Prev_Terminal := Node; for I in 1 .. Length loop Item.List.Append (Node_Index'Value (Next_Value)); end loop; end; end if; end Input_Following_Deleted; function Input_Children (Child_Count : in SAL.Base_Peek_Type) return Node_Access_Array is begin -- Child nodes are always created before parent nodes, so -- Get_Node_Access will succeed. return Result : Node_Access_Array (1 .. Child_Count) do for I in Result'Range loop Result (I) := Get_Node_Access; end loop; end return; end Input_Children; procedure Input_Node -- Read one node from Stream is begin declare Label : constant Node_Label := Node_Label'Value (Next_Value); Child_Count : constant SAL.Base_Peek_Type := SAL.Base_Peek_Type'Value (Next_Value); ID : constant Token_ID := Token_ID'Value (Next_Value); Node_Index : constant Syntax_Trees.Node_Index := Syntax_Trees.Node_Index'Value (Next_Value); Error_List : constant Error_List_Access := Input_Error_List; begin case Label is when Terminal_Label => declare Non_Grammar : constant Lexer.Token_Arrays.Vector := Input_Non_Grammar; Sequential_Index : constant Base_Sequential_Index := Base_Sequential_Index'Value (Next_Value); begin case Terminal_Label'(Label) is when Source_Terminal => if Node_Index = 0 and ID /= Tree.Lexer.Descriptor.SOI_ID then raise WisiToken.User_Error with "source_terminal node_index 0 has id" & ID'Image & " /= SOI; probably wrong language."; end if; pragma Assert (Child_Count = 0 and (Node_Index > 0 or else ID = Tree.Lexer.Descriptor.SOI_ID)); declare Byte_Region : constant Buffer_Region := Input_Buffer_Region; Char_Region : constant Buffer_Region := Input_Buffer_Region; New_Line_Count : constant Base_Line_Number_Type := Base_Line_Number_Type'Value (Next_Value); New_Node : constant Valid_Node_Access := new Node' (Label => Source_Terminal, Copied_Node => Invalid_Node_Access, Parent => Invalid_Node_Access, Augmented => null, Child_Count => 0, ID => ID, Node_Index => Node_Index, Error_List => Error_List, Non_Grammar => Non_Grammar, Sequential_Index => Sequential_Index, Byte_Region => Byte_Region, Char_Region => Char_Region, New_Line_Count => New_Line_Count, Following_Deleted => Valid_Node_Access_Lists.Empty_List); begin Input_Following_Deleted (New_Node); Tree.Nodes.Append (New_Node); Node_Index_Map.Extend (Node_Index); Node_Index_Map (Node_Index) := New_Node; if New_Node.ID = Tree.Lexer.Descriptor.EOI_ID then Tree.EOI := New_Node; elsif New_Node.ID = Tree.Lexer.Descriptor.SOI_ID then Tree.SOI := New_Node; end if; end; when Virtual_Terminal => pragma Assert (Child_Count = 0 and Node_Index < 0); declare Insert_Location : constant WisiToken.Insert_Location := WisiToken.Insert_Location'Value (Next_Value); New_Node : constant Valid_Node_Access := new Node' (Label => Virtual_Terminal, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => ID, Node_Index => Node_Index, Parent => Invalid_Node_Access, Augmented => null, Error_List => Error_List, Non_Grammar => Non_Grammar, Sequential_Index => Sequential_Index, Insert_Location => Insert_Location); begin Tree.Nodes.Append (New_Node); Node_Index_Map.Extend (Node_Index); Node_Index_Map (Node_Index) := New_Node; end; when Virtual_Identifier => raise SAL.Programmer_Error; end case; end; when Nonterm => pragma Assert (Node_Index < 0); declare Virtual : constant Boolean := Boolean'Value (Next_Value); Recover_Conflict : constant Boolean := Boolean'Value (Next_Value); RHS_Index : constant Natural := Natural'Value (Next_Value); Name_Offset : constant Base_Buffer_Pos := Base_Buffer_Pos'Value (Next_Value); Name_Length : constant Base_Buffer_Pos := Base_Buffer_Pos'Value (Next_Value); Children : constant Node_Access_Array := Input_Children (Child_Count); New_Node : constant Valid_Node_Access := new Node' (Label => Nonterm, Copied_Node => Invalid_Node_Access, Child_Count => Child_Count, ID => ID, Node_Index => Node_Index, Parent => Invalid_Node_Access, Augmented => null, Error_List => Error_List, Virtual => Virtual, Recover_Conflict => Recover_Conflict, RHS_Index => RHS_Index, Name_Offset => Name_Offset, Name_Length => Name_Length, Children => Children); begin Tree.Nodes.Append (New_Node); Node_Index_Map.Extend (Node_Index); Node_Index_Map (Node_Index) := New_Node; for Child of Children loop Child.Parent := New_Node; end loop; end; end case; end; end Input_Node; begin Open (File, In_File, File_Name); Stream := Ada.Streams.Stream_IO.Stream (File); declare Node_Count : constant Positive_Node_Index := Positive_Node_Index'Value (Next_Value); begin for I in 1 .. Node_Count loop Input_Node; end loop; end; for Item of Delayed_Following_Deleted loop for Index of Item.List loop Item.Prev_Terminal.Following_Deleted.Append (Node_Index_Map (Index)); end loop; end loop; declare Streams_Length : constant Ada.Containers.Count_Type := Ada.Containers.Count_Type'Value (Next_Value); begin for I in 1 .. Streams_Length loop raise SAL.Not_Implemented with "get_tree: streams"; end loop; end; Tree.Set_Root (Get_Node_Access); Close (File); if Tree.Streams.Length > 0 then for Stream_Cur in Tree.Streams.Iterate loop for Err_Cur in Tree.Stream_Error_Iterate ((Cur => Stream_Cur)) loop Error_Data_Lists.Variable_Ref (Err_Cur.SER.Error).Set_Node_Access (Node_Index_Map); end loop; end loop; else Tree.Set_Parents; for Err in Tree.Error_Iterate loop Error_Data_Lists.Variable_Ref (Err.Error).Set_Node_Access (Node_Index_Map); end loop; end if; end Get_Tree; function In_Tree (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return (for some N of Tree.Nodes => N = Node); end In_Tree; function Has_Child (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Child : in Valid_Node_Access) return Boolean is begin for C of Node.Children loop if C = Child then return True; end if; end loop; return False; end Has_Child; function Has_Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return Node.Children'Length > 0; end Has_Children; function Has_Error (Node : in Valid_Node_Access) return Boolean is begin return Node.Error_List /= null; end Has_Error; function Has_Error (Error : in Error_Ref) return Boolean is begin if Error.Node = Invalid_Node_Access then return False; elsif Valid_Node_Access_Lists.Has_Element (Error.Deleted) then return True; else return Error.Node.Error_List /= null; end if; end Has_Error; function Has_Error (Error : in Stream_Error_Ref) return Boolean is begin if Error.Ref.Ref.Node = Invalid_Node_Access then return False; elsif Valid_Node_Access_Lists.Has_Element (Error.Deleted) then return True; else return Error.Ref.Ref.Node.Error_List /= null; end if; end Has_Error; function Has_Error (Position : in Stream_Error_Cursor) return Boolean is begin return Has_Error (Position.SER); end Has_Error; function Has_Error (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Node.Error_List /= null; end Has_Error; function Has_Error_Class (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Error_Class : in Error_Data'Class) return Error_Ref is use all type Error_Data_Lists.Cursor; use all type Ada.Tags.Tag; begin if Node.Error_List /= null then declare Result : Error_Ref := (Node => Node, Deleted => Valid_Node_Access_Lists.No_Element, Error => Node.Error_List.First); begin loop if Node.Error_List.Constant_Reference (Result.Error).Element.all'Tag = Error_Class'Tag then return Result; end if; Error_Data_Lists.Next (Result.Error); exit when Result.Error = Error_Data_Lists.No_Element; end loop; end; end if; return Invalid_Error_Ref; end Has_Error_Class; function Has_Errors (Tree : in Syntax_Trees.Tree) return Boolean is begin if Tree.Parents_Set then return Tree.First_Error /= Invalid_Error_Ref; else for Cur in Tree.Streams.Iterate loop if Tree.First_Error ((Cur => Cur)) /= Invalid_Stream_Error_Ref then return True; end if; end loop; return False; end if; end Has_Errors; function Has_Following_Deleted (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return Node.Following_Deleted.Length > 0; end Has_Following_Deleted; function Has_Input (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Boolean is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin return Parse_Stream.Stack_Top /= Parse_Stream.Elements.Last; end Has_Input; function Has_Non_Grammar (Tree : in Syntax_Trees.Tree; Terminal : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Terminal.Non_Grammar.Length > 0; end Has_Non_Grammar; function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Child.Parent /= Invalid_Node_Access; end Has_Parent; function ID (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Token_ID is pragma Unreferenced (Tree); begin return Node.ID; end ID; function ID (Tree : in Syntax_Trees.Tree; Element : in Stream_Index) return Token_ID is pragma Unreferenced (Tree); begin return Stream_Element_Lists.Element (Element.Cur).Node.ID; end ID; function Identifier (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Base_Identifier_Index is pragma Unreferenced (Tree); begin return Node.Identifier; end Identifier; function Image (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return String is begin if Item.Virtual then return "(" & Image (Item.ID, Tree.Lexer.Descriptor.all) & ")"; else return "(" & Image (Tree, Item.Element_Node, Node_Numbers => True) & (if Item.Element_Node = Item.Node then "" else ", " & Image (Tree, Item.Node, Terminal_Node_Numbers => True)) & ")"; end if; end Image; function Image (Tree : in Syntax_Trees.Tree; Stream : in Parse_Stream; Stack : in Boolean := True; Input : in Boolean := True; Shared : in Boolean := False; Children : in Boolean := False; Node_Numbers : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Line_Numbers : in Boolean := False; State_Numbers : in Boolean := True) return String is -- stack ^ stack_top input / shared use Ada.Strings.Unbounded; use Stream_Element_Lists; Result : Unbounded_String := +"(" & Trimmed_Image (Stream.Label) & ", "; Element : Cursor := (if Stack or Stream.Stack_Top = No_Element then Stream.Elements.First else Next (Stream.Stack_Top)); Need_Comma : Boolean := False; Current_Stream_Label : Stream_Label := Stream.Label; begin loop if not Has_Element (Element) then if Shared and Current_Stream_Label /= Shared_Stream_Label then if not Has_Element (Stream.Shared_Link) then exit; else Current_Stream_Label := Shared_Stream_Label; Element := Stream.Shared_Link; Result := @ & "/"; end if; else exit; end if; end if; if Need_Comma then Result := @ & (if Children then "," & ASCII.LF else ", "); else Need_Comma := True; end if; Result := @ & (if Stream.Stack_Top = Element then "^(" else "(") & (if State_Numbers then Trimmed_Image (Stream_Element_Lists.Element (Element).State) else "--") & ", " & (if Children then Tree.Subtree_Image (Stream_Element_Lists.Element (Element).Node, Node_Numbers, Non_Grammar, Augmented, Line_Numbers) else Tree.Image (Stream_Element_Lists.Element (Element).Node, Children => False, RHS_Index => False, Node_Numbers => Node_Numbers, Terminal_Node_Numbers => True, Non_Grammar => Non_Grammar, Augmented => Augmented, Line_Numbers => Line_Numbers)) & ")"; if not Input then exit when Element = Stream.Stack_Top; end if; Element := Next (Element); end loop; Result := @ & ")"; return -Result; end Image; function Image (Tree : in Syntax_Trees.Tree; Children : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Line_Numbers : in Boolean := False; Root : in Node_Access := Invalid_Node_Access) return String is begin if Root /= Invalid_Node_Access then -- Assuming children = true in this case. return Subtree_Image (Tree, Root, Non_Grammar, Augmented, Line_Numbers); elsif Tree.Streams.Length = 0 then if Tree.Root = Invalid_Node_Access then return "invalid_tree: no streams, Tree.Root not set"; else -- Assuming children = true in this case. return Subtree_Image (Tree, Tree.Root, Non_Grammar => Non_Grammar, Augmented => Augmented, Line_Numbers => Line_Numbers); end if; else declare use Ada.Strings.Unbounded; Result : Unbounded_String; Need_New_Line : Boolean := False; begin for Stream of Tree.Streams loop if Need_New_Line then Result := @ & ASCII.LF; else Need_New_Line := True; end if; Result := @ & Image (Tree, Stream, Children, Non_Grammar => Non_Grammar, Augmented => Augmented, Line_Numbers => Line_Numbers); end loop; return -Result; end; end if; end Image; function Image (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Stack : in Boolean := True; Input : in Boolean := True; Shared : in Boolean := False; Children : in Boolean := False; Node_Numbers : in Boolean := True; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Line_Numbers : in Boolean := False; State_Numbers : in Boolean := True) return String is begin return Image (Tree, Tree.Streams (Stream.Cur), Stack, Input, Shared, Children, Node_Numbers, Non_Grammar, Augmented, Line_Numbers, State_Numbers); end Image; function Image (Tree : in Syntax_Trees.Tree; Element : in Stream_Index; State : in Boolean := False; Children : in Boolean := False; RHS_Index : in Boolean := False; Node_Numbers : in Boolean := False; Terminal_Node_Numbers : in Boolean := False; Line_Numbers : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Expecting : in Boolean := False) return String is begin if Element.Cur = Stream_Element_Lists.No_Element then return ""; else declare El : Stream_Element renames Stream_Element_Lists.Element (Element.Cur); begin return (if State then "(" & Trimmed_Image (El.State) & ", " else "") & Image (Tree, El.Node, Children, RHS_Index, Node_Numbers, Terminal_Node_Numbers, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar, Augmented => Augmented, Expecting => Expecting) & (if State then ")" else ""); end; end if; end Image; function Image (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Children : in Boolean := False; RHS_Index : in Boolean := False; Node_Numbers : in Boolean := False; Terminal_Node_Numbers : in Boolean := False; Line_Numbers : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Expecting : in Boolean := False; Safe_Only : in Boolean := False) return String is use Ada.Strings.Unbounded; begin if Node = null then return ""; else declare Result : Unbounded_String; Node_Byte_Region : constant Buffer_Region := (if Safe_Only then Null_Buffer_Region else Tree.Byte_Region (Node, Trailing_Non_Grammar => False)); begin if Node.Label in Terminal_Label and then Node.Sequential_Index /= Invalid_Sequential_Index then Append (Result, Trimmed_Image (Node.Sequential_Index) & ";"); end if; if Node_Numbers then Append (Result, Trimmed_Image (Node.Node_Index) & ":"); elsif Terminal_Node_Numbers then Append (Result, (case Node.Label is when Source_Terminal => Trimmed_Image (Node.Node_Index) & ":", when Virtual_Terminal => Trimmed_Image (Node.Node_Index) & ":", when Virtual_Identifier => Trimmed_Image (Node.Identifier) & ":", when Nonterm => "")); end if; Append (Result, "(" & Image (Node.ID, Tree.Lexer.Descriptor.all)); Append (Result, (if RHS_Index and Node.Label = Nonterm then "_" & Trimmed_Image (Node.RHS_Index) else "")); if Node_Byte_Region /= Null_Buffer_Region then Append (Result, ", " & Image (Node_Byte_Region)); end if; if (Line_Numbers and Tree.Editable and not Safe_Only) and then Tree.Line_Region (Node, Trailing_Non_Grammar => True) /= Null_Line_Region then Append (Result, ", " & Image (Tree.Line_Region (Node, Trailing_Non_Grammar => True))); end if; if not Safe_Only and Children and Node.Label = Nonterm then Result := @ & " <= " & Image (Tree, Node.Children, RHS_Index, Node_Numbers, Terminal_Node_Numbers, Non_Grammar, Augmented); end if; if (Non_Grammar and Node.Label in Terminal_Label) and then Node.Non_Grammar.Length > 0 then Result := @ & "("; for Token of Node.Non_Grammar loop Result := @ & "("; Result := @ & Image (Token.ID, Tree.Lexer.Descriptor.all) & ", "; Result := @ & Image (Token.Byte_Region) & ", "; Result := @ & Image (Token.Line_Region); Result := @ & ")"; end loop; Result := @ & ")"; end if; if Node.Augmented /= null and Augmented then Result := @ & Image_Augmented (Node.Augmented.all); end if; if (Node_Numbers and Node.Label = Nonterm) and then Node.Recover_Conflict then Append (Result, " recover_conflict"); end if; if Node.Error_List /= null then if Expecting then for Err of Node.Error_List.all loop Append (Result, ASCII.LF & " ERROR: " & Err.Image (Tree, Node)); end loop; else for Err of Node.Error_List.all loop Append (Result, ", " & Err.Class_Image & " ERROR"); end loop; end if; end if; if Node.Label = Source_Terminal and then Node.Following_Deleted.Length > 0 then Append (Result, (if Children then ASCII.LF & " " else "") & " deleted: " & Tree.Image (Node.Following_Deleted)); end if; Append (Result, ")"); return -Result; end; end if; exception when E : others => -- Tolerate corrupt tree, for debugging. if Debug_Mode then Tree.Lexer.Trace.Put_Line ("corrupt tree; " & Ada.Exceptions.Exception_Name (E) & ":" & Ada.Exceptions.Exception_Message (E)); Tree.Lexer.Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E)); end if; return Node.Node_Index'Image & ": corrupt tree; " & Ada.Exceptions.Exception_Name (E) & ":" & Ada.Exceptions.Exception_Message (E); end Image; function Image (Tree : in Syntax_Trees.Tree; Nodes : in Node_Access_Array; RHS_Index : in Boolean := False; Node_Numbers : in Boolean := False; Terminal_Node_Numbers : in Boolean := False; Line_Numbers : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False) return String is use Ada.Strings.Unbounded; Result : Unbounded_String := +"("; Need_Comma : Boolean := False; begin for I in Nodes'Range loop Result := Result & (if Need_Comma then ", " else "") & (if Nodes (I) = null then " - " else Tree.Image (Nodes (I), RHS_Index => RHS_Index, Node_Numbers => Node_Numbers, Terminal_Node_Numbers => Terminal_Node_Numbers, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar, Augmented => Augmented)); Need_Comma := True; end loop; Result := Result & ")"; return -Result; end Image; function Image (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; First_Terminal : in Boolean := False; Node_Numbers : in Boolean := False; Terminal_Node_Numbers : in Boolean := False; Line_Numbers : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Expecting : in Boolean := False) return String is use Stream_Element_Lists; begin if Ref.Element.Cur /= No_Element then declare Element_Node : constant Valid_Node_Access := Element (Ref.Element.Cur).Node; begin return "(" & Trimmed_Image (Tree.Streams (Ref.Stream.Cur).Label) & ", " & Image (Tree, Ref.Element, Node_Numbers => Node_Numbers, Terminal_Node_Numbers => Terminal_Node_Numbers, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar, Augmented => Augmented, Expecting => Expecting) & (if Ref.Node = Invalid_Node_Access or Element_Node.Label in Terminal_Label then "" elsif Element_Node.Label = Nonterm and Element_Node = Ref.Node and First_Terminal then ", " & Image (Tree, Tree.First_Terminal (Ref.Node), Node_Numbers => Node_Numbers, Terminal_Node_Numbers => Terminal_Node_Numbers, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar, Augmented => Augmented, Expecting => Expecting) else ", " & Image (Tree, Ref.Node, Node_Numbers => Node_Numbers, Terminal_Node_Numbers => True, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar, Augmented => Augmented)) & ")"; end; elsif Ref.Node /= Invalid_Node_Access then return "(" & Image (Tree, Ref.Node, Terminal_Node_Numbers => True, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar) & ")"; else return "()"; end if; end Image; function Input_Has_Matching_Error (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Data : in Error_Data'Class) return Boolean is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Error_Ref : Stream_Node_Parents := Tree.To_Stream_Node_Parents (if Parse_Stream.Stack_Top = Parse_Stream.Elements.Last then (Tree.Shared_Stream, (Cur => Parse_Stream.Shared_Link), Element (Parse_Stream.Shared_Link).Node) else (Stream, (Cur => Next (Parse_Stream.Stack_Top)), Element (Next (Parse_Stream.Stack_Top)).Node)); begin Tree.First_Terminal (Error_Ref, Following => False); if Error_Ref.Ref.Node = Invalid_Node_Access then -- Empty nonterm return False; end if; if Error_Ref.Ref.Node.Error_List = null then return False; else return (for some Err of Error_Ref.Ref.Node.Error_List.all => Dispatch_Equal (Err, Data)); end if; end Input_Has_Matching_Error; function Insert_After (User_Data : in out User_Data_Type; Tree : in Syntax_Trees.Tree'Class; Insert_Token : in Valid_Node_Access; Insert_Before_Token : in Valid_Node_Access; Comment_Present : in Boolean; Blank_Line_Present : in Boolean) return Insert_Location is pragma Unreferenced (User_Data, Tree, Insert_Token, Insert_Before_Token, Comment_Present, Blank_Line_Present); begin return Before_Next; end Insert_After; procedure Insert_Source_Terminal (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Terminal : in WisiToken.Lexer.Token; Before : in Stream_Index; Errors : in Error_Data_Lists.List) is New_Node : constant Valid_Node_Access := Add_Source_Terminal_1 (Tree, Terminal, In_Shared_Stream => Stream = Tree.Shared_Stream, Errors => Errors); begin Insert_Stream_Element (Tree, Stream, New_Node, Before => Before.Cur); end Insert_Source_Terminal; function Insert_Source_Terminal (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Terminal : in WisiToken.Lexer.Token; Before : in Stream_Index; Errors : in Error_Data_Lists.List) return Single_Terminal_Ref is New_Node : constant Valid_Node_Access := Add_Source_Terminal_1 (Tree, Terminal, In_Shared_Stream => Stream = Tree.Shared_Stream, Errors => Errors); begin return Insert_Stream_Element (Tree, Stream, New_Node, Before => Before.Cur); end Insert_Source_Terminal; procedure Insert_Stream_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Before : in Stream_Element_Lists.Cursor := Stream_Element_Lists.No_Element) is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin Parse_Stream.Elements.Insert (Element => (Node => Node, State => Unknown_State), Before => (if Before /= No_Element then Before else (if Parse_Stream.Stack_Top = No_Element then No_Element else Next (Parse_Stream.Stack_Top)))); end Insert_Stream_Element; function Insert_Stream_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Before : in Stream_Element_Lists.Cursor := Stream_Element_Lists.No_Element) return Rooted_Ref is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); New_Element : constant Cursor := Parse_Stream.Elements.Insert (Element => (Node => Node, State => Unknown_State), Before => (if Before /= No_Element then Before else (if Parse_Stream.Stack_Top = No_Element then No_Element else Next (Parse_Stream.Stack_Top)))); begin return (Stream, (Cur => New_Element), Node); end Insert_Stream_Element; function Insert_Virtual_Terminal (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Terminal : in Token_ID) return Single_Terminal_Ref is New_Node : constant Node_Access := new Node' (Label => Virtual_Terminal, Child_Count => 0, ID => Terminal, Node_Index => -(Tree.Nodes.Last_Index + 1), others => <>); begin Tree.Nodes.Append (New_Node); return Insert_Stream_Element (Tree, Stream, New_Node); end Insert_Virtual_Terminal; function Is_Descendant_Of (Tree : in Syntax_Trees.Tree; Root : in Valid_Node_Access; Descendant : in Valid_Node_Access) return Boolean is Node : Node_Access := Descendant; begin loop exit when Node = Invalid_Node_Access; if Node = Root then return True; end if; Node := Tree.Parent (Node); end loop; return False; end Is_Descendant_Of; function Is_Empty (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Streams.Length = 0 and Tree.Root = Invalid_Node_Access; end Is_Empty; function Is_Empty_Nonterm (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Boolean is begin return (case Item.Virtual is when True => Is_Nonterminal (Item.ID, Tree.Lexer.Descriptor.all) and Item.First_Terminal = Invalid_Node_Access, when False => Item.Node /= Invalid_Node_Access and then Tree.Is_Empty_Nonterm (Item.Node)); end Is_Empty_Nonterm; function Is_Empty_Nonterm (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return Node.Label = Nonterm and then Tree.First_Terminal (Node) = Invalid_Node_Access; end Is_Empty_Nonterm; function Is_Empty_Or_Virtual_Nonterm (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return Node.Label = Nonterm and then (Tree.First_Terminal (Node) = Invalid_Node_Access or else -- no terminals Length (Tree.Byte_Region (Node, Trailing_Non_Grammar => False)) = 0 -- all terminals are virtual ); end Is_Empty_Or_Virtual_Nonterm; function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Node.Label = Nonterm; end Is_Nonterm; function Is_Optimized_List (Productions : in Production_Info_Trees.Vector; ID : in Token_ID) return Boolean is begin if Productions.Is_Empty then return False; else return Productions (ID).Optimized_List; end if; end Is_Optimized_List; function Is_Source_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Node.Label = Source_Terminal; end Is_Source_Terminal; function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return Tree.Label (Node) in Terminal_Label; end Is_Terminal; function Is_Valid (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Boolean is pragma Unreferenced (Tree); begin return Parse_Stream_Lists.Has_Element (Stream.Cur); end Is_Valid; function Is_Virtual_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Node.Label = Virtual_Terminal; end Is_Virtual_Terminal; function Is_Virtual_Identifier (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is pragma Unreferenced (Tree); begin return Node.Label = Virtual_Identifier; end Is_Virtual_Identifier; function Label (Node : in Valid_Node_Access) return Node_Label is begin return Node.Label; end Label; function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Label is pragma Unreferenced (Tree); begin return Node.Label; end Label; function Label (Tree : in Syntax_Trees.Tree; Element : in Stream_Index) return Node_Label is pragma Unreferenced (Tree); begin return Stream_Element_Lists.Element (Element.Cur).Node.Label; end Label; function Last_Non_Grammar (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is -- We always use a Parents stack, to limit Prev_Terminal to -- descendants of Node. Parents : Node_Stacks.Stack; Result : Node_Access := Last_Terminal (Tree, Node, Parents); begin loop exit when Result = Invalid_Node_Access; exit when Result.Non_Grammar.Length > 0; Prev_Terminal (Tree, Result, Parents); end loop; return Result; end Last_Non_Grammar; function Last_Parse_Stream (Tree : in Syntax_Trees.Tree) return Stream_ID is begin return (Cur => Parse_Stream_Lists.Last (Tree.Streams)); end Last_Parse_Stream; function Last_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Parents : in out Node_Stacks.Stack) return Node_Access is Result : Node_Access := Tree.Last_Terminal (Node, Parents); begin loop exit when Result = Invalid_Node_Access; exit when Result.Sequential_Index /= Invalid_Sequential_Index; Tree.Prev_Terminal (Result, Parents); end loop; return Result; end Last_Sequential_Terminal; function Last_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in Node_Access) return Node_Access is Parents : Node_Stacks.Stack; begin return Tree.Last_Sequential_Terminal (Node, Parents); end Last_Sequential_Terminal; procedure Last_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Syntax_Trees.Stream_Node_Parents; Parse_Stream : in Stream_ID; Preceding : in Boolean) is begin Tree.Last_Terminal (Ref, Parse_Stream, Preceding); loop exit when Ref.Ref = Invalid_Stream_Node_Ref; exit when Ref.Ref.Node /= Invalid_Node_Access and then Tree.Get_Sequential_Index (Ref.Ref.Node) /= Invalid_Sequential_Index; Tree.Prev_Terminal (Ref, Parse_Stream, Preceding); exit when not Preceding and Ref.Ref.Node = Invalid_Node_Access; end loop; end Last_Sequential_Terminal; function Last_Source_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return Node_Access is -- We always use a Parents stack, to limit Prev_Terminal to -- descendants of Node. Parents : Node_Stacks.Stack; Result : Node_Access := Last_Terminal (Tree, Node, Parents); begin loop exit when Result = Invalid_Node_Access; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Result.Label) is when Source_Terminal => True, when Virtual_Terminal => Result.Non_Grammar.Length > 0, when Virtual_Identifier => Result.Non_Grammar.Length > 0) else Result.Label = Source_Terminal); Prev_Terminal (Tree, Result, Parents); end loop; return Result; end Last_Source_Terminal; procedure Last_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Trailing_Non_Grammar : in Boolean; Parse_Stream : in Stream_ID) is begin Ref.Ref.Node := Last_Terminal (Tree, Ref.Ref.Node, Ref.Parents); loop exit when Ref.Ref.Node /= Invalid_Node_Access and then (if Trailing_Non_Grammar then (case Terminal_Label'(Ref.Ref.Node.Label) is when Source_Terminal => True, when Virtual_Terminal => Ref.Ref.Node.Non_Grammar.Length > 0, when Virtual_Identifier => Ref.Ref.Node.Non_Grammar.Length > 0) else Ref.Ref.Node.Label = Source_Terminal); Prev_Terminal (Tree, Ref, Parse_Stream, Preceding => True); end loop; end Last_Source_Terminal; function Last_Terminal (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Node_Access is begin return (if Item.Virtual then Item.Last_Terminal else Last_Terminal (Tree, Item.Element_Node)); end Last_Terminal; function Last_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is begin case Node.Label is when Terminal_Label => return Node; when Nonterm => for C of reverse Node.Children loop -- Encountering a deleted child here is an error in the user algorithm. declare Term : constant Node_Access := Last_Terminal (Tree, C); begin if Term /= Invalid_Node_Access then return Term; end if; end; end loop; return Invalid_Node_Access; end case; end Last_Terminal; function Last_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Parents : in out Node_Stacks.Stack) return Node_Access is Parent_Depth : constant SAL.Base_Peek_Type := Parents.Depth; begin case Node.Label is when Terminal_Label => return Node; when Nonterm => for C of reverse Node.Children loop -- We tolerate null C here because this function is called while -- printing a tree for debug. if C /= Invalid_Node_Access then Parents.Push (Node); declare Last_Term : constant Node_Access := Last_Terminal (Tree, C, Parents); begin if Last_Term /= Invalid_Node_Access then return Last_Term; else Parents.Pop (Parents.Depth - Parent_Depth); -- discard parents from call to Last_Terminal. end if; end; end if; end loop; -- All children are empty return Invalid_Node_Access; end case; end Last_Terminal; procedure Last_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Parse_Stream : in Stream_ID; Preceding : in Boolean) is use Stream_Element_Lists; begin if Ref.Ref.Node = Invalid_Node_Access then -- Ref is an empty nonterm. null; else Ref.Ref.Node := Last_Terminal (Tree, Ref.Ref.Node, Ref.Parents); end if; if Preceding then loop exit when Ref.Ref.Node /= Invalid_Node_Access; Prev_Terminal (Tree, Ref, Parse_Stream, Preceding); exit when not Has_Element (Ref.Ref.Element.Cur); end loop; elsif Ref.Ref.Node = Invalid_Node_Access then Ref.Parents.Clear; end if; end Last_Terminal; procedure Left_Breakdown (Tree : in out Syntax_Trees.Tree; Ref : in out Stream_Node_Ref; User_Data : in Syntax_Trees.User_Data_Access_Constant) is -- [Wagner Graham 1998] doesn't modify the tree structure for -- Left_Breakdown; it just moves the Current_Token pointer around. -- That means the rest of the parser must understand that. -- -- Here we actually decompose the tree, as in [Lahav 2008]. Empty -- nonterms are handled by caller. -- -- Any errors on stream elements that are deleted along the way are -- moved to their First_Terminal, which is always the same node; the -- node that is the last promoted to the parse stream. use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Ref.Stream.Cur); Cur : Cursor := Ref.Element.Cur; To_Delete : Cursor := Cur; Node : Valid_Node_Access := Stream_Element_Lists.Element (Cur).Node; Next_I : Positive_Index_Type; First_Child : constant Positive_Index_Type := 1; -- preserve symmetry with Right_Breakdown New_Errors : Error_Data_Lists.List; begin Ref.Element.Cur := No_Element; -- Allow deleting via To_Delete. loop Next_I := Positive_Index_Type'Last; for I in reverse 2 .. Node.Child_Count loop if Node.Children (I).Child_Count > 0 or Node.Children (I).Label in Terminal_Label then Next_I := I; end if; Cur := Parse_Stream.Elements.Insert (Element => (Node => Node.Children (I), State => Unknown_State), Before => Cur); Node.Children (I).Parent := Invalid_Node_Access; -- We don't set node.children (I) to invalid here, because we need it -- if Next_I /= First_Child. end loop; Node.Children (First_Child).Parent := Invalid_Node_Access; if Node.Children (First_Child).Child_Count > 0 or Node.Children (First_Child).Label in Terminal_Label then Next_I := First_Child; else -- Node.Children (First_Child) is an empty nonterm; it has not -- been added to stream. if Next_I = Positive_Index_Type'Last then -- Node is an empty nonterm; move to first sibling below. null; else -- First non_empty is in Node.Children (Next_I); delete leading empty -- nonterms that were added to the stream. for I in First_Child + 1 .. Next_I - 1 loop declare To_Delete_2 : Cursor := Cur; begin Next (Cur); -- We do not set errors on empty nonterms. pragma Assert (Stream_Element_Lists.Element (To_Delete_2).Node.Error_List = null); Parse_Stream.Elements.Delete (To_Delete_2); end; end loop; pragma Assert (Element (Cur).Node = Node.Children (Next_I)); -- Delete the nonterm that we were breaking down, and record the one -- we are now breaking down for deletion. declare Node : constant Valid_Node_Access := Stream_Element_Lists.Element (To_Delete).Node; begin if Node.Error_List /= null then for Err of Tree.Error_List (Node) loop New_Errors.Append (To_Message (Err, Tree, Node)); end loop; end if; end; Parse_Stream.Elements.Delete (To_Delete); if Element (Cur).Node.Label = Nonterm then To_Delete := Cur; else -- ada_mode-interactive_04.adb To_Delete := No_Element; end if; end if; end if; declare Temp : constant Node_Access := Node; begin if Next_I = Positive_Index_Type'Last then -- Node is an empty nonterm; move to first sibling. Possibly similar -- to test_incremental.adb Recover_04. raise SAL.Not_Implemented with "FIXME: Syntax_Trees.Left_Breakdown move to next sibling."; else Node := Node.Children (Next_I); end if; -- Now we can clear the children of Temp (was Node). if Tree.Parents_Set then Temp.Children := (others => Invalid_Node_Access); end if; end; if Node.Label in Terminal_Label then if To_Delete = No_Element or else (To_Delete /= Cur and Next_I /= First_Child) then Ref.Element.Cur := Cur; else Ref.Element.Cur := Parse_Stream.Elements.Insert (Element => (Node => Node, State => Unknown_State), Before => Cur); Cur := No_Element; -- allow delete via To_Delete end if; Ref.Node := Node; if To_Delete /= No_Element then declare Node : constant Valid_Node_Access := Stream_Element_Lists.Element (To_Delete).Node; begin if Node.Error_List /= null then for Err of Tree.Error_List (Node) loop New_Errors.Append (To_Message (Err, Tree, Node)); end loop; end if; end; Parse_Stream.Elements.Delete (To_Delete); end if; exit; end if; end loop; if New_Errors.Length > 0 then Ref.Node := Add_Errors (Tree, Ref.Node, New_Errors, User_Data); Replace_Node (Ref.Element, Ref.Node); end if; end Left_Breakdown; function Lexable (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Streams.Length = 1 and (Tree.Shared_Stream.Cur /= Parse_Stream_Lists.No_Element and then Tree.Streams (Tree.Shared_Stream.Cur).Elements.Length = 1); end Lexable; function Line_At_Byte_Pos (Tree : in Syntax_Trees.Tree; Byte_Pos : in Buffer_Pos) return Base_Line_Number_Type is function Line_At_Byte_Pos (Node : in Valid_Node_Access; Start_Line : in WisiToken.Line_Number_Type) return Base_Line_Number_Type is Prev_Term : constant Valid_Node_Access := (if Node = Tree.Root then Tree.SOI elsif Node = Tree.SOI then Tree.SOI else Tree.Prev_Source_Terminal (Node, Trailing_Non_Grammar => True)); begin -- Byte_Pos can be in whitespace or non_grammar, so we construct the -- region to check from two successive terminals. We need line number -- information, so we find the prev/next terminals with new_lines in -- the token or non_grammar. case Node.Label is when Terminal_Label => declare Prev_New_Line : constant New_Line_Ref := Tree.Prev_New_Line (Node, Start_Line); Check_Region : constant Buffer_Region := (First => (if Node = Tree.SOI then Tree.Byte_Region (Tree.SOI, Trailing_Non_Grammar => True).First else Tree.Byte_Region (Prev_Term, Trailing_Non_Grammar => True).Last + 1), Last => (if Node = Tree.EOI then Node.Non_Grammar (1).Byte_Region.First else Tree.Byte_Region (Node, Trailing_Non_Grammar => True).Last)); function Check_Non_Grammar return Base_Line_Number_Type -- Return Invalid_Line_Number if Byte_Pos not in Node.Non_Grammar is begin if Node.Non_Grammar.Length > 0 and then Byte_Pos <= Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last then for Token of Node.Non_Grammar loop if Byte_Pos <= Token.Byte_Region.First then return Token.Line_Region.First; elsif Byte_Pos <= Token.Byte_Region.Last then return Tree.Lexer.Line_At_Byte_Pos (Token, Byte_Pos); end if; end loop; end if; return Invalid_Line_Number; end Check_Non_Grammar; begin pragma Assert (Prev_New_Line.Pos /= Invalid_Buffer_Pos); -- SOI if nothing else if not Contains (Check_Region, Byte_Pos) then return Invalid_Line_Number; else case Terminal_Label'(Node.Label) is when Virtual_Identifier | Virtual_Terminal => -- ada_mode-partial_parse.adb declare Temp : constant Base_Line_Number_Type := Check_Non_Grammar; begin if Temp = Invalid_Line_Number then return Prev_New_Line.Line; else return Temp; end if; end; when Source_Terminal => if Node = Tree.EOI then return Node.Non_Grammar (1).Line_Region.First; elsif Byte_Pos < Node.Byte_Region.First then -- In whitespace before token return Prev_New_Line.Line; elsif Byte_Pos <= Node.Byte_Region.Last then return Tree.Lexer.Line_At_Byte_Pos (Node.Byte_Region, Byte_Pos, First_Line => Prev_New_Line.Line); else declare Temp : constant Base_Line_Number_Type := Check_Non_Grammar; begin if Temp = Invalid_Line_Number then raise SAL.Programmer_Error; else return Temp; end if; end; end if; end case; end if; end; when Nonterm => declare First_Term : constant Node_Access := Tree.First_Source_Terminal (Node, Trailing_Non_Grammar => True, Following => False); Last_Term : constant Node_Access := Tree.Last_Source_Terminal (Node, Trailing_Non_Grammar => True); begin if First_Term = Invalid_Node_Access then -- Empty or all virtual return Invalid_Line_Number; elsif not Contains ((First => (if Node = Tree.Root then Tree.Byte_Region (Tree.SOI, Trailing_Non_Grammar => True).First else Tree.Byte_Region (Prev_Term, Trailing_Non_Grammar => True).Last + 1), Last => (if Last_Term = Tree.EOI then Last_Term.Non_Grammar (1).Byte_Region.First else Tree.Byte_Region (Last_Term, Trailing_Non_Grammar => True).Last)), Byte_Pos) then return Invalid_Line_Number; else for Child of Node.Children loop declare Temp : constant Base_Line_Number_Type := Line_At_Byte_Pos (Child, Start_Line => Tree.Prev_New_Line (Child, Start_Line).Line); begin if Temp = Invalid_Line_Number then -- Check next child null; else return Temp; end if; end; end loop; raise SAL.Programmer_Error; -- Contains said we'd find it. end if; end; end case; end Line_At_Byte_Pos; begin return Line_At_Byte_Pos (Tree.Root, Start_Line => Tree.SOI.Non_Grammar (1).Line_Region.First); end Line_At_Byte_Pos; function Line_At_Node (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Ref : in Real_Recover_Token) return Base_Line_Number_Type is function Find_Element return Stream_Index is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Cur : Cursor := Parse_Stream.Stack_Top; begin loop exit when not Has_Element (Cur); if Stream_Element_Lists.Element (Cur).Node = Ref.Element_Node then return (Cur => Cur); end if; Next (Cur); end loop; -- Not found in stream input; search stack. Cur := Parse_Stream.Stack_Top; loop Previous (Cur); exit when not Has_Element (Cur); if Stream_Element_Lists.Element (Cur).Node = Ref.Element_Node then return (Cur => Cur); end if; end loop; return Invalid_Stream_Index; end Find_Element; Element : constant Stream_Index := Find_Element; begin if Element = Invalid_Stream_Index then -- Ref.Node is a child of some stream Element; too hard to find. -- test_incremental.adb Lexer_Errors_05. return Invalid_Line_Number; else return Line_At_Node (Tree, Tree.To_Stream_Node_Parents (Tree.To_Rooted_Ref (Stream, Element)), Stream); end if; end Line_At_Node; function Line_At_Node (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Line_Number_Type is Temp : Valid_Node_Access := Node; New_Line_Count : Base_Line_Number_Type := 0; begin loop Temp := Tree.Prev_Terminal (Temp); exit when Temp.Non_Grammar.Length > 0; if Temp.Label = Source_Terminal then New_Line_Count := @ + Temp.New_Line_Count; end if; end loop; return Temp.Non_Grammar (Temp.Non_Grammar.Last_Index).Line_Region.Last + New_Line_Count; end Line_At_Node; function Line_At_Node (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Parents; Parse_Stream : in Stream_ID) return Line_Number_Type is Temp : Stream_Node_Parents := Ref; New_Line_Count : Base_Line_Number_Type := 0; begin loop Tree.Prev_Terminal (Temp, Parse_Stream, Preceding => True); exit when Temp.Ref.Node.Non_Grammar.Length > 0; if Temp.Ref.Node.Label = Source_Terminal then New_Line_Count := @ + Temp.Ref.Node.New_Line_Count; end if; end loop; return Temp.Ref.Node.Non_Grammar (Temp.Ref.Node.Non_Grammar.Last_Index).Line_Region.Last + New_Line_Count; end Line_At_Node; function Line_At_Node (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Parse_Stream : in Stream_ID) return Line_Number_Type is begin return Tree.Line_At_Node (Tree.To_Stream_Node_Parents (Ref), Parse_Stream); end Line_At_Node; function Line_Begin_Char_Pos (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type) return Buffer_Pos is Node : Node_Access := Tree.Root; Begin_Char_Pos : Buffer_Pos := Invalid_Buffer_Pos; begin if Line = Line_Number_Type'First then return Buffer_Pos'First; end if; Node := Find_New_Line (Tree, Line, Node, Begin_Char_Pos); return Begin_Char_Pos; end Line_Begin_Char_Pos; function Line_Begin_Char_Pos (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type; Stream : in Stream_ID) return Buffer_Pos is Begin_Char_Pos : Buffer_Pos := Invalid_Buffer_Pos; begin if Line = Line_Number_Type'First then return Buffer_Pos'First; end if; declare Ref : Stream_Node_Parents; begin Ref.Ref := Tree.Stream_First (Stream, Skip_SOI => False); Find_New_Line (Tree, Ref, Stream, Line, Begin_Char_Pos); if Ref.Ref.Node = Invalid_Node_Access then return Invalid_Buffer_Pos; else return Begin_Char_Pos; end if; end; end Line_Begin_Char_Pos; function Line_Begin_Token (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type) return Node_Access is begin declare Node : constant Node_Access := Tree.First_Non_Grammar (Root (Tree)); begin if Node = Invalid_Node_Access then -- Tree has no tokens with a Line_Region. Note that during LR parse, EOI -- is not in the tree, only in the parse stream. return Invalid_Node_Access; end if; if Line = Tree.Line_Region (Node, Trailing_Non_Grammar => True).First then return Node; elsif Line < Tree.Line_Region (Node, Trailing_Non_Grammar => True).First then return Invalid_Node_Access; end if; end; declare Begin_Char_Pos : Buffer_Pos; Node : Node_Access := Find_New_Line (Tree, Line, Root (Tree), Begin_Char_Pos); begin if Node = Invalid_Node_Access then -- Line is after EOI. return Invalid_Node_Access; elsif Node.ID = Tree.Lexer.Descriptor.EOI_ID then -- Find_New_Line allows both Line, Line - 1. if Node.Non_Grammar (Node.Non_Grammar.First_Index).Line_Region.First = Line then return Node; else return Invalid_Node_Access; end if; else -- Node now contains the non-grammar that ends Line - 1 if Empty_Line (Tree, Node.Non_Grammar, Line) then return Invalid_Node_Access; else Next_Terminal (Tree, Node); return Node; end if; end if; end; end Line_Begin_Token; function Line_Begin_Token (Tree : in Syntax_Trees.Tree; Line : in Line_Number_Type; Stream : in Stream_ID; Following_Source_Terminal : in Boolean) return Node_Access is Ref : Stream_Node_Parents; Begin_Char_Pos : Buffer_Pos; EOI_Line : constant Line_Number_Type := Tree.EOI.Non_Grammar (Tree.EOI.Non_Grammar.First).Line_Region.First; begin Ref.Ref := Stream_First (Tree, Stream, Skip_SOI => True); if Line = Line_Number_Type'First then if Line = Tree.Line_Region (Ref, Stream).First then return Tree.First_Terminal (Ref.Ref.Node); else if Following_Source_Terminal then Next_Source_Terminal (Tree, Ref, Trailing_Non_Grammar => False); return Ref.Ref.Node; else return Invalid_Node_Access; end if; end if; elsif Line = EOI_Line + 1 then return Tree.EOI; elsif Line > EOI_Line + 1 then return Invalid_Node_Access; end if; Find_New_Line (Tree, Ref, Stream, Line, Begin_Char_Pos); if Ref.Ref = Invalid_Stream_Node_Ref then return Invalid_Node_Access; else -- Ref now contains the non-grammar that ends Line - 1, or EOI. if Ref.Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID then -- test_incremental.adb Edit_String_10 return Invalid_Node_Access; elsif Empty_Line (Tree, Ref.Ref.Node.Non_Grammar, Line) then if Following_Source_Terminal then Next_Source_Terminal (Tree, Ref, Trailing_Non_Grammar => False); return Ref.Ref.Node; else return Invalid_Node_Access; end if; else Next_Terminal (Tree, Ref, Following => True); return Ref.Ref.Node; end if; end if; end Line_Begin_Token; procedure Line_Region_Internal_1 (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Prev_Non_Grammar : in Valid_Node_Access; Next_Non_Grammar : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean; First_Non_Grammar_Token : out WisiToken.Lexer.Token; Last_Non_Grammar_Token : out WisiToken.Lexer.Token; Last_Non_Grammar_Is_Node_Non_Grammar : out Boolean) is -- Since all non_grammar have line_region, we don't have to look for -- a new_line, just any non_grammar. -- -- We always have to find a previous and next non_grammar, to allow -- for multi-line tokens. -- -- The last few tokens in a nonterm may have no non_grammar; then we -- have to find the following Non_Grammar. Last_Non_Grammar : constant Syntax_Trees.Node_Access := (if Node = Invalid_Node_Access then Invalid_Node_Access else Tree.Last_Non_Grammar (Node)); Last_Terminal : constant Syntax_Trees.Node_Access := (if Node = Invalid_Node_Access then Invalid_Node_Access else Tree.Last_Terminal (Node)); Actual_Last_Non_Grammar : constant Syntax_Trees.Valid_Node_Access := (if Last_Non_Grammar = Invalid_Node_Access then Next_Non_Grammar elsif Last_Non_Grammar = Last_Terminal then Last_Non_Grammar else Next_Non_Grammar); begin First_Non_Grammar_Token := (if (Node = Tree.Root and Prev_Non_Grammar.ID = Tree.Lexer.Descriptor.SOI_ID) -- We are finding the line_region of wisi_accept in an Editable -- tree; we want to include the leading non_grammar in SOI. or Node.ID = Tree.Lexer.Descriptor.SOI_ID -- We are finding the line_region of SOI. then Prev_Non_Grammar.Non_Grammar (Prev_Non_Grammar.Non_Grammar.First_Index) else -- We are finding the line_region of a leading non_terminal; we don't -- want to include the leading non_grammar in SOI. Prev_Non_Grammar.Non_Grammar (Prev_Non_Grammar.Non_Grammar.Last_Index)); Last_Non_Grammar_Is_Node_Non_Grammar := Actual_Last_Non_Grammar = Last_Terminal; Last_Non_Grammar_Token := Actual_Last_Non_Grammar.Non_Grammar (if Trailing_Non_Grammar and Actual_Last_Non_Grammar = Last_Non_Grammar then Actual_Last_Non_Grammar.Non_Grammar.Last_Index else Actual_Last_Non_Grammar.Non_Grammar.First_Index); end Line_Region_Internal_1; function Line_Region_Internal (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Prev_Non_Grammar : in Valid_Node_Access; Next_Non_Grammar : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return WisiToken.Line_Region is First_Non_Grammar_Token : WisiToken.Lexer.Token; Last_Non_Grammar_Token : WisiToken.Lexer.Token; Last_Non_Grammar_Is_Node_Non_Grammar : Boolean; begin Line_Region_Internal_1 (Tree, Node, Prev_Non_Grammar, Next_Non_Grammar, Trailing_Non_Grammar, First_Non_Grammar_Token, Last_Non_Grammar_Token, Last_Non_Grammar_Is_Node_Non_Grammar); return (First => First_Non_Grammar_Token.Line_Region.Last, Last => (if Trailing_Non_Grammar and Last_Non_Grammar_Is_Node_Non_Grammar then Last_Non_Grammar_Token.Line_Region.Last else Last_Non_Grammar_Token.Line_Region.First)); end Line_Region_Internal; function Byte_Region_Of_Line_Region_Internal (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Prev_Non_Grammar : in Valid_Node_Access; Next_Non_Grammar : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return WisiToken.Buffer_Region is First_Non_Grammar_Token : WisiToken.Lexer.Token; Last_Non_Grammar_Token : WisiToken.Lexer.Token; Last_Non_Grammar_Is_Node_Non_Grammar : Boolean; begin Line_Region_Internal_1 (Tree, Node, Prev_Non_Grammar, Next_Non_Grammar, Trailing_Non_Grammar, First_Non_Grammar_Token, Last_Non_Grammar_Token, Last_Non_Grammar_Is_Node_Non_Grammar); return (First => First_Non_Grammar_Token.Byte_Region.Last, Last => (if Last_Non_Grammar_Is_Node_Non_Grammar then Last_Non_Grammar_Token.Byte_Region.Last else Last_Non_Grammar_Token.Byte_Region.First)); end Byte_Region_Of_Line_Region_Internal; function Line_Region (Tree : in Syntax_Trees.Tree) return WisiToken.Line_Region is begin return (First => Tree.SOI.Non_Grammar (1).Line_Region.First, Last => Tree.EOI.Non_Grammar (1).Line_Region.Last); end Line_Region; function Line_Region (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return WisiToken.Line_Region is Prev_Non_Grammar : constant Node_Access := Tree.Prev_Non_Grammar (Node); Next_Non_Grammar : constant Node_Access := Tree.Next_Non_Grammar (Node); begin if Prev_Non_Grammar = Invalid_Node_Access or Next_Non_Grammar = Invalid_Node_Access then -- Tolerate this because used in error messages. return Null_Line_Region; else return Line_Region_Internal (Tree, Node, Prev_Non_Grammar => Tree.Prev_Non_Grammar (Node), Next_Non_Grammar => Tree.Next_Non_Grammar (Node), Trailing_Non_Grammar => Trailing_Non_Grammar); end if; end Line_Region; function Line_Region (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Trailing_Non_Grammar : in Boolean) return WisiToken.Line_Region is begin return Line_Region (Tree, To_Stream_Node_Parents (Tree, Ref), Ref.Stream, Trailing_Non_Grammar); end Line_Region; function Byte_Region_Of_Line_Region (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return WisiToken.Buffer_Region is Prev_Non_Grammar : Stream_Node_Ref := Ref; Next_Non_Grammar : Stream_Node_Ref := Ref; begin Tree.Prev_Non_Grammar (Prev_Non_Grammar); Tree.Next_Non_Grammar (Next_Non_Grammar); return Byte_Region_Of_Line_Region_Internal (Tree, Ref.Node, Prev_Non_Grammar.Node, Next_Non_Grammar.Node, Trailing_Non_Grammar => True); end Byte_Region_Of_Line_Region; function Line_Region (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Parents; Parse_Stream : in Stream_ID; Trailing_Non_Grammar : in Boolean := True) return WisiToken.Line_Region is Prev_Non_Grammar : Stream_Node_Parents := Ref; Next_Non_Grammar : Stream_Node_Parents := Ref; begin Tree.Prev_Non_Grammar (Prev_Non_Grammar, Parse_Stream); Tree.Next_Non_Grammar (Next_Non_Grammar); return Line_Region_Internal (Tree, Ref.Ref.Node, Prev_Non_Grammar.Ref.Node, Next_Non_Grammar.Ref.Node, Trailing_Non_Grammar); end Line_Region; function Line_Region (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Ref : in Real_Recover_Token) return WisiToken.Line_Region is function Find_Element return Stream_Index is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Cur : Cursor := Parse_Stream.Stack_Top; begin loop exit when not Has_Element (Cur); if Stream_Element_Lists.Element (Cur).Node = Ref.Element_Node then return (Cur => Cur); end if; Next (Cur); end loop; -- Not found in stream input; search stack. Cur := Parse_Stream.Stack_Top; loop Previous (Cur); exit when not Has_Element (Cur); if Stream_Element_Lists.Element (Cur).Node = Ref.Element_Node then return (Cur => Cur); end if; end loop; return Invalid_Stream_Index; end Find_Element; Element : constant Stream_Index := Find_Element; begin if Element = Invalid_Stream_Index then return Null_Line_Region; else declare Ref_Parents : Stream_Node_Parents := (Ref => (Stream, Element, Get_Node (Element)), Parents => <>); begin Tree.First_Terminal (Ref_Parents, Following => True); return Line_Region (Tree, Ref_Parents, Stream, Trailing_Non_Grammar => True); end; end if; end Line_Region; function Make_Rooted (Item : in Recover_Token) return Recover_Token is begin if Item.Virtual then return Item; elsif Item.Element_Node = Item.Node then return Item; else return (Virtual => False, Element_Node => Item.Element_Node, Node => Item.Element_Node); end if; end Make_Rooted; type Augmented_In_Tree is new Base_Augmented with record I : Integer; end record; Aug_In_Tree : constant Augmented_In_Tree := (Base_Augmented with 1); procedure Mark_In_Tree (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Data : in User_Data_Access; Node_Error_Reported : in out Boolean) is pragma Unreferenced (Data, Node_Error_Reported); begin if Node.Augmented /= null then raise SAL.Programmer_Error with (if Node.Augmented.all in Augmented_In_Tree then "Mark_In_Tree called twice on node " & Tree.Image (Node, Node_Numbers => True) else "Mark_In_Tree called with Augmented already set"); end if; Node.Augmented := new Augmented_In_Tree'(Aug_In_Tree); if Node.Label = Source_Terminal then for N of Node.Following_Deleted loop N.Augmented := new Augmented_In_Tree'(Aug_In_Tree); end loop; end if; end Mark_In_Tree; procedure Move_Element (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Ref : in out Stream_Node_Parents; New_Node : in Valid_Node_Access; User_Data : in User_Data_Access_Constant) -- Move Ref to Stream, replacing Ref.Node with New_Node, -- copying all ancestors. Update Ref to point to new stream element -- with copied nodes. is -- We don't use Move_Shared_To_Input, because that doesn't deep copy the -- node. Orig_Element_Node : constant Valid_Node_Access := Get_Node (Ref.Ref.Element); Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin if Ref.Ref.Stream /= Stream then declare New_Element : constant Stream_Element_Lists.Cursor := Parse_Stream.Elements.Insert (Element => (Node => (if Orig_Element_Node = Ref.Ref.Node then New_Node else Copy_Node (Tree, Orig_Element_Node, Parent => Invalid_Node_Access, User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => True)), State => Unknown_State), Before => Stream_Element_Lists.Next (Parse_Stream.Stack_Top)); begin if Ref.Ref.Stream = Tree.Shared_Stream and then Ref.Ref.Element.Cur = Parse_Stream.Shared_Link then Stream_Element_Lists.Next (Parse_Stream.Shared_Link); end if; -- Don't set Ref.Ref.Node yet; needed by Copy_Ancestors below. Ref.Ref.Stream := Stream; Ref.Ref.Element.Cur := New_Element; if Ref.Parents.Depth > 0 then Ref.Parents.Set (Index => Ref.Parents.Depth, Depth => Ref.Parents.Depth, Element => Get_Node (Ref.Ref.Element)); end if; end; elsif Orig_Element_Node = Ref.Ref.Node then Replace_Node (Ref.Ref.Element, New_Node); end if; if Orig_Element_Node = Ref.Ref.Node then Ref.Ref.Node := New_Node; else -- Edit child links in ancestors, update Ref.Parents to match. Copy_Ancestors (Tree, Ref, New_Node, User_Data); end if; end Move_Element; procedure Move_Shared_To_Input (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID) is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Before : constant Cursor := Next (Parse_Stream.Stack_Top); begin Parse_Stream.Elements.Insert (Element => (Node => Element (Parse_Stream.Shared_Link).Node, State => Unknown_State), Before => Before); Next (Parse_Stream.Shared_Link); end Move_Shared_To_Input; procedure Move_Shared_To_Input (Tree : in out Syntax_Trees.Tree; First : in Stream_Node_Ref; Last : in Stream_Node_Ref; Stream : in Stream_ID) is use Stream_Element_Lists; Temp : Stream_Node_Ref := First; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Before : constant Cursor := Next (Parse_Stream.Stack_Top); begin loop Parse_Stream.Elements.Insert (Element => (Node => Element (Temp.Element.Cur).Node, State => Unknown_State), Before => Before); exit when Temp.Element = Last.Element; Tree.Stream_Next (Temp, Rooted => True); end loop; Tree.Stream_Next (Temp, Rooted => True); Parse_Stream.Shared_Link := Temp.Element.Cur; end Move_Shared_To_Input; function Name (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Buffer_Region is begin if Item.Virtual then if Item.Name = Null_Buffer_Region then if Item.First_Terminal = Invalid_Node_Access or else Tree.Byte_Region (Item.First_Terminal, Trailing_Non_Grammar => False) = Null_Buffer_Region then return Null_Buffer_Region; else if Item.First_Terminal = Invalid_Node_Access or else Tree.Byte_Region (Item.Last_Terminal, Trailing_Non_Grammar => False) = Null_Buffer_Region then return Null_Buffer_Region; else return (Tree.Byte_Region (Item.First_Terminal, Trailing_Non_Grammar => False).First, Tree.Byte_Region (Item.Last_Terminal, Trailing_Non_Grammar => False).Last); end if; end if; else return Item.Name; end if; else return Tree.Name (Item.Element_Node); end if; end Name; function Name (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Buffer_Region is begin case Node.Label is when Nonterm => if Node.Name_Length = 0 then return Tree.Byte_Region (Node, Trailing_Non_Grammar => False); else declare First_Terminal : constant Node_Access := Tree.First_Terminal (Node); Byte_First : constant Buffer_Pos := Tree.Byte_Region (First_Terminal, Trailing_Non_Grammar => False).First; begin return (Byte_First + Node.Name_Offset, Byte_First + Node.Name_Offset + Node.Name_Length - 1); end; end if; when Source_Terminal => return Node.Byte_Region; when Virtual_Terminal_Label => return Null_Buffer_Region; end case; end Name; function Name (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Buffer_Region is begin -- We use the Element node because the nonterminal has the most valid Name. return Tree.Name (Stream_Element_Lists.Element (Ref.Element.Cur).Node); end Name; overriding function Next (Object : Error_Iterator; Position : Error_Ref) return Error_Ref is begin return Result : Error_Ref := Position do Object.Tree.Next_Error (Result); end return; end Next; overriding function Next (Object : Stream_Error_Iterator; Position : Stream_Error_Cursor) return Stream_Error_Cursor is begin return Result : Stream_Error_Cursor := Position do Object.Tree.Next_Error (Result.SER); end return; end Next; procedure Next_Error (Tree : in Syntax_Trees.Tree; Error : in out Error_Ref) is pragma Unreferenced (Tree); use Valid_Node_Access_Lists; use Error_Data_Lists; begin if Has_Element (Error.Error) then Next (Error.Error); end if; if Has_Element (Error.Error) then return; end if; if Has_Element (Error.Deleted) then Next (Error.Deleted); if not Has_Element (Error.Deleted) then Next_Node (Error.Node); end if; First_Error (Error); else if Error.Node.Error_List = null then if Error.Node.Label = Source_Terminal then Error.Deleted := Error.Node.Following_Deleted.First; else Next_Node (Error.Node); if Error.Node = Invalid_Node_Access then -- No more errors. return; end if; end if; First_Error (Error); else if Has_Element (Error.Error) then Next (Error.Error); end if; if not Has_Element (Error.Error) then if Error.Node.Label = Source_Terminal then Error.Deleted := Error.Node.Following_Deleted.First; if not Has_Element (Error.Deleted) then Next_Node (Error.Node); end if; else Next_Node (Error.Node); end if; if Error.Node = Invalid_Node_Access then -- No more errors. return; end if; First_Error (Error); end if; end if; end if; end Next_Error; procedure Next_Error (Tree : in Syntax_Trees.Tree; Error : in out Stream_Error_Ref) is use Valid_Node_Access_Lists; use Error_Data_Lists; begin if Has_Element (Error.Error) then Next (Error.Error); end if; if Has_Element (Error.Error) then return; end if; if Has_Element (Error.Deleted) then Next (Error.Deleted); if not Has_Element (Error.Deleted) then Next_Node (Tree, Error.Ref); end if; First_Error (Tree, Error); else if Error.Ref.Ref.Node.Error_List = null then if Error.Ref.Ref.Node.Label = Source_Terminal then Error.Deleted := Error.Ref.Ref.Node.Following_Deleted.First; else Next_Node (Tree, Error.Ref); if Error.Ref.Ref.Node = Invalid_Node_Access then -- No more errors. return; end if; end if; First_Error (Tree, Error); else if Has_Element (Error.Error) then Next (Error.Error); end if; if not Has_Element (Error.Error) then if Error.Ref.Ref.Node.Label = Source_Terminal then Error.Deleted := Error.Ref.Ref.Node.Following_Deleted.First; if not Has_Element (Error.Deleted) then Next_Node (Tree, Error.Ref); end if; else Next_Node (Tree, Error.Ref); end if; if Error.Ref.Ref.Node = Invalid_Node_Access then -- No more errors. return; end if; First_Error (Tree, Error); end if; end if; end if; end Next_Error; procedure Next_New_Line (Tree : in Syntax_Trees.Tree; Start_Ref : in Terminal_Ref; After_Non_Grammar : in Positive_Index_Type; Result_Ref : out Terminal_Ref; Result_Non_Grammar : out Positive_Index_Type) is Index : Lexer.Token_Arrays.Extended_Index := After_Non_Grammar; begin Result_Ref := Start_Ref; loop Next_Non_Grammar : loop if Index /= Lexer.Token_Arrays.No_Index and Index < Result_Ref.Node.Non_Grammar.Last_Index then Index := @ + 1; else Next_Terminal (Tree, Result_Ref); if Result_Ref.Node.Non_Grammar.Length > 0 then Index := Result_Ref.Node.Non_Grammar.First_Index; exit Next_Non_Grammar; else Index := Lexer.Token_Arrays.No_Index; end if; end if; end loop Next_Non_Grammar; exit when Result_Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID or Contains_New_Line (Result_Ref.Node.Non_Grammar (Index).Line_Region); end loop; Result_Non_Grammar := Index; end Next_New_Line; procedure Next_Node (Node : in out Node_Access) is procedure Next_Sibling is begin loop if Node.Parent = Invalid_Node_Access then Node := Invalid_Node_Access; return; else declare Child_Index : constant Positive_Index_Type := Syntax_Trees.Child_Index (Node.Parent.all, Node); begin if Child_Index = Node.Parent.Child_Count then Node := Node.Parent; else Node := Node.Parent.Children (Child_Index + 1); exit; end if; end; end if; end loop; end Next_Sibling; begin case Node.Label is when Terminal_Label => Next_Sibling; when Nonterm => if Node.Child_Count > 0 then Node := Node.Children (1); else Next_Sibling; end if; end case; end Next_Node; procedure Next_Node (Tree : in Syntax_Trees.Tree; Node : in out Stream_Node_Parents) is procedure Next_Sibling is begin loop if Node.Parents.Depth = 0 then if Node.Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID then Node.Ref := Invalid_Stream_Node_Ref; return; else Stream_Next (Tree, Node.Ref, Rooted => True); return; end if; else declare Child_Index : constant Positive_Index_Type := Syntax_Trees.Child_Index (Node.Parents.Peek.all, Node.Ref.Node); begin if Child_Index = Node.Parents.Peek.Child_Count then Node.Ref.Node := Node.Parents.Pop; else Node.Ref.Node := Node.Parents.Peek.Children (Child_Index + 1); exit; end if; end; end if; end loop; end Next_Sibling; begin case Node.Ref.Node.Label is when Terminal_Label => Next_Sibling; when Nonterm => if Node.Ref.Node.Child_Count > 0 then Node.Parents.Push (Node.Ref.Node); Node.Ref.Node := Node.Ref.Node.Children (1); else Next_Sibling; end if; end case; end Next_Node; function Next_Non_Grammar (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Valid_Node_Access is Result : Node_Access := Node; begin if Node.ID = Tree.Lexer.Descriptor.EOI_ID then return Node; elsif Node = Tree.Root then return Tree.EOI; end if; loop Result := Next_Terminal (Tree, Result); exit when Result.Non_Grammar.Length > 0; end loop; return Result; end Next_Non_Grammar; procedure Next_Non_Grammar (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref) is begin if Ref.Node /= Invalid_Node_Access and then Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID then return; end if; loop Next_Terminal (Tree, Ref); exit when Ref.Node = Invalid_Node_Access; exit when Ref.Node.Non_Grammar.Length > 0; end loop; end Next_Non_Grammar; procedure Next_Non_Grammar (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents) is begin if Ref.Ref.Node /= Invalid_Node_Access and then Ref.Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID then return; end if; loop Next_Terminal (Tree, Ref, Following => True); exit when Ref.Ref.Node = Invalid_Node_Access; exit when Ref.Ref.Node.Non_Grammar.Length > 0; end loop; end Next_Non_Grammar; procedure Next_Nonterm (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref) is procedure Next_Sibling is begin loop if Ref.Node.Parent = Invalid_Node_Access then loop Stream_Next (Tree, Ref, Rooted => True); if Ref = Invalid_Stream_Node_Ref then return; elsif Ref.Node.ID = Tree.Lexer.Descriptor.EOI_ID then Ref := Invalid_Stream_Node_Ref; return; elsif Ref.Node.Label = Nonterm then return; else null; end if; end loop; else declare Child_Index : constant Positive_Index_Type := Syntax_Trees.Child_Index (Ref.Node.Parent.all, Ref.Node); begin if Child_Index = Ref.Node.Parent.Child_Count then Ref.Node := Ref.Node.Parent; else for I in Child_Index + 1 .. Ref.Node.Parent.Child_Count loop if Ref.Node.Parent.Children (I).ID = Tree.Lexer.Descriptor.EOI_ID then Ref := Invalid_Stream_Node_Ref; return; elsif Ref.Node.Parent.Children (I).Label = Nonterm then Ref.Node := Ref.Node.Parent.Children (I); return; end if; end loop; Ref.Node := Ref.Node.Parent; end if; end; end if; end loop; end Next_Sibling; begin case Ref.Node.Label is when Terminal_Label => Next_Sibling; when Nonterm => if Ref.Node.Child_Count > 0 then for N of Ref.Node.Children loop if N.ID = Tree.Lexer.Descriptor.EOI_ID then Ref := Invalid_Stream_Node_Ref; return; elsif N.Label = Nonterm then Ref.Node := N; return; end if; end loop; end if; Next_Sibling; end case; end Next_Nonterm; procedure Next_Parse_Stream (Tree : in Syntax_Trees.Tree; Stream : in out Stream_ID) is begin Parse_Stream_Lists.Next (Stream.Cur); end Next_Parse_Stream; procedure Next_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access; Parents : in out Node_Stacks.Stack) is begin loop Next_Terminal (Tree, Node, Parents); exit when Node = Invalid_Node_Access; exit when Node.Sequential_Index /= Invalid_Sequential_Index; end loop; end Next_Sequential_Terminal; procedure Next_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Syntax_Trees.Stream_Node_Ref) is begin loop Next_Terminal (Tree, Ref); exit when Ref.Node = Invalid_Node_Access; exit when Ref.Node.Sequential_Index /= Invalid_Sequential_Index; end loop; end Next_Sequential_Terminal; procedure Next_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Syntax_Trees.Stream_Node_Parents; Following : in Boolean) is begin loop Next_Terminal (Tree, Ref, Following); exit when Ref.Ref.Node = Invalid_Node_Access; exit when Ref.Ref.Node.Sequential_Index /= Invalid_Sequential_Index; end loop; end Next_Sequential_Terminal; function Next_Source_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return Node_Access is Result : Node_Access := Next_Terminal (Tree, Node); begin loop exit when Result = Invalid_Node_Access; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Result.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Result.Non_Grammar.Length > 0) else Result.Label = Source_Terminal); Next_Terminal (Tree, Result); end loop; return Result; end Next_Source_Terminal; function Next_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Trailing_Non_Grammar : in Boolean) return Stream_Node_Ref is begin return Result : Stream_Node_Ref := Next_Terminal (Tree, Ref) do loop exit when Result = Invalid_Stream_Node_Ref; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Result.Node.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Result.Node.Non_Grammar.Length > 0) else Result.Node.Label = Source_Terminal); Next_Terminal (Tree, Result); end loop; end return; end Next_Source_Terminal; procedure Next_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref; Trailing_Non_Grammar : in Boolean) is begin loop Next_Terminal (Tree, Ref); exit when Ref = Invalid_Stream_Node_Ref; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Ref.Node.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Ref.Node.Non_Grammar.Length > 0) else Ref.Node.Label = Source_Terminal); end loop; end Next_Source_Terminal; procedure Next_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Trailing_Non_Grammar : in Boolean) is begin loop Next_Terminal (Tree, Ref, Following => True); exit when Ref.Ref = Invalid_Stream_Node_Ref; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Ref.Ref.Node.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Ref.Ref.Node.Non_Grammar.Length > 0) else Ref.Ref.Node.Label = Source_Terminal); end loop; end Next_Source_Terminal; function Next_Stream_ID_Trimmed_Image (Tree : in Syntax_Trees.Tree) return String is begin return Trimmed_Image (Tree.Next_Stream_Label); end Next_Stream_ID_Trimmed_Image; procedure Next_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access) is begin Node := Next_Terminal (Tree, Node); end Next_Terminal; function Next_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is pragma Unreferenced (Tree); function First_Child (Node : in Valid_Node_Access) return Node_Access is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => return Node; when Nonterm => -- Use first non-empty for J of Node.Children loop -- We tolerate deleted children here for edited trees. if J /= Invalid_Node_Access then declare Result : constant Node_Access := First_Child (J); begin if Result /= Invalid_Node_Access then return Result; end if; end; end if; end loop; -- All Children are empty return Invalid_Node_Access; end case; end First_Child; function Next_Child (Child : in Valid_Node_Access; Parent : in Node_Access) return Node_Access is begin -- Parent is parent of Child; return node immediately after Child. if Parent = Invalid_Node_Access then return Invalid_Node_Access; else case Parent.Label is when Source_Terminal => -- Child is in Parent.Following_Deleted. return Next_Child (Parent, Parent.Parent); when Nonterm => -- Normal tree node for I in Parent.Children'Range loop if Parent.Children (I) = Child then -- Use first non-empty next from I + 1. for J in I + 1 .. Parent.Children'Last loop -- We tolerate deleted children here for edited trees. if Parent.Children (J) /= Invalid_Node_Access then declare Result : constant Node_Access := First_Child (Parent.Children (J)); begin if Result /= Invalid_Node_Access then return Result; end if; end; end if; end loop; -- All next Children are empty return Next_Child (Parent, Parent.Parent); end if; end loop; raise SAL.Programmer_Error; -- Child not found in Node.Children when others => raise SAL.Programmer_Error; end case; end if; end Next_Child; begin return Next_Child (Node, Node.Parent); end Next_Terminal; procedure Next_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access; Parents : in out Node_Stacks.Stack) is pragma Unreferenced (Tree); function First_Child (Node : in Valid_Node_Access) return Node_Access is begin case Node.Label is when Terminal_Label => return Node; when Nonterm => -- Use first non-empty Parents.Push (Node); for J of Node.Children loop -- Encountering a deleted child here is an error in the user -- algorithm. declare Result : constant Node_Access := First_Child (J); begin if Result /= Invalid_Node_Access then return Result; end if; end; end loop; -- All Children are empty Parents.Pop; return Invalid_Node_Access; end case; end First_Child; function Next_Child (Child : in Valid_Node_Access; Parent : in Valid_Node_Access) return Node_Access is Parent_Depth : constant SAL.Base_Peek_Type := Parents.Depth; begin -- Parent is Parent of Child; return node immediately after Child. pragma Assert (Parent.Label = Nonterm); for I in Parent.Children'Range loop -- Encountering a deleted child here is an error in the user -- algorithm. if Parent.Children (I) = Child then -- Use first non-empty from I + 1. for J in I + 1 .. Parent.Children'Last loop Parents.Push (Parent); declare Result : constant Node_Access := First_Child (Parent.Children (J)); begin if Result /= Invalid_Node_Access then return Result; else Parents.Pop (Parents.Depth - Parent_Depth); -- discard parents from call to First_Child. end if; end; end loop; -- All next Children are empty (or there are none); move to -- next cousin. if Parents.Is_Empty then return Invalid_Node_Access; else return Next_Child (Parent, Parents.Pop); end if; end if; end loop; raise SAL.Programmer_Error; -- Child not found in Node.Children end Next_Child; begin if Parents.Is_Empty then Node := Invalid_Node_Access; else Node := Next_Child (Node, Parents.Pop); end if; end Next_Terminal; procedure Next_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Terminal_Ref) is use Stream_Element_Lists; begin loop -- Handle empty Elements if Element (Ref.Element.Cur).Node.Label in Terminal_Label or else Ref.Node = Invalid_Node_Access -- A previous Stream_Next arrived at an empty nonterm, or -- Next_Terminal reached the end of an element node. then Stream_Next (Tree, Ref, Rooted => False); exit when Ref.Element = Invalid_Stream_Index; else Ref.Node := Next_Terminal (Tree, Ref.Node); end if; exit when Ref.Node /= Invalid_Node_Access; end loop; end Next_Terminal; function Next_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Terminal_Ref) return Terminal_Ref is begin return Result : Terminal_Ref := Ref do Next_Terminal (Tree, Result); end return; end Next_Terminal; procedure Next_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Following : in Boolean) is use Stream_Element_Lists; begin loop -- Handle empty Elements if Element (Ref.Ref.Element.Cur).Node.Label in Terminal_Label or else -- Can only be true on the first loop Ref.Ref.Node = Invalid_Node_Access -- The previous loop reached the end of an element node. then if Following then Stream_Next (Tree, Ref, Rooted => False); else Ref.Ref.Node := Invalid_Node_Access; Ref.Parents.Clear; exit; end if; exit when Ref.Ref.Element = Invalid_Stream_Index; -- end of stream exit when Ref.Ref.Node /= Invalid_Node_Access and then Ref.Ref.Node.Label in Terminal_Label; else Next_Terminal (Tree, Ref.Ref.Node, Ref.Parents); exit when Ref.Ref.Node /= Invalid_Node_Access; end if; end loop; end Next_Terminal; function New_Stream (Tree : in out Syntax_Trees.Tree) return Stream_ID is begin return Result : constant Stream_ID := (Cur => Tree.Streams.Append ((Label => Tree.Next_Stream_Label, Stack_Top => Invalid_Stream_Index.Cur, Shared_Link => Tree.Stream_First (Tree.Shared_Stream, Skip_SOI => True).Element.Cur, Elements => <>))) do -- WORKAROUND: This is broken by gnat 13; ada-mode -- test/ada_mode-function_2.adb fails with a ref_count error. Tree.Enable_Ref_Count_Check (Result, Enable => False); Tree.Next_Stream_Label := @ + 1; end return; end New_Stream; function New_Stream (Tree : in out Syntax_Trees.Tree; Old_Stream : in Stream_ID) return Stream_ID is begin if Old_Stream = Invalid_Stream_ID then return New_Stream (Tree); else declare Old_Parse_Stream : Parse_Stream renames Tree.Streams (Old_Stream.Cur); Old_Stack_Top : constant Stream_Element_Lists.Cursor := Old_Parse_Stream.Stack_Top; Result_Cur : constant Parse_Stream_Lists.Cursor := Tree.Streams.Append ((Label => Tree.Next_Stream_Label, Stack_Top => Invalid_Stream_Index.Cur, Shared_Link => Old_Parse_Stream.Shared_Link, Elements => <>)); New_Stream : Parse_Stream renames Tree.Streams (Result_Cur); New_Cur : Stream_Element_Lists.Cursor; Old_Cur : Stream_Element_Lists.Cursor := Old_Parse_Stream.Elements.First; use Stream_Element_Lists; begin loop exit when not Has_Element (Old_Cur); declare Old_Element : constant Stream_Element := Element (Old_Cur); New_Node : constant Node_Access := Old_Element.Node; -- We do not deep copy any nodes for the new stream; they are all -- shared with other streams. begin New_Cur := New_Stream.Elements.Append ((Node => New_Node, State => Old_Element.State)); end; if Old_Cur = Old_Stack_Top then New_Stream.Stack_Top := New_Cur; end if; Next (Old_Cur); end loop; Tree.Next_Stream_Label := @ + 1; return (Cur => Result_Cur); end; end if; end New_Stream; function Node_Access_Compare (Left, Right : in Node_Access) return SAL.Compare_Result is -- Within one batch parsed subtree, positive and negative -- Node_Indices are separately unique. Positive Node_Index first, abs -- value for wisitoken_grammar_editing.translate_EBNF_to_BNF. (if Left.Node_Index > 0 and Right.Node_Index <= 0 then SAL.Less elsif Left.Node_Index <= 0 and Right.Node_Index > 0 then SAL.Greater elsif abs Left.Node_Index > abs Right.Node_Index then SAL.Greater elsif abs Left.Node_Index < abs Right.Node_Index then SAL.Less else SAL.Equal); function Node_ID (Tree : in Syntax_Trees.Tree; Item : in Recover_Token) return Token_ID is pragma Unreferenced (Tree); begin return Item.Node.ID; end Node_ID; function Non_Grammar_Var (Tree : in Syntax_Trees.Tree; Terminal : in Valid_Node_Access) return Token_Array_Var_Ref is pragma Unreferenced (Tree); begin return (Element => (case Terminal.Label is when Terminal_Label => Terminal.Non_Grammar'Access, when others => raise SAL.Programmer_Error), Dummy => 0); end Non_Grammar_Var; function Non_Grammar_Const (Terminal : in Valid_Node_Access) return Token_Array_Const_Ref is begin return (Element => (case Terminal.Label is when Terminal_Label => Terminal.Non_Grammar'Access, when others => raise SAL.Programmer_Error), Dummy => 0); end Non_Grammar_Const; function Non_Grammar_Const (Tree : in Syntax_Trees.Tree; Terminal : in Valid_Node_Access) return Token_Array_Const_Ref is pragma Unreferenced (Tree); begin return Non_Grammar_Const (Terminal); end Non_Grammar_Const; function Parent (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Count : in Positive := 1) return Node_Access is pragma Unreferenced (Tree); Result : Node_Access := Node; N : Natural := 0; begin loop Result := Result.Parent; N := N + 1; exit when N = Count or Result = Invalid_Node_Access; end loop; return Result; end Parent; function Parents_Set (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Parents_Set; end Parents_Set; function Parents_Valid (Ref : in Stream_Node_Parents) return Boolean is begin return (Ref.Ref.Element = Invalid_Stream_Index and Ref.Ref.Node = Invalid_Node_Access) or else ((Stream_Element_Lists.Element (Ref.Ref.Element.Cur).Node = Ref.Ref.Node or Ref.Ref.Node = Invalid_Node_Access) and Ref.Parents.Is_Empty) or else (Ref.Parents.Depth > 0 and then (for all Item of Ref.Parents => Item /= Invalid_Node_Access and then Item.Label = Nonterm) and then (Ref.Parents.Peek (Ref.Parents.Depth) = Stream_Element_Lists.Element (Ref.Ref.Element.Cur).Node and -- we don't check the intervening parent items. (for some Child of Ref.Parents.Peek.Children => Child = Ref.Ref.Node))); end Parents_Valid; function Parseable (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Streams.Length = 1; end Parseable; function Peek (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Count : in SAL.Peek_Type := 1) return Stream_Index is use Stream_Element_Lists; Result : Cursor := Tree.Streams (Stream.Cur).Stack_Top; begin for I in 1 .. Count - 1 loop Result := Previous (@); end loop; return (Cur => Result); end Peek; function Pop (Parse_Stream : in out Syntax_Trees.Parse_Stream) return Valid_Node_Access is use Stream_Element_Lists; Temp : Cursor := Parse_Stream.Stack_Top; begin return Result : constant Valid_Node_Access := Element (Parse_Stream.Stack_Top).Node do Previous (Parse_Stream.Stack_Top); Parse_Stream.Elements.Delete (Temp); -- This does not change Parse_Stream.Shared_Link end return; end Pop; function Pop (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID) return Valid_Node_Access is begin return Pop (Tree.Streams (Stream.Cur)); end Pop; function Prev_New_Line (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Start_Line : in Base_Line_Number_Type := Invalid_Line_Number) return New_Line_Ref is Prev : Node_Access := Tree.Prev_Terminal (Node); Actual_Start_Line : Line_Number_Type; function SOI_New_Line_Ref return New_Line_Ref is begin return (Node => Tree.SOI, Non_Grammar_Index => 1, First => False, Pos => Tree.SOI.Non_Grammar (1).Byte_Region.First, Line => Tree.SOI.Non_Grammar (1).Line_Region.First); end SOI_New_Line_Ref; function Prev_New_Line_Ref (Index : in SAL.Peek_Type) return New_Line_Ref is begin return (Node => Prev, Non_Grammar_Index => Index, First => False, Pos => Tree.Lexer.Contains_New_Line (Prev.Non_Grammar (Index).Byte_Region, First => False), Line => Prev.Non_Grammar (Index).Line_Region.Last); end Prev_New_Line_Ref; begin if Start_Line = Invalid_Line_Number then declare New_Line_Count : Base_Line_Number_Type := 0; begin if Prev = Invalid_Node_Access then return SOI_New_Line_Ref; end if; loop exit when Prev.Non_Grammar.Length > 0; New_Line_Count := @ + Prev.New_Line_Count; Prev_Terminal (Tree, Prev); end loop; Actual_Start_Line := Prev.Non_Grammar (Prev.Non_Grammar.Last_Index).Line_Region.Last + New_Line_Count; Prev := Tree.Prev_Terminal (Node); end; else Actual_Start_Line := Start_Line; end if; loop if Prev = Invalid_Node_Access then return SOI_New_Line_Ref; elsif Prev = Tree.SOI then for I in reverse Prev.Non_Grammar.First_Index + 1 .. Prev.Non_Grammar.Last_Index loop if New_Line_Count (Prev.Non_Grammar (I).Line_Region) > 0 then return Prev_New_Line_Ref (I); end if; end loop; return SOI_New_Line_Ref; else case Terminal_Label'(Prev.Label) is when Virtual_Identifier | Virtual_Terminal => for I in reverse Prev.Non_Grammar.First_Index .. Prev.Non_Grammar.Last_Index loop -- ada_mode-interactive_01.adb if Prev.Non_Grammar (I).ID = Tree.Lexer.Descriptor.New_Line_ID then return Prev_New_Line_Ref (I); end if; end loop; Prev_Terminal (Tree, Prev); when Source_Terminal => if Prev.Non_Grammar.Length > 0 then for I in reverse Prev.Non_Grammar.First_Index .. Prev.Non_Grammar.Last_Index loop if New_Line_Count (Prev.Non_Grammar (I).Line_Region) > 0 then return Prev_New_Line_Ref (I); end if; end loop; Prev_Terminal (Tree, Prev); else declare Result : New_Line_Ref; begin Result.Pos := Tree.Lexer.Contains_New_Line (Prev.ID, Prev.Byte_Region, First => False); if Result.Pos /= Invalid_Buffer_Pos then Result.Node := Prev; Result.First := True; Result.Line := Actual_Start_Line; return Result; else Prev_Terminal (Tree, Prev); end if; end; end if; end case; end if; end loop; end Prev_New_Line; function Prev_Non_Grammar (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is Result : Node_Access := Node; begin if Node = Tree.Root then return Tree.SOI; elsif Node.ID = Tree.Lexer.Descriptor.SOI_ID then return Node; end if; loop Result := Prev_Terminal (Tree, Result); exit when Result = Invalid_Node_Access; exit when Result.Non_Grammar.Length > 0; end loop; return Result; end Prev_Non_Grammar; procedure Prev_Non_Grammar (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref) is begin if Ref.Node /= Invalid_Node_Access and then Ref.Node.ID = Tree.Lexer.Descriptor.SOI_ID then return; end if; loop Prev_Terminal (Tree, Ref); exit when Ref.Node = Invalid_Node_Access; exit when Ref.Node.Non_Grammar.Length > 0; end loop; end Prev_Non_Grammar; procedure Prev_Non_Grammar (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Parse_Stream : in Stream_ID) is begin if Ref.Ref.Node /= Invalid_Node_Access and then Ref.Ref.Node.ID = Tree.Lexer.Descriptor.SOI_ID then return; end if; loop Prev_Terminal (Tree, Ref, Parse_Stream, Preceding => True); exit when Ref.Ref.Node = Invalid_Node_Access; exit when Ref.Ref.Node.Non_Grammar.Length > 0; end loop; end Prev_Non_Grammar; procedure Prev_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access; Parents : in out Node_Stacks.Stack) is begin loop Prev_Terminal (Tree, Node, Parents); exit when Node = Invalid_Node_Access; exit when Node.Sequential_Index /= Invalid_Sequential_Index; end loop; end Prev_Sequential_Terminal; procedure Prev_Sequential_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Syntax_Trees.Stream_Node_Parents; Parse_Stream : in Stream_ID; Preceding : in Boolean) is begin loop Prev_Terminal (Tree, Ref, Parse_Stream, Preceding); exit when not Preceding and Ref.Ref.Node = Invalid_Node_Access; exit when Ref.Ref = Invalid_Stream_Node_Ref; exit when Ref.Ref.Node.Sequential_Index /= Invalid_Sequential_Index; end loop; end Prev_Sequential_Terminal; function Prev_Source_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Trailing_Non_Grammar : in Boolean) return Node_Access is begin return Result : Node_Access := Node do loop Result := Prev_Terminal (Tree, Result); exit when Result = Invalid_Node_Access; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Result.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Result.Non_Grammar.Length > 0) else Result.Label = Source_Terminal); end loop; end return; end Prev_Source_Terminal; function Prev_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref; Trailing_Non_Grammar : in Boolean) return Stream_Node_Ref is begin return Result : Stream_Node_Ref := Ref do loop Prev_Terminal (Tree, Result); exit when Result = Invalid_Stream_Node_Ref; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Result.Node.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Result.Node.Non_Grammar.Length > 0) else Result.Node.Label = Source_Terminal); end loop; end return; end Prev_Source_Terminal; procedure Prev_Source_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Parse_Stream : in Stream_ID; Trailing_Non_Grammar : in Boolean) is begin loop Prev_Terminal (Tree, Ref, Parse_Stream, Preceding => True); exit when Ref.Ref = Invalid_Stream_Node_Ref; exit when (if Trailing_Non_Grammar then (case Terminal_Label'(Ref.Ref.Node.Label) is when Source_Terminal => True, when Virtual_Terminal | Virtual_Identifier => Ref.Ref.Node.Non_Grammar.Length > 0) else Ref.Ref.Node.Label = Source_Terminal); end loop; end Prev_Source_Terminal; function Prev_Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Node_Access is pragma Unreferenced (Tree); function Last_Child (Node : in Valid_Node_Access) return Node_Access is begin case Node.Label is when Source_Terminal | Virtual_Terminal | Virtual_Identifier => return Node; when Nonterm => -- Use first non-empty from end. for J of reverse Node.Children loop -- We tolerate deleted children here for edited trees. if J /= Invalid_Node_Access then declare Result : constant Node_Access := Last_Child (J); begin if Result /= Invalid_Node_Access then return Result; end if; end; end if; end loop; -- All Children are empty return Invalid_Node_Access; end case; end Last_Child; function Prev_Child (Child : in Valid_Node_Access; Parent : in Node_Access) return Node_Access is begin -- Parent is Parent of Child; return terminal node immediately previous to Child. if Parent = Invalid_Node_Access then return Invalid_Node_Access; else case Parent.Label is when Source_Terminal => -- Child is in Parent.Following_Deleted return Parent; when Nonterm => -- Normal tree entry for I in reverse Parent.Children'Range loop if Parent.Children (I) = Child then -- Use first non-empty from I - 1. for J in reverse Parent.Children'First .. I - 1 loop -- We tolerate deleted children here for edited trees. if Parent.Children (J) /= Invalid_Node_Access then declare Result : constant Node_Access := Last_Child (Parent.Children (J)); begin if Result /= Invalid_Node_Access then return Result; end if; end; end if; end loop; -- All previous Children are empty return Prev_Child (Parent, Parent.Parent); end if; end loop; raise SAL.Programmer_Error; -- Child not found in Parent.Children when others => raise SAL.Programmer_Error; end case; end if; end Prev_Child; begin return Prev_Child (Node, Node.Parent); end Prev_Terminal; procedure Prev_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access) is begin Node := Prev_Terminal (Tree, Node); end Prev_Terminal; procedure Prev_Terminal (Tree : in Syntax_Trees.Tree; Node : in out Node_Access; Parents : in out Node_Stacks.Stack) is -- WORKAROUND: if the postcondition and this pragma is uncommented, -- GNAT 13 complains that Tree is referenced in the postcondition; if -- the postcondition is uncommented and this pragma commented, it -- complains that it is referenced in the body. previous versions of -- GNAT did not complain about the postcondition. So we comment out the postcondition -- pragma Unreferenced (Tree); function Last_Child (Node : in Valid_Node_Access) return Node_Access is begin case Node.Label is when Terminal_Label => return Node; when Nonterm => -- Use first non-empty from end. Parents.Push (Node); for J of reverse Node.Children loop -- Encountering a deleted child here is an error in the user -- algorithm. declare Result : constant Node_Access := Last_Child (J); begin if Result /= Invalid_Node_Access then return Result; end if; end; end loop; -- All Children are empty Parents.Pop; return Invalid_Node_Access; end case; end Last_Child; function Prev_Child (Child : in Valid_Node_Access; Parent : in Valid_Node_Access) return Node_Access is Parent_Depth : constant SAL.Base_Peek_Type := Parents.Depth; begin -- Parent is parent of Child; return node immediately previous to Child. pragma Assert (Parent.Label = Nonterm); for I in reverse Parent.Children'Range loop -- Encountering a deleted child here is an error in the user -- algorithm. if Parent.Children (I) = Child then -- Use first non-empty from I - 1. for J in reverse Parent.Children'First .. I - 1 loop Parents.Push (Parent); declare Result : constant Node_Access := Last_Child (Parent.Children (J)); begin if Result /= Invalid_Node_Access then return Result; else Parents.Pop (Parents.Depth - Parent_Depth); -- discard parents from call to Last_Child. end if; end; end loop; -- All previous Parent.Children are empty (or there are none); move to -- prev cousin. if Parents.Is_Empty then return Invalid_Node_Access; else return Prev_Child (Parent, Parents.Pop); end if; end if; end loop; raise SAL.Programmer_Error; -- Child not found in Parent.Children end Prev_Child; begin if Parents.Is_Empty then Node := Invalid_Node_Access; else Node := Prev_Child (Node, Parents.Pop); end if; end Prev_Terminal; procedure Prev_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Terminal_Ref) is use Stream_Element_Lists; begin loop -- Handle empty Elements if Element (Ref.Element.Cur).Node.Label in Terminal_Label or else Ref.Node = Invalid_Node_Access -- A previous Prev_Element arrived at an empty nonterm, or -- Prev_Terminal reached the beginning of an element node. then Stream_Prev (Tree, Ref, Rooted => False); exit when Ref.Element = Invalid_Stream_Index; else Ref.Node := Prev_Terminal (Tree, Ref.Node); end if; exit when Ref.Node /= Invalid_Node_Access; end loop; end Prev_Terminal; function Prev_Terminal (Tree : in Syntax_Trees.Tree; Ref : in Terminal_Ref) return Terminal_Ref is begin return Result : Terminal_Ref := Ref do Prev_Terminal (Tree, Result); end return; end Prev_Terminal; procedure Prev_Terminal (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Parse_Stream : in Stream_ID; Preceding : in Boolean) is use Stream_Element_Lists; begin loop -- Handle empty Elements if Element (Ref.Ref.Element.Cur).Node.Label in Terminal_Label or else Ref.Ref.Node = Invalid_Node_Access -- Ref is at a terminal element or an empty nonterm, or was at a -- first terminal; move to previous stream element. then if not Preceding then Ref.Ref.Node := Invalid_Node_Access; Ref.Parents.Clear; exit; end if; if Parse_Stream /= Invalid_Stream_ID and Ref.Ref.Stream = Tree.Shared_Stream then declare P_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Parse_Stream.Cur); begin if Ref.Ref.Element.Cur = P_Stream.Shared_Link then Ref := (Ref => (Parse_Stream, (Cur => P_Stream.Elements.Last), Element (P_Stream.Elements.Last).Node), Parents => <>); Tree.Last_Terminal (Ref, Parse_Stream, Preceding => False); else Stream_Prev (Tree, Ref, Rooted => False); end if; end; else Stream_Prev (Tree, Ref, Rooted => False); end if; exit when Ref.Ref.Element = Invalid_Stream_Index; else Prev_Terminal (Tree, Ref.Ref.Node, Ref.Parents); end if; exit when Ref.Ref.Node /= Invalid_Node_Access; end loop; end Prev_Terminal; procedure Print_Ref_Counts (Tree : in Syntax_Trees.Tree) is begin for Stream of Tree.Streams loop Tree.Lexer.Trace.Put (Trimmed_Image (Stream.Label) & ":"); declare use Stream_Element_Lists; Cur : Cursor := Stream.Elements.First; begin loop exit when Cur = No_Element; Tree.Lexer.Trace.Put (Integer'Image (Ref_Count (Cur) - 1)); Next (Cur); end loop; end; Tree.Lexer.Trace.New_Line; end loop; end Print_Ref_Counts; procedure Print_Streams (Tree : in Syntax_Trees.Tree; Children : in Boolean := False; Non_Grammar : in Boolean := False) is begin for Stream of Tree.Streams loop Tree.Lexer.Trace.Put_Line (Tree.Image (Stream, Shared => True, Children => Children, Node_Numbers => True, Non_Grammar => Non_Grammar)); Tree.Lexer.Trace.New_Line; end loop; end Print_Streams; procedure Print_Tree (Tree : in Syntax_Trees.Tree; Root : in Node_Access := Invalid_Node_Access; Line_Numbers : in Boolean := False; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Safe_Only : in Boolean := False) is procedure Print_Node (Node : in Valid_Node_Access; Level : in Integer) is begin for I in 1 .. Level loop Tree.Lexer.Trace.Put ("| ", Prefix => False); end loop; Tree.Lexer.Trace.Put (Image (Tree, Node, Children => False, RHS_Index => True, Node_Numbers => True, Line_Numbers => Line_Numbers, Non_Grammar => Non_Grammar, Augmented => Augmented, Safe_Only => Safe_Only), Prefix => False); Tree.Lexer.Trace.New_Line; if Node.Label = Nonterm then for Child of Node.Children loop if Child = null then Tree.Lexer.Trace.Put (" : ", Prefix => True); for I in 1 .. Level + 1 loop Tree.Lexer.Trace.Put ("| ", Prefix => False); end loop; Tree.Lexer.Trace.Put ("", Prefix => False); Tree.Lexer.Trace.New_Line; else Print_Node (Child, Level + 1); end if; end loop; end if; end Print_Node; Print_Root : constant Node_Access := (if Root = Invalid_Node_Access then Syntax_Trees.Root (Tree) else Root); Print_SOI_EOI : constant Boolean := Root = Invalid_Node_Access and Print_Root /= Tree.Root and Tree.Streams.Length > 0; begin if Print_Root = Invalid_Node_Access then Tree.Lexer.Trace.Put_Line (""); else if Print_SOI_EOI then declare -- Get SOI, EOI from same stream as Print_Root Stream : Parse_Stream renames Tree.Streams (Tree.Streams.Last); begin Print_Node (Stream_Element_Lists.Element (Stream.Elements.First).Node, 0); end; end if; Print_Node (Print_Root, 0); if Print_SOI_EOI then declare -- Get SOI, EOI from same stream as Print_Root Stream : Parse_Stream renames Tree.Streams (Tree.Streams.Last); begin Print_Node (Stream_Element_Lists.Element (Stream.Elements.Last).Node, 0); end; end if; end if; end Print_Tree; function Process_Tree (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Visit_Parent : in Visit_Parent_Mode; Process_Node : access function (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean) return Boolean is begin if Visit_Parent = Before then if not Process_Node (Tree, Node) then return False; end if; end if; if Node.Label = Nonterm then for Child of Node.Children loop if Child /= null then if not Process_Tree (Tree, Child, Visit_Parent, Process_Node) then return False; end if; end if; end loop; end if; if Visit_Parent = After then return Process_Node (Tree, Node); else return True; end if; end Process_Tree; procedure Process_Tree (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Process_Node : access procedure (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access)) is begin if Node.Label = Nonterm then for Child of Node.Children loop if Child /= null then Process_Tree (Tree, Child, Process_Node); end if; end loop; end if; Process_Node (Tree, Node); end Process_Tree; procedure Process_Tree (Tree : in out Syntax_Trees.Tree; Process_Node : access procedure (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access); Root : in Node_Access := Invalid_Node_Access) is begin Tree.Traversing := True; Process_Tree (Tree, (if Root = Invalid_Node_Access then Syntax_Trees.Root (Tree) else Root), Process_Node); Tree.Traversing := False; exception when others => Tree.Traversing := False; raise; end Process_Tree; function Production_ID (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return WisiToken.Production_ID is pragma Unreferenced (Tree); begin return (Node.ID, Node.RHS_Index); end Production_ID; function Push (Parse_Stream : in out Syntax_Trees.Parse_Stream; Stream_ID : in Syntax_Trees.Stream_ID; Node : in Valid_Node_Access; State : in State_Index) return Rooted_Ref is use Stream_Element_Lists; New_Element : constant Cursor := Parse_Stream.Elements.Insert (Element => (Node, State), Before => Next (Parse_Stream.Stack_Top)); begin Parse_Stream.Stack_Top := New_Element; -- caller must change Parse_Stream.Shared_Link if needed. return (Stream_ID, (Cur => New_Element), Node); end Push; procedure Push (Parse_Stream : in out Syntax_Trees.Parse_Stream; Stream_ID : in Syntax_Trees.Stream_ID; Node : in Valid_Node_Access; State : in State_Index) is Junk : Stream_Node_Ref := Push (Parse_Stream, Stream_ID, Node, State); pragma Unreferenced (Junk); begin null; end Push; procedure Push (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; State : in State_Index) is begin Push (Tree.Streams (Stream.Cur), Stream, Node, State); end Push; procedure Push_Back (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID) is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin Parse_Stream.Stack_Top := Stream_Element_Lists.Previous (Parse_Stream.Stack_Top); -- This does not change Parse_Stream.Shared_Link end Push_Back; procedure Put_Tree (Tree : in Syntax_Trees.Tree; File_Name : in String) is -- The format uses parens and spaces; no commas. One node per line, -- then one stream per line. use Ada.Streams.Stream_IO; File : File_Type; Stream : Stream_Access; -- SAL.SAL.Gen_Unbounded_Definite_Vectors uses SAL.Peek_Type -- internally to index the vector; that has a range 1 .. -- Integer'Last, smaller than Node_Index'Range. So we must use a -- smaller type, and hope the actual tree does not have that many -- nodes. subtype Half_Node_Index is Node_Index range Node_Index'First / 2 .. Node_Index'Last / 2; package Node_Index_Sets is new SAL.Gen_Unbounded_Definite_Vectors (Half_Node_Index, Boolean, Default_Element => False); Node_Index_Seen : Node_Index_Sets.Vector; procedure Seen (I : in Node_Index) is begin if Node_Index_Seen.Is_Empty then Node_Index_Seen.Set_First_Last (I, I); elsif I < Node_Index_Seen.First_Index then Node_Index_Seen.Set_First_Last (I, Node_Index_Seen.Last_Index); elsif I > Node_Index_Seen.Last_Index then Node_Index_Seen.Set_First_Last (Node_Index_Seen.First_Index, I); else if Node_Index_Seen (I) then raise SAL.Programmer_Error with "duplicate node_index; use Copy_Tree first"; end if; end if; Node_Index_Seen (I) := True; end Seen; procedure Put_Error_List (Error_List : in Error_List_Access) is begin if Error_List = null then String'Write (Stream, " 0()"); else String'Write (Stream, Error_List.Length'Image & '('); for Error of Error_List.all loop Error_Data'Class'Output (Stream, Error); end loop; Character'Write (Stream, ')'); end if; end Put_Error_List; function Buffer_Region_Image (Region : in Buffer_Region) return String is begin return "(" & Trimmed_Image (Region.First) & Region.Last'Image & ")"; end Buffer_Region_Image; function Line_Region_Image (Region : in WisiToken.Line_Region) return String is begin return "(" & Trimmed_Image (Region.First) & Region.Last'Image & ")"; end Line_Region_Image; function Token_Image (Token : in WisiToken.Lexer.Token) return String is begin return "(" & Trimmed_Image (Token.ID) & Buffer_Region_Image (Token.Byte_Region) & Buffer_Region_Image (Token.Char_Region) & Line_Region_Image (Token.Line_Region) & ")"; end Token_Image; function Token_Array_Image is new WisiToken.Lexer.Token_Arrays.Gen_Image (Token_Image); procedure Put_Node (Node : in Valid_Node_Access) is begin String'Write (Stream, "(" & Node.Label'Image & Node.Child_Count'Image & Node.ID'Image & " " & Node.Node_Index'Image); -- We don't output Node.Parent; redundant with node.Children. -- FIXME: implement augmented Put_Error_List (Node.Error_List); case Node.Label is when Terminal_Label => String'Write (Stream, Node.Non_Grammar.Length'Image & Token_Array_Image (Node.Non_Grammar)); String'Write (Stream, Node.Sequential_Index'Image); case Terminal_Label'(Node.Label) is when Source_Terminal => String'Write (Stream, Buffer_Region_Image (Node.Byte_Region) & Buffer_Region_Image (Node.Char_Region) & Node.New_Line_Count'Image); String'Write (Stream, Node.Following_Deleted.Length'Image & "("); for Del of Node.Following_Deleted loop String'Write (Stream, Del.Node_Index'Image); end loop; String'Write (Stream, ")"); when Virtual_Terminal => String'Write (Stream, " " & Node.Insert_Location'Image); when Virtual_Identifier => raise SAL.Not_Implemented with "put_tree virtual_identifier"; end case; when Nonterm => String'Write (Stream, " " & Node.Virtual'Image & " " & Node.Recover_Conflict'Image & Node.RHS_Index'Image & Node.Name_Offset'Image & Node.Name_Length'Image); String'Write (Stream, "("); for Child of Node.Children loop if Child = Invalid_Node_Access then String'Write (Stream, Invalid_Node_Index'Image); else String'Write (Stream, " " & Child.Node_Index'Image); end if; end loop; String'Write (Stream, ")"); end case; String'Write (Stream, ")" & ASCII.LF); end Put_Node; begin Create (File, Out_File, File_Name); Stream := Ada.Streams.Stream_IO.Stream (File); String'Write (Stream, Tree.Nodes.Last_Index'Image & ASCII.LF); for Node of Tree.Nodes loop Seen (Node.Node_Index); Put_Node (Node); end loop; String'Write (Stream, Tree.Streams.Length'Image & ASCII.LF); for Stream of Tree.Streams loop raise SAL.Not_Implemented with "put_tree stream"; end loop; if Tree.Root /= Invalid_Node_Access then String'Write (Stream, Tree.Root.Node_Index'Image); end if; Close (File); end Put_Tree; function Recover_Conflict (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Boolean is begin return Node.Recover_Conflict; end Recover_Conflict; function Reduce (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Production : in WisiToken.Production_ID; Child_Count : in Ada.Containers.Count_Type; State : in State_Index; Recover_Conflict : in Boolean) return Rooted_Ref is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); function Pop_Children return Valid_Node_Access_Array is begin return Result : Valid_Node_Access_Array (1 .. SAL.Base_Peek_Type (Child_Count)) := (others => Dummy_Node) do -- IMPROVEME: use iterated_component_association to avoid bogus init. Waiting on compiler support. for I in reverse Result'Range loop Result (I) := Pop (Parse_Stream); end loop; end return; end Pop_Children; New_Node : constant Node_Access := Tree.Add_Nonterm_1 (Production, Pop_Children, Clear_Parents => False, Recover_Conflict => Recover_Conflict); begin return Push (Parse_Stream, Stream, New_Node, State); end Reduce; procedure Replace_Child (Tree : in out Syntax_Trees.Tree; Parent : in Valid_Node_Access; Child_Index : in SAL.Peek_Type; Old_Child : in Node_Access; New_Child : in Node_Access; Old_Child_New_Parent : in Node_Access := Invalid_Node_Access) is pragma Unreferenced (Tree); begin Parent.Children (Child_Index) := New_Child; if Old_Child /= null then Old_Child.Parent := Old_Child_New_Parent; end if; New_Child.Parent := Parent; end Replace_Child; procedure Replace_Node (Element : in Stream_Index; New_Node : in Valid_Node_Access) is Orig : Stream_Element := Stream_Element_Lists.Element (Element.Cur); begin Orig.Node := New_Node; Stream_Element_Lists.Replace_Element (Element.Cur, Orig); end Replace_Node; procedure Replace_State (Cur : in Stream_Element_Lists.Cursor; New_State : in State_Index) is Orig : Stream_Element := Stream_Element_Lists.Element (Cur); begin Orig.State := New_State; Stream_Element_Lists.Replace_Element (Cur, Orig); end Replace_State; function RHS_Index (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Natural is pragma Unreferenced (Tree); begin return Node.RHS_Index; end RHS_Index; function Root (Tree : in Syntax_Trees.Tree) return Node_Access is begin return Tree.Root; end Root; function Rooted (Ref : in Stream_Node_Ref) return Boolean is begin return Stream_Element_Lists.Has_Element (Ref.Element.Cur) and then Stream_Element_Lists.Element (Ref.Element.Cur).Node = Ref.Node; end Rooted; procedure Set_Augmented (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Value : in Augmented_Class_Access) is pragma Unreferenced (Tree); begin Node.Augmented := Value; end Set_Augmented; procedure Set_Children (Tree : in out Syntax_Trees.Tree; Parent : in out Valid_Node_Access; Children : in Node_Access_Array) is begin -- See Design note in spec about Parents, Parent_Set. -- Clear current Children.Parent first, in case some are also in new -- children. for C of Parent.Children loop if C /= null then C.Parent := Invalid_Node_Access; end if; end loop; if Parent.Children'Length = Children'Length then -- reuse current node Parent.Virtual := False; Parent.Children := Children; else -- reallocate node with new child_count declare Realloc_Parent : constant Node_Access := new Node' (Label => Nonterm, Copied_Node => Invalid_Node_Access, Child_Count => Children'Last, ID => Parent.ID, Node_Index => -(Tree.Nodes.Last_Index + 1), Parent => Parent.Parent, Augmented => Parent.Augmented, Error_List => (if Parent.Error_List = null then null else new Error_Data_Lists.List'(Parent.Error_List.all)), Virtual => False, Recover_Conflict => Parent.Recover_Conflict, RHS_Index => Parent.RHS_Index, Name_Offset => Parent.Name_Offset, Name_Length => Parent.Name_Length, Children => Children); begin Tree.Nodes.Append (Realloc_Parent); if Parent.Parent /= null then Parent.Parent.Children (Child_Index (Parent.Parent.all, Parent)) := Realloc_Parent; end if; Parent := Realloc_Parent; end; end if; for Child of Children loop if Child.Parent /= Invalid_Node_Access then declare Other_Parent : constant Node_Access := Child.Parent; Child_Index : constant SAL.Base_Peek_Type := Syntax_Trees.Child_Index (Other_Parent.all, Child); begin Other_Parent.Children (Child_Index) := null; end; end if; Child.Parent := Parent; end loop; end Set_Children; procedure Set_Children (Tree : in out Syntax_Trees.Tree; Node : in out Valid_Node_Access; New_ID : in WisiToken.Production_ID; Children : in Node_Access_Array) is begin Node.ID := New_ID.LHS; Node.RHS_Index := New_ID.RHS; Set_Children (Tree, Node, Children); end Set_Children; procedure Set_Insert_Location (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Insert_Location : in WisiToken.Insert_Location) is pragma Unreferenced (Tree); begin Node.Insert_Location := Insert_Location; end Set_Insert_Location; procedure Set_Name (Tree : in Syntax_Trees.Tree; Item : in out Recover_Token; Name : in Buffer_Region) is begin if Item.Virtual then Item.Name := Name; else Tree.Set_Name (Item.Element_Node, Name); end if; end Set_Name; procedure Set_Name (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Region : in Buffer_Region) is First_Terminal : constant Node_Access := Tree.First_Terminal (Node); Byte_First : constant Buffer_Pos := Tree.Byte_Region (First_Terminal, Trailing_Non_Grammar => False).First; begin if Region = Null_Buffer_Region or else -- Not a valid name (First_Terminal.Label = Virtual_Terminal and not Tree.Parents_Set) -- Can't trust Byte_First then null; else Node.Name_Offset := Region.First - Byte_First; Node.Name_Length := Region.Last - Region.First + 1; end if; end Set_Name; procedure Set_Node_Index (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Node_Index : in Syntax_Trees.Node_Index) is pragma Unreferenced (Tree); begin Node.Node_Index := Node_Index; end Set_Node_Index; procedure Set_Parents (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID := Invalid_Stream_ID) is procedure Set_Parents (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access; Parent : in Node_Access) is begin Node.Parent := Parent; case Node.Label is when Source_Terminal => for N of Node.Following_Deleted loop N.Parent := Node; end loop; when Virtual_Terminal | Virtual_Identifier => null; when Nonterm => for C of Node.Children loop if C = null then -- This can only happen if someone calls Set_Parents after parents -- are already set and the tree is edited. raise SAL.Programmer_Error with "encountered deleted child"; end if; Set_Parents (Tree, C, Node); end loop; end case; end Set_Parents; begin -- IMPROVEME incremental: only need to handle fully parsed tree, no -- streams. Use incremental algorithm; if find a set parent link, -- assume subtree under that node has parent links set? requires all -- "node.parent = null" to do all ancestors as well. if Stream = Invalid_Stream_ID then if Tree.Streams.Length = 0 then if Tree.Root = Invalid_Node_Access then raise SAL.Parameter_Error with "invalid_tree: no streams, Tree.Root not set"; else Set_Parents (Tree, Tree.Root, Invalid_Node_Access); end if; else declare use Stream_Element_Lists; Cur : Cursor := Tree.Streams (Tree.Shared_Stream.Cur).Elements.First; begin loop exit when Cur = No_Element; Set_Parents (Tree, Element (Cur).Node, Invalid_Node_Access); Next (Cur); end loop; end; end if; else declare use Stream_Element_Lists; Cur : Cursor := Tree.Streams (Stream.Cur).Elements.First; begin loop exit when Cur = No_Element; Set_Parents (Tree, Element (Cur).Node, Invalid_Node_Access); Next (Cur); end loop; end; end if; Tree.Parents_Set := True; end Set_Parents; procedure Set_Root (Tree : in out Syntax_Trees.Tree; New_Root : in Valid_Node_Access) is begin if New_Root.Children (1).ID = Tree.Lexer.Descriptor.SOI_ID and New_Root.Children (New_Root.Children'Last).ID = Tree.Lexer.Descriptor.EOI_ID then Tree.Root := New_Root; else declare Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Tree.Streams.Last); -- Parse_Stream is Shared_Stream if this is a packrat parse. SOI : constant Valid_Node_Access := Stream_Element_Lists.Element (Parse_Stream.Elements.First).Node; Last_Node : constant Valid_Node_Access := Stream_Element_Lists.Element (Parse_Stream.Elements.Last).Node; EOI : constant Node_Access := (if Last_Node.ID = Tree.Lexer.Descriptor.EOI_ID then Last_Node elsif Last_Node.Children (Last_Node.Child_Count).ID = Tree.Lexer.Descriptor.EOI_ID then Last_Node.Children (Last_Node.Child_Count) else Tree.EOI); function Create_New_Children return Node_Access_Array is Last : Positive_Index_Type := New_Root.Children'Last; New_Children : Node_Access_Array (1 .. New_Root.Children'Last + 2); begin if New_Root.Children (1).ID /= Tree.Lexer.Descriptor.SOI_ID then New_Children (1) := SOI; Last := 1 + New_Root.Children'Length; New_Children (2 .. Last) := New_Root.Children; end if; if New_Root.Children (New_Root.Children'Last).ID /= Tree.Lexer.Descriptor.EOI_ID then Last := @ + 1; New_Children (Last) := EOI; end if; return New_Children (1 .. Last); end Create_New_Children; New_Children : constant Node_Access_Array := Create_New_Children; begin Tree.SOI := SOI; Tree.EOI := EOI; Tree.Root := new Node' (Label => Nonterm, Copied_Node => Invalid_Node_Access, Child_Count => New_Children'Last, ID => New_Root.ID, Node_Index => New_Root.Node_Index, Parent => null, Augmented => New_Root.Augmented, Error_List => (if New_Root.Error_List = null then null else new Error_Data_Lists.List'(New_Root.Error_List.all)), Virtual => New_Root.Virtual, Recover_Conflict => New_Root.Recover_Conflict, RHS_Index => New_Root.RHS_Index, Name_Offset => New_Root.Name_Offset, Name_Length => New_Root.Name_Length, Children => New_Children); for Child of New_Children loop Child.Parent := Tree.Root; end loop; Tree.Nodes.Append (Tree.Root); end; end if; end Set_Root; procedure Set_Sequential_Index (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Index : in Base_Sequential_Index) is pragma Unreferenced (Tree); begin Node.Sequential_Index := Index; end Set_Sequential_Index; function Shared_Stream (Tree : in Syntax_Trees.Tree) return Stream_ID is begin return Tree.Shared_Stream; end Shared_Stream; function Shared_Token (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Rooted_Ref is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin if Stream_Element_Lists.Has_Element (Parse_Stream.Shared_Link) then return (Stream => Tree.Shared_Stream, Element => (Cur => Parse_Stream.Shared_Link), Node => Stream_Element_Lists.Element (Parse_Stream.Shared_Link).Node); else -- Shared_Link was EOI, then EOI was copied to parse stream to add an -- error. test_incremental.adb Preserve_parse_Errors_1. return Invalid_Stream_Node_Ref; end if; end Shared_Token; procedure Shift (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; State : in State_Index) is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin if Parse_Stream.Stack_Top = Parse_Stream.Elements.Last then -- Current input token is Stream.Shared_Link. Push (Parse_Stream, Stream, Stream_Element_Lists.Element (Parse_Stream.Shared_Link).Node, State); Stream_Element_Lists.Next (Parse_Stream.Shared_Link); else -- Current input token is Stream input. Stream_Element_Lists.Next (Parse_Stream.Stack_Top); Replace_State (Parse_Stream.Stack_Top, State); end if; end Shift; procedure Shift (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access; Shift_Bytes : in Base_Buffer_Pos; Shift_Chars : in Base_Buffer_Pos; Shift_Lines : in Base_Line_Number_Type; Last_Stable_Byte : in Base_Buffer_Pos; Non_Grammar_Next : in out Lexer.Token_Arrays.Extended_Index) is begin case Terminal_Label'(Node.Label) is when Source_Terminal => pragma Assert (if Node.ID = Tree.Lexer.Descriptor.SOI_ID then Shift_Bytes = 0 and Shift_Chars = 0); if Node.Byte_Region /= Null_Buffer_Region then Node.Byte_Region := @ + Shift_Bytes; end if; if Node.Char_Region /= Null_Buffer_Region then Node.Char_Region := @ + Shift_Chars; end if; when Virtual_Terminal | Virtual_Identifier => null; end case; for I in Node.Non_Grammar.First_Index .. Node.Non_Grammar.Last_Index loop declare Token : Lexer.Token renames Node.Non_Grammar (I); begin if Token.ID = Tree.Lexer.Descriptor.SOI_ID then null; elsif Token.Byte_Region.Last < Last_Stable_Byte then Token.Byte_Region := @ + Shift_Bytes; Token.Char_Region := @ + Shift_Chars; Token.Line_Region := @ + Shift_Lines; else Non_Grammar_Next := I; exit; end if; end; end loop; if Node.Augmented /= null then Shift (Node.Augmented.all, Shift_Bytes, Shift_Chars, Shift_Lines, Last_Stable_Byte); end if; end Shift; function Single_Terminal (Ref : in Stream_Node_Ref) return Boolean is begin return Stream_Element_Lists.Element (Ref.Element.Cur).Node = Ref.Node and Ref.Node.Label in Terminal_Label; end Single_Terminal; function SOI (Tree : in Syntax_Trees.Tree) return Node_Access is begin return Tree.SOI; end SOI; function Stack_Depth (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return SAL.Base_Peek_Type is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Element : Cursor := Parse_Stream.Stack_Top; Result : SAL.Base_Peek_Type := 0; begin loop exit when not Has_Element (Element); Result := @ + 1; Element := Previous (Element); end loop; return Result; end Stack_Depth; function Stack_Top (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return Stream_Index is begin return (Cur => Tree.Streams (Stream.Cur).Stack_Top); end Stack_Top; procedure Start_Edit (Tree : in out Syntax_Trees.Tree) is use Stream_Element_Lists; begin Tree.Shared_Stream := (Cur => Tree.Streams.Append ((Label => Shared_Stream_Label, Stack_Top => Invalid_Stream_Index.Cur, Shared_Link => Invalid_Stream_Index.Cur, Elements => <>))); Tree.Streams (Tree.Shared_Stream.Cur).Elements.Append ((Node => Tree.SOI, State => Unknown_State)); Tree.SOI.Parent := Invalid_Node_Access; -- Delete SOI, EOI from root children (added in Finish_Parse) declare New_Children : Node_Access_Array (1 .. Tree.Root.Child_Count - 2); begin New_Children := Tree.Root.Children (2 .. Tree.Root.Children'Last - 1); Tree.Root := new Node' (Label => Nonterm, Copied_Node => Invalid_Node_Access, Child_Count => Tree.Root.Child_Count - 2, ID => Tree.Root.ID, Node_Index => Tree.Root.Node_Index, Parent => null, Augmented => Tree.Root.Augmented, Error_List => (if Tree.Root.Error_List = null then null else new Error_Data_Lists.List'(Tree.Root.Error_List.all)), Virtual => Tree.Root.Virtual, Recover_Conflict => Tree.Root.Recover_Conflict, RHS_Index => Tree.Root.RHS_Index, Name_Offset => Tree.Root.Name_Offset, Name_Length => Tree.Root.Name_Length, Children => New_Children); for Child of New_Children loop Child.Parent := Tree.Root; end loop; Tree.Nodes.Append (Tree.Root); end; Tree.Streams (Tree.Shared_Stream.Cur).Elements.Append ((Node => Tree.Root, State => Unknown_State)); Tree.Streams (Tree.Shared_Stream.Cur).Elements.Append ((Node => Tree.EOI, State => Unknown_State)); Tree.EOI.Parent := Invalid_Node_Access; Tree.Root := Invalid_Node_Access; end Start_Edit; procedure Start_Lex (Tree : in out Syntax_Trees.Tree) is Begin_Byte_Pos : Buffer_Pos; Begin_Char_Pos : Buffer_Pos; Begin_Line : Line_Number_Type; begin Tree.Lexer.Errors.Clear; Tree.Lexer.Begin_Pos (Begin_Byte_Pos, Begin_Char_Pos, Begin_Line); declare Token : constant Lexer.Token := (ID => Tree.Lexer.Descriptor.SOI_ID, Byte_Region => (Begin_Byte_Pos, Begin_Byte_Pos), Char_Region => (Begin_Char_Pos, Begin_Char_Pos), Line_Region => (Begin_Line, Begin_Line)); -- Tree.*_Region uses SOI.*_Region.First as first * in text, -- .Last as first * in next token. begin if Tree.SOI = null then Tree.SOI := new Node' (Label => Source_Terminal, Child_Count => 0, others => <>); Tree.Nodes.Append (Tree.SOI); end if; Tree.SOI.all := (Label => Source_Terminal, Copied_Node => Invalid_Node_Access, Child_Count => 0, ID => Tree.Lexer.Descriptor.SOI_ID, Node_Index => 0, Parent => Invalid_Node_Access, Augmented => null, Error_List => null, Non_Grammar => Lexer.Token_Arrays.To_Vector (Token), Sequential_Index => Invalid_Sequential_Index, Byte_Region => Token.Byte_Region, Char_Region => Token.Char_Region, New_Line_Count => New_Line_Count (Token.Line_Region), Following_Deleted => Valid_Node_Access_Lists.Empty_List); Tree.Shared_Stream := (Cur => Tree.Streams.Append ((Label => Shared_Stream_Label, Stack_Top => Stream_Element_Lists.No_Element, Shared_Link => Stream_Element_Lists.No_Element, Elements => <>))); Tree.Streams (Tree.Shared_Stream.Cur).Elements.Append ((Node => Tree.SOI, State => Unknown_State)); end; end Start_Lex; procedure Start_Parse (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; State : in State_Index) is Junk : Terminal_Ref := Append_Stream_Element (Tree, Stream, Tree.SOI, State); pragma Unreferenced (Junk); begin Tree.Parents_Set := False; end Start_Parse; function State (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Unknown_State_Index is pragma Unreferenced (Tree, Stream); begin return Stream_Element_Lists.Element (Element.Cur).State; end State; function State (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return State_Index is begin return Stream_Element_Lists.Element (Tree.Streams (Stream.Cur).Stack_Top).State; end State; function Stream_Count (Tree : in Syntax_Trees.Tree) return SAL.Base_Peek_Type is begin return SAL.Base_Peek_Type (Tree.Streams.Length); end Stream_Count; procedure Stream_Delete (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Element : in out Stream_Index) is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin if Parse_Stream.Stack_Top = Element.Cur then Parse_Stream.Stack_Top := Stream_Element_Lists.No_Element; end if; Parse_Stream.Elements.Delete (Element.Cur); end Stream_Delete; function Stream_Error_Iterate (Tree : aliased in Syntax_Trees.Tree; Stream : in Stream_ID) return Stream_Error_Iterator_Interfaces.Forward_Iterator'Class is begin return Stream_Error_Iterator'(Tree => Tree'Access, Stream => Stream.Cur); end Stream_Error_Iterate; function Stream_First (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Skip_SOI : in Boolean) return Stream_Index is begin return Result : Stream_Index := (Cur => Tree.Streams (Stream.Cur).Elements.First) do if Skip_SOI then Stream_Element_Lists.Next (Result.Cur); end if; end return; end Stream_First; function Stream_First (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Skip_SOI : in Boolean) return Rooted_Ref is Cur : constant Stream_Element_Lists.Cursor := Tree.Streams (Stream.Cur).Elements.First; begin return Result : Rooted_Ref := (Stream, (Cur => Cur), Stream_Element_Lists.Element (Cur).Node) do if Skip_SOI then Tree.Stream_Next (Result, Rooted => True); end if; end return; end Stream_First; function Stream_Input_Length (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return SAL.Base_Peek_Type is use Stream_Element_Lists; use SAL; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Element : Cursor := Next (Parse_Stream.Stack_Top); Result : Base_Peek_Type := 0; begin loop exit when not Has_Element (Element); Result := @ + 1; Element := Next (Element); end loop; return Result; end Stream_Input_Length; procedure Stream_Insert (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Before : in Stream_Index) is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin Node.Parent := Invalid_Node_Access; Parse_Stream.Elements.Insert (Element => (Node => Node, State => Unknown_State), Before => Before.Cur); end Stream_Insert; function Stream_Insert (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access; Before : in Stream_Index) return Stream_Node_Ref is Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); begin Node.Parent := Invalid_Node_Access; return Result : constant Stream_Node_Ref := (Stream => Stream, Node => Node, Element => (Cur => Parse_Stream.Elements.Insert (Element => (Node => Node, State => Unknown_State), Before => Before.Cur))); end Stream_Insert; function Stream_Last (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Skip_EOI : in Boolean) return Stream_Index is begin return Result : Stream_Index := (Cur => Tree.Streams (Stream.Cur).Elements.Last) do if Skip_EOI then Stream_Element_Lists.Previous (Result.Cur); end if; end return; end Stream_Last; function Stream_Last (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Skip_EOI : in Boolean) return Rooted_Ref is begin return To_Rooted_Ref (Tree, Stream, Stream_Last (Tree, Stream, Skip_EOI)); end Stream_Last; function Stream_Length (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID) return SAL.Base_Peek_Type is begin return SAL.Base_Peek_Type (Tree.Streams (Stream.Cur).Elements.Length); end Stream_Length; function Stream_Next (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Stream_Index is begin return (if Element = Invalid_Stream_Index then (Cur => Tree.Streams (Stream.Cur).Elements.First) else (Cur => Stream_Element_Lists.Next (Element.Cur))); end Stream_Next; function Stream_Next (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Rooted_Ref is Result : Stream_Node_Ref := Ref; begin Stream_Next (Tree, Result, Rooted => True); return Result; end Stream_Next; procedure Stream_Next (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref; Rooted : in Boolean) is use Stream_Element_Lists; begin Ref.Element := (Cur => Next (Ref.Element.Cur)); if not Has_Element (Ref.Element.Cur) then if Ref.Stream = Tree.Shared_Stream then Ref.Stream := Invalid_Stream_ID; elsif not Has_Element (Tree.Streams (Ref.Stream.Cur).Shared_Link) then Ref.Stream := Invalid_Stream_ID; else Ref.Element.Cur := Tree.Streams (Ref.Stream.Cur).Shared_Link; Ref.Stream := Tree.Shared_Stream; end if; end if; Ref.Node := (if Has_Element (Ref.Element.Cur) then (if Rooted then Element (Ref.Element.Cur).Node else First_Terminal (Tree, Element (Ref.Element.Cur).Node)) else Invalid_Node_Access); end Stream_Next; procedure Stream_Next (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Rooted : in Boolean) is use Stream_Element_Lists; begin Ref.Parents.Clear; Stream_Next (Tree, Ref.Ref, Rooted => True); if Ref.Ref.Element.Cur /= No_Element and not Rooted then Ref.Ref.Node := First_Terminal (Tree, Stream_Element_Lists.Element (Ref.Ref.Element.Cur).Node, Ref.Parents); end if; end Stream_Next; function Stream_Prev (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Stream_Index is pragma Unreferenced (Tree, Stream); begin return (Cur => Stream_Element_Lists.Previous (Element.Cur)); end Stream_Prev; function Stream_Prev (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Rooted_Ref is Result : Stream_Node_Ref := Ref; begin Stream_Prev (Tree, Result); return Result; end Stream_Prev; procedure Stream_Prev (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Ref; Rooted : in Boolean := True) is use Stream_Element_Lists; begin Ref.Element := (Cur => Previous (Ref.Element.Cur)); if not Has_Element (Ref.Element.Cur) then Ref.Stream := Invalid_Stream_ID; end if; Ref.Node := (if Has_Element (Ref.Element.Cur) then (if Rooted then Element (Ref.Element.Cur).Node else Tree.Last_Terminal (Element (Ref.Element.Cur).Node)) else Invalid_Node_Access); end Stream_Prev; procedure Stream_Prev (Tree : in Syntax_Trees.Tree; Ref : in out Stream_Node_Parents; Rooted : in Boolean) is use Stream_Element_Lists; begin Ref.Parents.Clear; Stream_Prev (Tree, Ref.Ref, Rooted => True); if Ref.Ref.Element.Cur /= No_Element and not Rooted then Ref.Ref.Node := Last_Terminal (Tree, Stream_Element_Lists.Element (Ref.Ref.Element.Cur).Node, Ref.Parents); end if; end Stream_Prev; function Subtree_Image (Tree : in Syntax_Trees.Tree; Node : in Node_Access; Node_Numbers : in Boolean := True; Non_Grammar : in Boolean := False; Augmented : in Boolean := False; Line_Numbers : in Boolean := False; Level : in Integer := 0) return String is use Ada.Strings.Unbounded; Result : Unbounded_String := +"" & ASCII.LF; begin for I in 1 .. Level loop Result := @ & "| "; end loop; Result := @ & (if Node = Invalid_Node_Access then "" else Image (Tree, Node, Children => False, Node_Numbers => Node_Numbers, RHS_Index => True, Terminal_Node_Numbers => True, Non_Grammar => Non_Grammar, Line_Numbers => Line_Numbers, Augmented => Augmented)); if Node /= Invalid_Node_Access and then Node.Label = Nonterm then for Child of Node.Children loop Result := @ & Subtree_Image (Tree, Child, Node_Numbers, Non_Grammar, Augmented, Line_Numbers, Level + 1); end loop; end if; return -Result; end Subtree_Image; function Subtree_Root (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Access) return Valid_Node_Access is pragma Unreferenced (Tree); N : Valid_Node_Access := Node; begin loop exit when N.Parent = Invalid_Node_Access; N := N.Parent; end loop; return N; end Subtree_Root; function To_Node_Access (Item : in Valid_Node_Access_Array) return Node_Access_Array is begin return (for I in Item'Range => Item (I)); end To_Node_Access; function To_Real_Recover_Token (Item : in Stream_Node_Ref) return Real_Recover_Token is begin return (Virtual => False, Element_Node => Stream_Element_Lists.Element (Item.Element.Cur).Node, Node => Item.Node); end To_Real_Recover_Token; function To_Rooted_Ref (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Element : in Stream_Index) return Rooted_Ref is pragma Unreferenced (Tree); begin return (Stream, Element, Stream_Element_Lists.Element (Element.Cur).Node); end To_Rooted_Ref; function To_Stream_Node_Ref (Tree : in Syntax_Trees.Tree; Stream : in Stream_ID; Node : in Valid_Node_Access) return Stream_Node_Ref is use Stream_Element_Lists; Parse_Stream : Syntax_Trees.Parse_Stream renames Tree.Streams (Stream.Cur); Root : constant Valid_Node_Access := Tree.Subtree_Root (Node); Cur : Cursor := Parse_Stream.Elements.First; begin loop exit when Element (Cur).Node = Root; Next (Cur); end loop; return (Stream => Stream, Element => (Cur => Cur), Node => Node); end To_Stream_Node_Ref; function To_Stream_Node_Parents (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Stream_Node_Parents is begin return Result : Stream_Node_Parents := (Ref, Parents => <>) do if Ref = Invalid_Stream_Node_Ref or else Rooted (Ref) then null; elsif Tree.Parents_Set then declare Inverted_Parents : Node_Stacks.Stack; Node : Valid_Node_Access := Ref.Node.Parent; Root_Node : constant Valid_Node_Access := Stream_Element_Lists.Element (Ref.Element.Cur).Node; begin loop Inverted_Parents.Push (Node); exit when Node = Root_Node; Node := Node.Parent; end loop; Result.Parents := Inverted_Parents.Invert; end; else declare use Stream_Element_Lists; begin Result.Ref.Node := Tree.First_Terminal (Element (Ref.Element.Cur).Node, Result.Parents); loop exit when Result.Ref.Node = Ref.Node; Tree.Next_Terminal (Result, Following => True); end loop; end; end if; end return; end To_Stream_Node_Parents; function To_Valid_Node_Access (Item : in Node_Access_Array) return Valid_Node_Access_Array is begin return (for I in Item'Range => Item (I)); end To_Valid_Node_Access; function Traversing (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Traversing; end Traversing; function Trimmed_Image (Tree : in Syntax_Trees.Tree; Item : in Stream_ID) return String is begin return Trimmed_Image (Tree.Streams (Item.Cur).Label); end Trimmed_Image; function Trimmed_Image (Item : in Stream_Index) return String is begin return (if Item = Invalid_Stream_Index then "-" else Trimmed_Image (Stream_Element_Lists.Element (Item.Cur).Node.Node_Index)); end Trimmed_Image; function Trimmed_Image (Node : in Node_Access) return String is begin return (if Node = Invalid_Node_Access then "-" else Trimmed_Image (Node.Node_Index)); end Trimmed_Image; function Tree_Size_Image (Tree : in Syntax_Trees.Tree) return String is begin return Node_Index'(Tree.Nodes.Last_Index)'Image; end Tree_Size_Image; procedure Update_Error (Tree : in out Syntax_Trees.Tree; Stream : in Stream_ID; Error_Ref : in Stream_Error_Ref; Data : in Error_Data'Class; User_Data : in User_Data_Access_Constant) is use Error_Data_Lists; Error_Node : constant Valid_Node_Access := Syntax_Trees.Error_Node (Error_Ref); New_Error_List : constant Error_List_Access := new List'(Error_Node.Error_List.all); Cur : Cursor := New_Error_List.First; Moved_Ref : Stream_Node_Parents := Error_Ref.Ref; begin loop exit when Dispatch_Equal (Data, New_Error_List (Cur)); Next (Cur); end loop; New_Error_List (Cur) := Data; if Error_Ref.Deleted /= Valid_Node_Access_Lists.No_Element then declare Old_Following_Deleted : Valid_Node_Access_Lists.List renames Error_Ref.Ref.Ref.Node.Following_Deleted; pragma Assert (Error_Node.Following_Deleted.Length = 0); New_Error_Node : constant Valid_Node_Access := Copy_Node (Tree, Error_Node, Parent => Invalid_Node_Access, Copy_Children => False, Copy_Following_Deleted => False, User_Data => User_Data, New_Error_List => New_Error_List, Set_Error_List => True, Set_Copied_Node => True); begin Move_Element (Tree, Stream, Moved_Ref, New_Node => Copy_Node (Tree, Error_Ref.Ref.Ref.Node, Parent => (if Tree.Parents_Set then Error_Ref.Ref.Ref.Node.Parent else Invalid_Node_Access), Copy_Children => False, Copy_Following_Deleted => False, User_Data => User_Data), User_Data => User_Data); for Cur in Old_Following_Deleted.Iterate loop Moved_Ref.Ref.Node.Following_Deleted.Append ((if Cur = Error_Ref.Deleted then New_Error_Node else Copy_Node (Tree, Old_Following_Deleted (Cur), Parent => Invalid_Node_Access, User_Data => User_Data, Copy_Children => False, Copy_Following_Deleted => False, Set_Copied_Node => True))); end loop; New_Error_List (Cur).Adjust_Copy; New_Error_Node.Copied_Node := Invalid_Node_Access; for Cur in Old_Following_Deleted.Iterate loop Old_Following_Deleted (Cur).Copied_Node := Invalid_Node_Access; end loop; end; else Move_Element (Tree, Stream, Moved_Ref, New_Node => Copy_Node (Tree, Error_Ref.Ref.Ref.Node, Parent => Invalid_Node_Access, Copy_Children => False, Copy_Following_Deleted => True, New_Error_List => New_Error_List, Set_Error_List => True, User_Data => User_Data), User_Data => User_Data); end if; end Update_Error; function Valid_Root (Tree : in Syntax_Trees.Tree) return Boolean is begin return Tree.Root /= Invalid_Node_Access or Tree.Stream_Count > 0; end Valid_Root; function Valid_Stream_Node (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Ref) return Boolean is begin return Tree.Contains (Ref.Stream, Ref.Element) and then (if Ref.Node = Invalid_Node_Access then Ref /= Invalid_Stream_Node_Ref else (not Tree.Parents_Set or else Tree.Is_Descendant_Of (Root => Tree.Get_Node (Ref.Stream, Ref.Element), Descendant => Ref.Node))); end Valid_Stream_Node; function Valid_Stream_Node_Parents (Tree : in Syntax_Trees.Tree; Ref : in Stream_Node_Parents) return Boolean is begin return Valid_Stream_Node (Tree, Ref.Ref) and Parents_Valid (Ref); end Valid_Stream_Node_Parents; procedure Validate_Tree (Tree : in out Syntax_Trees.Tree; User_Data : in User_Data_Access; Error_Reported : in out Node_Sets.Set; Node_Index_Order : in Boolean; Byte_Region_Order : in Boolean := True; Line_Number_Order : in Boolean := True; Root : in Node_Access := Invalid_Node_Access; Validate_Node : in Syntax_Trees.Validate_Node := null) is Real_Root : Node_Access; Last_Source_Terminal_Pos : Base_Buffer_Pos := Buffer_Pos'First; Last_Line : Base_Line_Number_Type := Tree.SOI.Non_Grammar (1).Line_Region.First; procedure Process_Node (Tree : in out Syntax_Trees.Tree; Node : in Valid_Node_Access) is Node_Image_Output : Boolean := False; procedure Put_Error (Msg : in String) is begin -- Tell the caller that some error happened, even if not -- Node_Index_Order. Error_Reported.Insert (Node); if not Node_Image_Output then Tree.Lexer.Trace.Put_Line (Tree.Error_Message (Node, Image (Tree, Node, Children => False, Node_Numbers => True, Safe_Only => True))); Node_Image_Output := True; end if; Tree.Lexer.Trace.Put_Line (Tree.Error_Message (Node, "... invalid_tree: " & Msg)); end Put_Error; begin -- Node_Index checked in Nonterm below; no check needed for -- Source_Terminal since that is set by lexer. Node_Index on Virtual -- terminals not checked. -- For some reason, this loop hangs in some cases -- (ada_mode-recover_partial_28.adb). it hasn't caught a bug in a -- while, so we're leaving it out. -- -- if not (for some N of Tree.Nodes => N = Node) then -- Put_Error ("node " & Tree.Image (Node, Node_Numbers => True) & " not in Tree.Nodes"); -- end if; if Node = Real_Root then if Node.Parent /= null then Put_Error ("root parent set expecting null"); end if; elsif Node.Parent = null then Put_Error ("parent null expecting set"); -- Node in Parent.Children checked below. end if; -- Augmented handled by Validate_Node below. if Node.Error_List /= null then for Err of Node.Error_List.all loop declare Node_Error_Reported : Boolean := (if Node_Index_Order then Error_Reported.Contains (Node) else False); begin Validate_Error (Err, Tree, Node, Node_Error_Reported); if Node_Error_Reported then Error_Reported.Insert (Node); Node_Image_Output := True; end if; end; end loop; end if; case Node.Label is when Terminal_Label => if Node.Sequential_Index /= Invalid_Sequential_Index then Put_Error ("invalid Sequential_Index:" & Node.Sequential_Index'Image); end if; case Terminal_Label'(Node.Label) is when Source_Terminal => if Byte_Region_Order then if Node.Byte_Region.First < Last_Source_Terminal_Pos then Put_Error ("byte_region out of order"); end if; Last_Line := @ + Node.New_Line_Count; if Node.Non_Grammar.Length > 0 then Last_Source_Terminal_Pos := Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last; if Tree.Lexer.Descriptor.New_Line_ID /= Invalid_Token_ID then for Token of Node.Non_Grammar loop -- If node_index_order is changed, so is line_number order, but not -- vice-versa; normally due to %if in grammar, or grammar -- re-writting. See wisitoken-generate-tree_sitter.adb if (Line_Number_Order and Node_Index_Order) and then Token.Line_Region.First /= Last_Line then Put_Error ("line_number missing/out of order"); end if; Last_Line := Token.Line_Region.Last; end loop; end if; else Last_Source_Terminal_Pos := Node.Byte_Region.Last; end if; end if; for Deleted of Node.Following_Deleted loop if Deleted.Parent /= Node then Put_Error ("deleted.parent wrong"); end if; if not Tree.In_Tree (Deleted) then Put_Error ("deleted not in Tree.Nodes"); end if; if Deleted.Error_List /= null then for Err of Deleted.Error_List.all loop declare Node_Error_Reported : Boolean := (if Node_Index_Order then Error_Reported.Contains (Deleted) else False); begin Validate_Error (Err, Tree, Deleted, Node_Error_Reported); if Node_Error_Reported then Error_Reported.Insert (Deleted); end if; end; end loop; end if; if Deleted.Following_Deleted.Length > 0 then Put_Error ("deleted has following_deleted"); end if; end loop; when Virtual_Terminal | Virtual_Identifier => if Node.Non_Grammar.Length > 0 then if Byte_Region_Order then Last_Source_Terminal_Pos := Node.Non_Grammar (Node.Non_Grammar.Last_Index).Byte_Region.Last; if Tree.Lexer.Descriptor.New_Line_ID /= Invalid_Token_ID then for Token of Node.Non_Grammar loop if Token.Line_Region.First /= Last_Line then Put_Error ("line_number missing/out of order"); end if; Last_Line := Token.Line_Region.Last; end loop; end if; end if; end if; end case; when Nonterm => for I in Node.Children'Range loop if Node.Children (I) = null then Put_Error ("child" & I'Image & " deleted"); else if Node_Index_Order and then abs Node.Children (I).Node_Index >= abs Node.Node_Index then Put_Error ("child.node_index" & Node_Index'Image (abs Node.Children (I).Node_Index) & " >= parent.node_index" & Node_Index'Image (abs Node.Node_Index)); end if; declare Child_Parent : constant Node_Access := Node.Children (I).Parent; begin if Child_Parent /= Node then Put_Error ((if Child_Parent = Invalid_Node_Access then "child.parent invalid" else "child.parent incorrect")); end if; end; end if; end loop; end case; if Validate_Node /= null then declare Node_Error_Reported : Boolean := (if Node_Index_Order then Error_Reported.Contains (Node) else False); begin Validate_Node (Tree, Node, User_Data, Node_Error_Reported); if Node_Error_Reported then Error_Reported.Insert (Node); Node_Image_Output := True; end if; end; end if; end Process_Node; begin if Root /= Invalid_Node_Access then Real_Root := Root; Process_Tree (Tree, Root, Process_Node'Access); else if Tree.Streams.Length = 0 then if Tree.Root = Invalid_Node_Access then Tree.Lexer.Trace.Put_Line (Error_Message (Tree.Lexer.File_Name, 1, 1, "... invalid_tree: Tree.Root not set")); else Real_Root := Tree.Root; Process_Tree (Tree, Tree.Root, Process_Node'Access); if Validate_Node = Mark_In_Tree'Access then for Node of Tree.Nodes loop if Node.Augmented = null then Error_Reported.Insert (Node); -- Node is not in tree, so can't use Tree.Error_Message Tree.Lexer.Trace.Put_Line (Image (Tree, Node, Children => False, Node_Numbers => True, Safe_Only => True)); Tree.Lexer.Trace.Put_Line ("... invalid_tree: node in Tree.Nodes but not in tree (has parent, should not)"); end if; end loop; end if; end if; else for Stream of Tree.Streams loop declare use Stream_Element_Lists; Cur : Cursor := Stream.Elements.First; begin loop exit when Cur = No_Element; Real_Root := Element (Cur).Node; Process_Tree (Tree, Real_Root, Process_Node'Access); Next (Cur); end loop; end; end loop; end if; end if; end Validate_Tree; procedure Sequential_Index_Cleared (Tree : in Syntax_Trees.Tree) is Stream : Stream_ID := Tree.Shared_Stream; begin loop declare Terminal : Stream_Node_Parents := Tree.To_Stream_Node_Parents (Tree.To_Rooted_Ref (Stream, Tree.Stream_First (Stream, Skip_SOI => False))); begin loop if Terminal.Ref.Node.Sequential_Index /= Invalid_Sequential_Index then raise SAL.Programmer_Error with "sequential_index not cleared: " & Tree.Image (Terminal.Ref); end if; Tree.Next_Terminal (Terminal, Following => True); exit when Terminal.Ref = Invalid_Stream_Node_Ref; end loop; end; Tree.Next_Parse_Stream (Stream); exit when Stream = Invalid_Stream_ID; end loop; end Sequential_Index_Cleared; end WisiToken.Syntax_Trees;