Merge branch 'topic/v810-011' into 'master'

Ada API: fix a stack overflow in Children_And_Trivia

Closes AdaCore#651

See merge request eng/libadalang/langkit!742

Author: thvnx

langkit/templates/pkg_analysis_body_ada.mako

@@ -1203,6 +1203,72 @@ package body ${ada_lib_name}.Analysis is
       Assign_Names_To_Logic_Vars (Node.Internal.Node);
    end Assign_Names_To_Logic_Vars;
 
+   -----------
+   -- First --
+   -----------
+
+   function First
+     (Self : Children_Array) return Children_Array_Cursor is
+   begin
+      return Self.Children.First_Index;
+   end First;
+
+   ----------
+   -- Last --
+   ----------
+
+   function Last
+     (Self : Children_Array) return Children_Array_Cursor is
+   begin
+      return Self.Children.Last_Index;
+   end Last;
+
+   ----------
+   -- Next --
+   ----------
+
+   function Next
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Children_Array_Cursor is
+   begin
+      pragma Unreferenced (Self);
+      return Pos + 1;
+   end Next;
+
+   --------------
+   -- Previous --
+   --------------
+
+   function Previous
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Children_Array_Cursor is
+   begin
+      pragma Unreferenced (Self);
+      return Pos - 1;
+   end Previous;
+
+   -----------------
+   -- Has_Element --
+   -----------------
+
+   function Has_Element
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Boolean is
+   begin
+      return Pos in First (Self) .. Last (Self);
+   end Has_Element;
+
+   -------------
+   -- Element --
+   -------------
+
+   function Element
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Child_Record is
+   begin
+      return Self.Children (Pos);
+   end Element;
+
    -------------------------
    -- Children_And_Trivia --
    -------------------------
@@ -1217,22 +1283,17 @@ package body ${ada_lib_name}.Analysis is
 
       Check_Safety_Net (Node);
       declare
-         Bare_Result : constant Bare_Children_Array :=
+         Bare_Result : constant Bare_Children_Vector :=
             Children_And_Trivia (Unwrap_Node (Node));
-         Result      : Children_Array (Bare_Result'Range);
+         Result      : Children_Array;
       begin
-         for I in Bare_Result'Range loop
-            declare
-               BR : Bare_Child_Record renames Bare_Result (I);
-               R  : Child_Record renames Result (I);
-            begin
-               case BR.Kind is
-                  when Child =>
-                     R := (Child, Wrap_Node (BR.Node));
-                  when Trivia =>
-                     R := (Trivia, BR.Trivia);
-               end case;
-            end;
+         for C of Bare_Result loop
+            case C.Kind is
+               when Child =>
+                  Result.Children.Append ((Child, Wrap_Node (C.Node)));
+               when Trivia =>
+                  Result.Children.Append ((Trivia, C.Trivia));
+            end case;
          end loop;
          return Result;
       end;

langkit/templates/pkg_analysis_spec_ada.mako

@@ -9,6 +9,7 @@
 <%namespace name="struct_types"   file="struct_types_ada.mako" />
 
 with Ada.Containers;
+private with Ada.Containers.Vectors;
 private with Ada.Finalization;
 with Ada.Strings.Unbounded;
 % if any(a.used_in_public_struct for a in ctx.array_types):
@@ -454,7 +455,49 @@ package ${ada_lib_name}.Analysis is
    end record;
    --  Variant that holds either an AST node or a token
 
-   type Children_Array is array (Positive range <>) of Child_Record;
+   subtype Children_Array_Cursor is Positive;
+   type Children_Array is private
+      with Iterable => (First       => First,
+                        Next        => Next,
+                        Has_Element => Has_Element,
+                        Element     => Element,
+                        Last        => Last,
+                        Previous    => Previous);
+   --  This iterable type holds an array of ``Child`` or ``Trivia`` nodes
+
+   function First
+     (Self : Children_Array) return Children_Array_Cursor;
+   --  Return the first child or trivia cursor corresponding to the children
+   --  array. Helper for the ``Iterable`` aspect.
+
+   function Last
+     (Self : Children_Array) return Children_Array_Cursor;
+   --  Return the last child or trivia cursor corresponding to the children
+   --  array. Helper for the ``Iterable`` aspect.
+
+   function Next
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Children_Array_Cursor;
+   --  Return the child or trivia cursor that follows ``Self`` in the children
+   --  array. Helper for the ``Iterable`` aspect.
+
+   function Previous
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Children_Array_Cursor;
+   --  Return the child or trivia cursor that follows ``Self`` in the children
+   --  array. Helper for the ``Iterable`` aspect.
+
+   function Has_Element
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Boolean;
+   --  Return if ``Pos`` is in ``Self``'s iteration range. Helper for the
+   --  ``Iterable`` aspect.
+
+   function Element
+     (Self : Children_Array;
+      Pos  : Children_Array_Cursor) return Child_Record;
+   --  Return the child of trivia node at position ``Pos`` in ``Self``. Helper
+   --  for the ``Iterable`` aspect.
 
    function Children_And_Trivia
      (Node : ${root_entity.api_name}'Class) return Children_Array;
@@ -770,6 +813,14 @@ private
          Safety_Net => Implementation.No_Node_Safety_Net);
    % endfor
 
+   package Child_Record_Vectors is new Ada.Containers.Vectors
+     (Index_Type   => Children_Array_Cursor,
+      Element_Type => Child_Record);
+
+   type Children_Array is record
+      Children : Child_Record_Vectors.Vector;
+   end record;
+
    procedure Check_Safety_Net (Self : ${T.root_node.entity.api_name}'Class);
    --  Check that Self's node and rebindings are still valid, raising a
    --  Stale_Reference_Error if one is not.

langkit/templates/pkg_implementation_body_ada.mako

@@ -3542,13 +3542,9 @@ package body ${ada_lib_name}.Implementation is
    -------------------------
 
    function Children_And_Trivia
-     (Node : ${T.root_node.name}) return Bare_Children_Array
+     (Node : ${T.root_node.name}) return Bare_Children_Vector
    is
-      package Children_Vectors is new Ada.Containers.Vectors
-        (Positive, Bare_Child_Record);
-      use Children_Vectors;
-
-      Ret_Vec : Vector;
+      Ret_Vec : Bare_Children_Vector;
       Ctx     : Internal_Context renames Node.Unit.Context;
       TDH     : Token_Data_Handler renames Node.Unit.TDH;
 
@@ -3624,14 +3620,7 @@ package body ${ada_lib_name}.Implementation is
          end if;
       end loop;
 
-      declare
-         A : Bare_Children_Array (1 .. Natural (Ret_Vec.Length));
-      begin
-         for I in A'Range loop
-            A (I) := Ret_Vec.Element (I);
-         end loop;
-         return A;
-      end;
+      return Ret_Vec;
    end Children_And_Trivia;
 
    --------------

langkit/templates/pkg_implementation_spec_ada.mako

@@ -16,6 +16,7 @@ with Ada.Containers;              use Ada.Containers;
 with Ada.Containers.Hashed_Maps;
 with Ada.Containers.Hashed_Sets;
 with Ada.Containers.Ordered_Maps;
+with Ada.Containers.Vectors;
 with Ada.Exceptions;
 with Ada.Strings.Unbounded;       use Ada.Strings.Unbounded;
 with Ada.Strings.Unbounded.Hash;
@@ -1281,10 +1282,13 @@ private package ${ada_lib_name}.Implementation is
    end record;
    --  Variant that holds either an node or a token
 
-   type Bare_Children_Array is array (Positive range <>) of Bare_Child_Record;
+   package Bare_Children_Record_Vectors is new Ada.Containers.Vectors
+     (Positive, Bare_Child_Record);
+
+   subtype Bare_Children_Vector is Bare_Children_Record_Vectors.Vector;
 
    function Children_And_Trivia
-     (Node : ${T.root_node.name}) return Bare_Children_Array;
+     (Node : ${T.root_node.name}) return Bare_Children_Vector;
    --  Implementation for Analysis.Children_And_Trivia
 
    % for astnode in ctx.astnode_types:

testsuite/tests/ada_api/children_and_trivia_stack_overflow/expected_concrete_syntax.lkt

@@ -0,0 +1,13 @@
+import lexer_example
+
+@with_lexer(foo_lexer)
+grammar foo_grammar {
+    @main_rule main_rule <- list*(id)
+    id <- Identifier(@identifier)
+}
+
+@abstract class FooNode implements Node[FooNode] {
+}
+
+class Identifier : FooNode implements TokenNode {
+}

testsuite/tests/ada_api/children_and_trivia_stack_overflow/main.adb

@@ -0,0 +1,25 @@
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Libfoolang.Analysis; use Libfoolang.Analysis;
+with Libfoolang.Common;   use Libfoolang.Common;
+
+procedure Main is
+   U : constant Analysis_Unit :=
+      Create_Context.Get_From_File ("main.txt");
+
+   Child_Counter, Trivia_Counter : Natural := 0;
+begin
+   --  This call to Children_And_Trivia raises a STORAGE_ERROR (stack overflow)
+   --  if the nodes are stored on the stack.
+
+   for N of U.Root.Children_And_Trivia loop
+      if N.Kind = Child then
+         Child_Counter := Child_Counter + 1;
+      else
+         Trivia_Counter := Trivia_Counter + 1;
+      end if;
+   end loop;
+   Put_Line ("Child:" & Child_Counter'Image);
+   Put_Line ("Trivia:" & Trivia_Counter'Image);
+   Put_Line ("main.adb: Done.");
+end Main;