svd2ada_0.1.0_6eb0b591/src/descriptors-cluster.adb

------------------------------------------------------------------------------
--                                                                          --
--                          SVD Binding Generator                           --
--                                                                          --
--                    Copyright (C) 2015-2019, AdaCore                      --
--                                                                          --
-- SVD2Ada 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.  SVD2Ada is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY;  without even the  implied warranty of MERCHANTA-  --
-- BILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public  --
-- License for  more details.  You should have  received  a copy of the GNU --
-- General Public License  distributed with SVD2Ada; see file COPYING3.  If --
-- not, go to http://www.gnu.org/licenses for a complete copy of the        --
-- license.                                                                 --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Text_IO;
with Ada.Containers.Indefinite_Vectors;

with DOM.Core;
with DOM.Core.Elements;  use DOM.Core.Elements;
with DOM.Core.Nodes;

with SVD2Ada_Utils;

package body Descriptors.Cluster is

   procedure Insert_Element
     (Cluster : in out Cluster_T;
      Elt     : Peripheral_Element);

   procedure Dump_Cluster_Type
     (Spec      : in out Ada_Gen.Ada_Spec;
      Cluster   : in out Cluster_T;
      Type_Name : String);

   function Image (N : Natural) return String;
   --  convenience routine, truncates leading blank from 'Image

   function Computed_Name (Input : Cluster_T) return Unbounded_String;
   --  if Input.Dim = 1 then returns the Input.XML_Id unchanged, otherwise
   --  computes it by removing the "[%s]" substring of the Xml_Id

   package String_List is new Ada.Containers.Indefinite_Vectors
     (Positive, String);

   ---------------------
   -- Read_Cluster --
   ---------------------

   function Read_Cluster
     (Elt            : DOM.Core.Element;
      Prepend        : Unbounded_String;
      Append         : Unbounded_String;
      Reg_Properties : Register_Properties_T;
      Db             : Cluster_Db'Class) return Cluster_T
   is
      use DOM.Core;

      List         : constant Node_List := Nodes.Child_Nodes (Elt);
      Result       : Cluster_T;
      Derived_From : constant String := Elements.Get_Attribute (Elt, "derivedFrom");
      Register     : Register_Access;
      Reg2         : Register_Access;
      Cluster      : Cluster_Access;
   begin
      Result.Reg_Properties := Reg_Properties;

      if Derived_From /= "" then
         declare
            Oth : Cluster_Access renames Db.Get_Cluster (Derived_From);
         begin
            if Oth /= null then
               Result := Oth.all;
               Result.Content.Clear;

               for Elt of Oth.Content loop
                  Result.Content.Append (Deep_Copy (Elt));
               end loop;

            else
               raise Constraint_Error with
                 "cluster 'derivedFrom' is not known: " & Derived_From;
            end if;
         end;
      end if;

      for J in 0 .. Nodes.Length (List) - 1 loop
         if Nodes.Node_Type (Nodes.Item (List, J)) = Element_Node then
            declare
               Child : constant DOM.Core.Element := DOM.Core.Element (Nodes.Item (List, J));
               Tag   : String renames Elements.Get_Tag_Name (Child);
            begin
               if Tag = "name" then
                  Result.Xml_Id := Get_Value (Child);
                  Result.Name := Prepend & Computed_Name (Result) & Append;
                  Result.Type_Name := Result.Name;
                  --  Type_Name might be overloaded by headerStructName

               elsif Tag = "headerStructName" then
                  Result.Type_Name := Get_Value (Child);

               elsif Tag = "description" then
                  Result.Description := Get_Value (Child);

               elsif Tag = "alternateCluster" then
                  null;

               elsif Tag = "addressOffset" then
                  Result.Address_Offset := Get_Value (Child);

               elsif Tag = "dim" then
                  Result.Dim := Get_Value (Child);

                  if Length (Result.Xml_Id) > 0 then
                     Result.Name := Computed_Name (Result);
                  end if;

               elsif Tag = "dimIncrement" then
                  Result.Dim_Increment := Get_Value (Child);

               elsif Tag = "dimIndex" then
                  Result.Dim_Index := Get_Value (Child);

               elsif Tag = "register" then
                  Register := Read_Register
                    (Child,
                     Prepend,
                     Append & "_" & To_String (Result.Name),
                     Result.Reg_Properties,
                     Result);

                  if Register.Dim > 1
                    and then Register.Dim_Increment /=
                      Register.Reg_Properties.Size / 8
                  then
                     --  in such case, this certainly indicates
                     --  two intertwined arrays of registers, We
                     --  need in this case to expand the erray
                     --  into individual values
                     for J in 0 .. Register.Dim - 1 loop
                        Reg2 := new Register_T'(Register.all);
                        Reg2.Dim := 1;
                        Reg2.Address_Offset :=
                          Register.Address_Offset +
                            J * Register.Dim_Increment;
                        Reg2.Name :=
                          Register.Name & To_String (J);
                        Insert_Element (Result, +Reg2);
                     end loop;
                  else
                     Insert_Element (Result, +Register);
                  end if;

               elsif Tag = "cluster" then
                  Cluster := new Cluster_T'
                    (Read_Cluster
                       (Child,
                        Prepend,
                        Append,
                        Result.Reg_Properties,
                        Result));
                  Insert_Element (Result, +Cluster);

               else
                  Ada.Text_IO.Put_Line
                    ("*** WARNING: ignoring cluster element " & Tag & " at " & Full_Name (Child));
               end if;
            end;
         end if;
      end loop;

      return Result;
   end Read_Cluster;

   ---------------
   -- Deep_Copy --
   ---------------

   function Deep_Copy (Cluster : Cluster_Access) return Cluster_Access
   is
      Result : constant Cluster_Access := new Cluster_T'(Cluster.all);
   begin
      Result.Content.Clear;

      for Elt of Cluster.Content loop
         case Elt.Kind is
            when Register_Element =>
               Result.Content.Append ((Register_Element, new Register_T'(Elt.Reg.all)));
            when Cluster_Element =>
               Result.Content.Append ((Cluster_Element, Deep_Copy (Elt.Cluster)));
         end case;
      end loop;

      return Result;
   end Deep_Copy;

   ------------------
   -- Get_Register --
   ------------------

   overriding function Get_Register
     (Db     : Cluster_T;
      XML_Id : String) return Register_Access
   is
   begin
      for Elt of Db.Content loop
         if Elt.Kind = Register_Element
           and then To_String (Elt.Reg.Xml_Id) = XML_Id
         then
            return Elt.Reg;
         end if;
      end loop;

      return null;
   end Get_Register;

   -----------------
   -- Get_Cluster --
   -----------------

   overriding function Get_Cluster
     (Db     : Cluster_T;
      XML_Id : String) return Cluster_Access
   is
   begin
      for Elt of Db.Content loop
         if Elt.Kind = Cluster_Element
           and then To_String (Elt.Cluster.Xml_Id) = XML_Id
         then
            return Elt.Cluster;
         end if;
      end loop;

      return null;
   end Get_Cluster;

   -------------
   -- Get_MSB --
   -------------

   function Get_Size (Cluster : Cluster_T) return Positive
   is
      Elt    : Peripheral_Element renames Cluster.Content.Last_Element;
      Result : Natural := 0;
   begin
      if Cluster.Dim > 1 then
         return Cluster.Dim_Increment * 8;
      end if;

      Result := 8 * Address_Offset (Elt);

      case Elt.Kind is
         when Register_Element =>
            Result := Result +
              (if Elt.Reg.Dim = 1
               then Elt.Reg.Reg_Properties.Size
               else Elt.Reg.Dim * Elt.Reg.Dim_Increment * 8);

         when Cluster_Element =>
            Result := Result + Get_Size (Elt.Cluster.all);
      end case;

      if Result mod 32 /= 0 then
         Result := Result + 32 - (Result mod 32);
      end if;

      return Positive (Result);
   end Get_Size;

   --------------------
   -- Insert_Element --
   --------------------

   procedure Insert_Element
     (Cluster : in out Cluster_T;
      Elt     : Peripheral_Element)
   is
      Added  : Boolean;
      Offset : constant Natural := Address_Offset (Elt);
   begin
      if Cluster.Content.Contains (Elt) then
         return;
      end if;

      Added := False;

      for J in 1 .. Integer (Peripheral_Element_Vectors.Length (Cluster.Content))
      loop
         case Cluster.Content (J).Kind is
            when Register_Element =>
               if Cluster.Content (J).Reg.Address_Offset > Offset then
                  Cluster.Content.Insert (J, Elt);
                  Added := True;
                  exit;
               end if;
            when Cluster_Element =>
               if Cluster.Content (J).Cluster.Address_Offset > Offset then
                  Cluster.Content.Insert (J, Elt);
                  Added := True;
                  exit;
               end if;
         end case;
      end loop;

      if not Added then
         Cluster.Content.Append (Elt);
      end if;
   end Insert_Element;

   -----------------------------------
   -- Process_Overlapping_Registers --
   -----------------------------------

   procedure Process_Overlapping_Registers
     (Reg_Set : Peripheral_Element_Vectors.Vector;
      Found   : out Boolean)
   is
      Idx      : Positive;
      Off      : Natural;
      Last     : Natural;
      Enum_Idx : Natural;

   begin
      Found := False;

      --  search the vector of elements to see if any overlap and, if so, set
      --  Found to True and mark them (within the vector) as overlapping
      for J in Reg_Set.First_Index .. Reg_Set.Last_Index - 1 loop
         declare
            Elt  : Peripheral_Element renames Reg_Set (J);
            Off1 : constant Natural := Address_Offset (Elt);
         begin
            for K in J + 1 .. Reg_Set.Last_Index loop
               declare
                  Elt2 : Peripheral_Element renames Reg_Set (K);
               begin
                  exit when Off1 /= Address_Offset (Elt2);

                  if Reg_Set (J).Kind /= Reg_Set (K).Kind then
                     raise Constraint_Error with
                       "Registers and clusters overlapping is " &
                       "not supported for now";
                  end if;

                  case Reg_Set (J).Kind is
                     when Register_Element =>
                        Reg_Set (J).Reg.Is_Overlapping := True;
                        Reg_Set (K).Reg.Is_Overlapping := True;
                        Found := True;
                     when Cluster_Element =>
                        Reg_Set (J).Cluster.Is_Overlapping := True;
                        Reg_Set (K).Cluster.Is_Overlapping := True;
                        Found := True;
                  end case;
               end;
            end loop;
         end;
      end loop;

      if not Found then
         return;
      end if;

      Idx := Reg_Set.First_Index;
      while Idx < Reg_Set.Last_Index loop
         --  Do not perform a second pass if the register has already been
         --  detected as aliased
         if not Is_Overlapping (Reg_Set (Idx)) then
            Idx := Idx + 1;
         else
            declare
               Elt    : constant Peripheral_Element := Reg_Set (Idx);
               Prefix : constant String := To_String (Name (Elt));

            begin
               Last := Prefix'Last;
               Off  := Address_Offset (Elt);
               --  First loop: look at another register at the same offset
               --  If found, mark the current register as overlapping, and find
               --  a prefix common to all overlapping registers.
               for K in Idx + 1 .. Reg_Set.Last_Index loop
                  exit when Address_Offset (Reg_Set (K)) /= Off;

                  for J in 1 .. Last loop
                     if J > Length (Name (Reg_Set (K)))
                       or else Prefix (J) /= Element (Name (Reg_Set (K)), J)
                     then
                        if Last /= 0 then
                           Last := J - 1;
                        end if;

                        exit;
                     end if;
                  end loop;
               end loop;
            end;

            --  Second loop: find enum values for the registers

            if Last = 0 then
               Enum_Idx := 1;
            end if;

            loop
               exit when Idx > Reg_Set.Last_Index;
               exit when Address_Offset (Reg_Set (Idx)) /= Off;

               declare
                  Elt    : constant Peripheral_Element := Reg_Set (Idx);
                  Prefix : constant String := To_String (Name (Elt));
               begin
                  if Last = 0 then
                     --  No common name found: let's imagine one
                     case Elt.Kind is
                        when Register_Element =>
                           Elt.Reg.Overlap_Suffix := To_Unbounded_String ("Mode_" & Image (Enum_Idx));
                        when Cluster_Element =>
                           Elt.Cluster.Overlap_Suffix := To_Unbounded_String ("Mode_" & Image (Enum_Idx));
                     end case;

                     Enum_Idx := Enum_Idx + 1;

                  elsif Last = Prefix'Last then
                     case Elt.Kind is
                        when Register_Element =>
                           Elt.Reg.Overlap_Suffix := To_Unbounded_String ("Default");
                        when Cluster_Element =>
                           Elt.Cluster.Overlap_Suffix := To_Unbounded_String ("Default");
                     end case;

                  else
                     --  If we have names like "CMR0",
                     --  "CMR0_WAVE_EQ_1", the suffix for the second must
                     --  skip the '_'.
                     declare
                        Skip : Positive := Last + 1;
                     begin
                        while Prefix (Skip) = '_' loop
                           Skip := Skip + 1;
                        end loop;

                        case Elt.Kind is
                           when Register_Element =>
                              Elt.Reg.Overlap_Suffix := To_Unbounded_String (Prefix (Skip .. Prefix'Last));
                           when Cluster_Element =>
                              Elt.Cluster.Overlap_Suffix := To_Unbounded_String (Prefix (Skip .. Prefix'Last));
                        end case;
                     end;
                  end if;

                  Idx := Idx + 1;
               end;
            end loop;
         end if;
      end loop;
   end Process_Overlapping_Registers;

   -----------
   -- Equal --
   -----------

   function Equal (C1, C2 : Cluster_Access) return Boolean
   is
      use type Ada.Containers.Count_Type;
   begin
      if C1.Name /= C2.Name
        or else C1.Address_Offset /= C2.Address_Offset
        or else Get_Size (C1.all) /= Get_Size (C2.all)
        or else C1.Dim /= C2.Dim
        or else C1.Dim_Increment /= C2.Dim_Increment
        or else C1.Content.Length /= C2.Content.Length
      then
         return False;
      end if;

      for J in C1.Content.First_Index .. C1.Content.Last_Index loop
         declare
            Elt1 : Peripheral_Element renames C1.Content (J);
            Elt2 : Peripheral_Element renames C2.Content (J);
         begin
            if Elt1.Kind /= Elt2.Kind then
               return False;
            end if;

            if Elt1.Kind = Register_Element then
               if not Equal (Elt1.Reg, Elt2.Reg) then
                  return False;
               end if;
            else
               if not Equal (Elt1.Cluster, Elt2.Cluster) then
                  return False;
               end if;
            end if;
         end;
      end loop;

      return True;
   end Equal;

   -----------------------
   -- Find_Common_Types --
   -----------------------

   procedure Find_Common_Types (Elts : Peripheral_Element_Vectors.Vector)
   is
   begin
      --  Look for fields with similar types, to use a single type definition
      --  in such situation
      for J in Elts.First_Index .. Elts.Last_Index - 1 loop
         if Elts (J).Kind = Register_Element
           and then Elts (J).Reg.Type_Holder = null
         then
            for K in J + 1 .. Elts.Last_Index loop
               if Elts (K).Kind = Register_Element then
                  if Equal (Elts (J).Reg, Elts (K).Reg) then
                     --  Simple case: two identical registers.
                     Elts (K).Reg.Type_Holder := Elts (J).Reg;

                  else
                     declare
                        Prefix : constant Unbounded_String :=
                                   Similar_Type (Elts (J).Reg, Elts (K).Reg);
                     begin
                        if Length (Prefix) > 0 then
                           --  We have similar types, but with different names.
                           --  In such situation, it'd be nice to generate a
                           --  common type definition.
                           Elts (J).Reg.Type_Name := Prefix;
                           Elts (K).Reg.Type_Holder := Elts (J).Reg;
                        end if;
                     end;
                  end if;
               end if;
            end loop;
         elsif Elts (J).Kind = Cluster_Element
           and then Elts (J).Cluster.Type_Holder = null
         then
            for K in J + 1 .. Elts.Last_Index loop
               if Elts (K).Kind = Cluster_Element then
                  if Equal (Elts (J).Cluster, Elts (K).Cluster) then
                     Elts (K).Cluster.Type_Holder := Elts (J).Cluster;
                  end if;
               end if;
            end loop;
         end if;
      end loop;
   end Find_Common_Types;

   ---------------------------
   -- Get_Discriminent_Type --
   ---------------------------

   function Get_Discriminent_Type
     (Reg_Set   : Peripheral_Element_Vectors.Vector;
      Spec      : in out Ada_Gen.Ada_Spec;
      Type_Name : String) return Ada_Type_Enum
   is
      Result : Ada_Type_Enum := New_Type_Enum (Id => Type_Name & "_Disc");
      Values : String_List.Vector;
      Val    : Ada_Enum_Value;

   begin
      for Reg of Reg_Set loop
         if Is_Overlapping (Reg)
           and then not Values.Contains (To_String (Overlap_Suffix (Reg)))
         then
            Values.Append (To_String (Overlap_Suffix (Reg)));
         end if;
      end loop;

      for S of Values loop
         Val := Add_Enum_Id (Spec, Result, S);

         declare
            Actual : constant String := To_String (Id (Val));
         begin
            if Actual /= S then
               for Reg of Reg_Set loop
                  if Is_Overlapping (Reg)
                    and then To_String (Overlap_Suffix (Reg)) = S
                  then
                     case Reg.Kind is
                        when Register_Element =>
                           Reg.Reg.Overlap_Suffix := Id (Val);
                        when Cluster_Element =>
                           Reg.Cluster.Overlap_Suffix := Id (Val);
                     end case;
                  end if;
               end loop;
            end if;
         end;
      end loop;

      return Result;
   end Get_Discriminent_Type;

   ------------------------------
   -- Dump_Peripheral_Elements --
   ------------------------------

   procedure Dump_Peripheral_Elements
     (Parent : in out Ada_Type_Record'Class;
      Elts   : Peripheral_Element_Vectors.Vector)
   is

      function Dim (Elt : Peripheral_Element) return Positive
      is (case Elt.Kind is
             when Register_Element => Elt.Reg.Dim,
             when Cluster_Element  => Elt.Cluster.Dim);

      function Get_Ada_Type (Elt : Peripheral_Element) return Ada_Type'Class
      is (case Elt.Kind is
             when Register_Element =>
                Get_Ada_Type (Elt.Reg),
             when Cluster_Element  =>
                Type_Holders.Element (Elt.Cluster.Ada_Type));

      function Get_Name (Elt : Peripheral_Element) return String
      is (case Elt.Kind is
             when Register_Element => To_String (Elt.Reg.Name),
             when Cluster_Element  => To_String (Elt.Cluster.Name));

      function Overlap_Suffix (Elt : Peripheral_Element) return String
      is (case Elt.Kind is
             when Register_Element => To_String (Elt.Reg.Overlap_Suffix),
             when Cluster_Element  => To_String (Elt.Cluster.Overlap_Suffix));

      function Get_Description (Elt : Peripheral_Element) return String
      is (case Elt.Kind is
             when Register_Element => To_String (Elt.Reg.Description),
             when Cluster_Element  => To_String (Elt.Cluster.Description));

      Properties     : Field_Properties;
      Is_Overlapping : Boolean;
      Dim_Increment  : Positive;
      Elt_Size       : Positive;
      Address_Offset : Natural;

   begin
      for Elt of Elts loop
         if Elt.Kind = Register_Element
           and then Get_Ada_Type (Elt) in Ada_Type_Record'Class
         then
            Properties :=
              (Is_Aliased     => True,
               Is_Volatile_FA => SVD2Ada_Utils.No_VFA_On_Reg_Types);
         else
            Properties :=
              (Is_Aliased     => True,
               Is_Volatile_FA => False);
         end if;

         case Elt.Kind is
            when Register_Element =>
               Dim_Increment  := Elt.Reg.Dim_Increment;
               Is_Overlapping := Elt.Reg.Is_Overlapping;
               Elt_Size       := Elt.Reg.Reg_Properties.Size;
               Address_Offset := Elt.Reg.Address_Offset;

            when Cluster_Element =>
               Dim_Increment  := Elt.Cluster.Dim_Increment;
               Is_Overlapping := Elt.Cluster.Is_Overlapping;
               Elt_Size       := Get_Size (Elt.Cluster.all);
               Address_Offset := Elt.Cluster.Address_Offset;
         end case;

         if Dim (Elt) > 1 and then
           Get_Ada_Type (Elt) not in Ada_Gen.Ada_Type_Array'Class
         then
            --  We need to unroll the array
            for J in 0 .. Dim (Elt) - 1 loop
               declare
                  Idx  : constant String := J'Image;
                  Name : constant String :=
                           Get_Name (Elt) & '_' &
                           Idx (Idx'First + 1 .. Idx'Last);
               begin
                  if Is_Overlapping then
                     Add_Field
                       (Ada_Type_Union (Parent),
                        Enum_Val   => Overlap_Suffix (Elt),
                        Id         => Name,
                        Typ        => Get_Ada_Type (Elt),
                        Offset     => Address_Offset + J * Dim_Increment,
                        LSB        => 0,
                        MSB        => Elt_Size - 1,
                        Properties => Properties,
                        Comment    => Get_Description (Elt));
                  else
                     Add_Field
                       (Parent,
                        Id         => Name,
                        Typ        => Get_Ada_Type (Elt),
                        Offset     => Address_Offset + J * Dim_Increment,
                        LSB        => 0,
                        MSB        => Elt_Size - 1,
                        Properties => Properties,
                        Comment    => Get_Description (Elt));
                  end if;
               end;
            end loop;

         else
            if Is_Overlapping then
               Add_Field
                 (Ada_Type_Union (Parent),
                  Enum_Val   => Overlap_Suffix (Elt),
                  Id         => Get_Name (Elt),
                  Typ        => Get_Ada_Type (Elt),
                  Offset     => Address_Offset,
                  LSB        => 0,
                  MSB        => (if Dim (Elt) = 1
                                 then Elt_Size - 1
                                 else Dim (Elt) * Dim_Increment * 8 - 1),
                  Properties => Properties,
                  Comment    => Get_Description (Elt));
            else
               Add_Field
                 (Parent,
                  Id         => Get_Name (Elt),
                  Typ        => Get_Ada_Type (Elt),
                  Offset     => Address_Offset,
                  LSB        => 0,
                  MSB        => (if Dim (Elt) = 1
                                 then Elt_Size - 1
                                 else Dim (Elt) * Dim_Increment * 8 - 1),
                  Properties => Properties,
                  Comment    => Get_Description (Elt));
            end if;
         end if;
      end loop;
   end Dump_Peripheral_Elements;

   -----------------------
   -- Dump_Cluster_Type --
   -----------------------

   procedure Dump_Cluster_Type
     (Spec      : in out Ada_Gen.Ada_Spec;
      Cluster   : in out Cluster_T;
      Type_Name : String)
   is

      function Create_Record return Ada_Type_Record'Class;

      -------------------
      -- Create_Record --
      -------------------

      function Create_Record return Ada_Type_Record'Class is
         Found : Boolean;
      begin
         Process_Overlapping_Registers (Cluster.Content, Found);
         if Found then
            declare
               Enum : Ada_Type_Enum :=
                        Get_Discriminent_Type (Cluster.Content,
                                               Spec,
                                               To_String (Cluster.Type_Name));
            begin
               Add (Spec, Enum);
               return New_Type_Union
                 (Type_Name,
                  "Discriminent",
                  Enum,
                  To_String (Cluster.Description));
            end;
         else
            --  No overlapping register: generate a simple record
            return New_Type_Record
              (Type_Name,
               To_String (Cluster.Description));
         end if;
      end Create_Record;

      Rec : Ada_Type_Record'Class := Create_Record;

   begin
      Add_Size_Aspect (Rec, Get_Size (Cluster));

      Dump_Peripheral_Elements (Rec, Cluster.Content);

      Add (Spec, Rec);
      Cluster.Ada_Type := Type_Holders.To_Holder (Rec);
   end Dump_Cluster_Type;

   ----------
   -- Dump --
   ----------

   procedure Dump
     (Spec    : in out Ada_Gen.Ada_Spec;
      Cluster : Cluster_Access)
   is
   begin
      if not Cluster.Content.Is_Empty then
         Add
           (Spec,
            New_Comment_Box (To_String (Cluster.Type_Name) & " cluster's Registers"));
      end if;

      Find_Common_Types (Cluster.Content);

      for Elt of Cluster.Content loop
         case Elt.Kind is
            when Register_Element =>
               Dump (Spec, Elt.Reg);
            when Cluster_Element =>
               Dump (Spec, Elt.Cluster);
         end case;
      end loop;

      Dump_Cluster_Type (Spec, Cluster.all, To_String (Cluster.Type_Name) & "_Cluster");

      if Cluster.Dim > 1 then
         declare
            Array_T : Ada_Type_Array;
         begin
            Array_T :=
              New_Type_Array
                (Id           => To_String (Cluster.Type_Name) & "_Clusters",
                 Index_Type   => "",
                 Index_First  => 0,
                 Index_Last   => Cluster.Dim - 1,
                 Element_Type => -Cluster.Ada_Type,
                 Comment      => To_String (Cluster.Description));
            Add (Spec, Array_T);
            Cluster.Ada_Type := -Array_T;
         end;
      end if;
   end Dump;

   -----------
   -- Image --
   -----------

   function Image (N : Natural) return String is
      S : constant String := N'Img;
   begin
      return S (S'First + 1 .. S'Last);
   end Image;

   -------------------
   -- Computed_Name --
   -------------------

   function Computed_Name (Input : Cluster_T) return Unbounded_String
   is
   begin
      if Input.Dim = 1 then
         return Input.Xml_Id;
      else
         declare
            Name   : constant String := To_String (Input.Xml_Id);
            Result : String (Name'Range);
            Idx    : Natural;
            Skip   : Boolean := False;
         begin
            Idx := Result'First - 1;

            for J in Name'Range loop
               if Skip then
                  Skip := False;

               elsif Name (J) in '[' | ']' then
                  null;

               elsif J < Name'Last and then Name (J .. J + 1) = "%s" then
                  --  Skip the next character (e.g. 's')
                  Skip := True;

               else
                  Idx := Idx + 1;
                  Result (Idx) := Name (J);
               end if;
            end loop;

            if Idx in Result'Range and then Result (Idx) = '_' then
               Idx := Idx - 1;
            end if;

            return To_Unbounded_String (Result (Result'First .. Idx));
         end;
      end if;
   end Computed_Name;

end Descriptors.Cluster;