-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset 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. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with SPARK_IO, Ada.Characters.Latin_1;

package body SPARK_XML is

   -------------------------------
   -- General Utility functions --
   -------------------------------

   -- Simple constructor function to build an E_Strings.T (presently an ExaminerString)
   -- This is public because is makes definign schemas easier, without having to keep
   -- track of lots of temporary variable for all the strings.
   function X_Str (Str : in String) return E_Strings.T is
   begin
      return E_Strings.Copy_String (Str => Str);
   end X_Str;

   -- Cleans up a string, performing the following replacements
   -- Character   Replacement
   -- =========   ===========
   --    <        &lt;
   --    >        &gt;
   --    &        &amp;
   --    '        &apos;
   --    "        &quot;
   -- These are fundamental characters in XML and cannot occur in
   -- character data (tag attributes, or character data.
   function Filter_String (Str : in E_Strings.T) return E_Strings.T is
      Old_String : E_Strings.T;
      New_String : E_Strings.T := E_Strings.Empty_String;
      Ch         : Character;
   begin
      Old_String := Str;

      while (E_Strings.Get_Length (E_Str => Old_String) > 0) loop
         E_Strings.Pop_Char (E_Str => Old_String,
                             Char  => Ch);
         case Ch is
            when '<' =>
               E_Strings.Append_String (E_Str => New_String,
                                        Str   => "&lt;");
            when '>' =>
               E_Strings.Append_String (E_Str => New_String,
                                        Str   => "&gt;");
            when '&' =>
               E_Strings.Append_String (E_Str => New_String,
                                        Str   => "&amp;");
            when ''' =>
               E_Strings.Append_String (E_Str => New_String,
                                        Str   => "&apos;");
            when '"' =>
               E_Strings.Append_String (E_Str => New_String,
                                        Str   => "&quot;");
            when others =>
               E_Strings.Append_Char (E_Str => New_String,
                                      Ch    => Ch);
         end case;
      end loop;

      return New_String;
   end Filter_String;

   -------------------
   -- Schema Access --
   -------------------

   function Get_Tag_Name (Schema : in Schema_Record;
                          TID    : in Tag_ID) return E_Strings.T is
   begin
      return Schema.Tags.Tag_Array (TID).Name;
   end Get_Tag_Name;

   function Get_Attribute_Name (Schema : in Schema_Record;
                                AID    : in Attribute_ID) return E_Strings.T is
   begin
      return (Schema.Attributes.Attribute_Array (AID).Name);
   end Get_Attribute_Name;

   function Get_Tag_Attributes (Schema : in Schema_Record;
                                TID    : in Tag_ID) return Tag_Attribute_Array is
   begin
      return Schema.Tags.Tag_Array (TID).Tag_Attributes;
   end Get_Tag_Attributes;

   function Get_Tag_Attribute
     (Schema : in Schema_Record;
      TID    : in Tag_ID;
      TAID   : in Tag_Attribute_Array_Index)
     return   Attribute_ID
   is
   begin
      return Schema.Tags.Tag_Array (TID).Tag_Attributes (TAID);
   end Get_Tag_Attribute;

   function Find_Tag (Schema : in Schema_Record;
                      Name   : in E_Strings.T) return Tag_ID is
      Found : Tag_ID := Null_Tag;
   begin
      for I in Tag_ID loop
         if E_Strings.Eq_String (E_Str1 => Name,
                                 E_Str2 => Get_Tag_Name (Schema => Schema,
                                                         TID    => I)) then
            Found := I;
            exit;
         end if;
      end loop;

      return Found;
   end Find_Tag;

   function Get_Attribute_Type (Schema : in Schema_Record;
                                AID    : in Attribute_ID) return Attribute_Type is
   begin
      return Schema.Attributes.Attribute_Array (AID).Content_Type;
   end Get_Attribute_Type;

   function Attribute_Is_Required (Schema : in Schema_Record;
                                   AID    : in Attribute_ID) return Boolean is
   begin
      return Schema.Attributes.Attribute_Array (AID).Required;
   end Attribute_Is_Required;

   function Is_Null_Attribute (AID : in Attribute_ID) return Boolean is
   begin
      return (AID = Null_Attribute);
   end Is_Null_Attribute;

   function Is_Null_Tag (TID : in Tag_ID) return Boolean is
   begin
      return (TID = Null_Tag);
   end Is_Null_Tag;

   function Get_Last_Child_Tag (Schema : in Schema_Record;
                                TID    : in Tag_ID) return Child_Tag_Array_Index is
   begin
      return Schema.Tags.Tag_Array (TID).Last_Child;
   end Get_Last_Child_Tag;

   function Get_Child_Tags (Schema : in Schema_Record;
                            TID    : in Tag_ID) return Child_Tag_Array is
   begin
      return Schema.Tags.Tag_Array (TID).Child_Tags;
   end Get_Child_Tags;

   function Get_Child_Tag
     (Schema : in Schema_Record;
      TID    : in Tag_ID;
      CTID   : in Child_Tag_Array_Index)
     return   Child_Tag
   is
   begin
      return Schema.Tags.Tag_Array (TID).Child_Tags (CTID);
   end Get_Child_Tag;

   function Is_Legal_Child
     (Schema : in Schema_Record;
      Parent : in Tag_ID;
      Child  : in Tag_ID)
     return   Boolean
   is
      Found    : Boolean := False;
      Children : Child_Tag_Array;
      Upper    : Child_Tag_Array_Index;
   begin

      if not Is_Null_Tag (TID => Child) then  -- The Null tag is never valid.

         Children := Get_Child_Tags (Schema => Schema,
                                     TID    => Parent);

         Upper := Get_Last_Child_Tag (Schema => Schema,
                                      TID    => Parent);

         for I in Child_Tag_Array_Index range Child_Tag_Array_Index'First .. Upper loop

            --# assert Upper = Upper% and Upper in Child_Tag_Array_Index;

            if Children (I).Child = Child then
               Found := True;
               exit;
            end if;
         end loop;

      end if;

      return Found;
   end Is_Legal_Child;

   ---------------------
   -- Schema creation --
   ---------------------

   -- Initialise the schema variables.
   procedure Init_Schema (Schema : out Schema_Record) is
   begin
      Schema := Empty_Schema_Record;
   end Init_Schema;

   -- Add a tag to the schema
   procedure Add_Tag (Schema : in out Schema_Record;
                      Name   : in     E_Strings.T;
                      ID     :    out Tag_ID) is
   begin
      if (Schema.Tags.Last_Tag < Tag_ID'Last) then
         Schema.Tags.Last_Tag                              := Tag_ID'Succ (Schema.Tags.Last_Tag);
         Schema.Tags.Tag_Array (Schema.Tags.Last_Tag).Name := Name;
         ID                                                := Schema.Tags.Last_Tag;
      else
         ID := Null_Tag;
      end if;
   end Add_Tag;

   procedure Add_Attribute_To_Tag
     (Schema       : in out Schema_Record;
      TID          : in     Tag_ID;
      Name         : in     E_Strings.T;
      Content_Type : in     Attribute_Type;
      Required     : in     Boolean;
      ID           :    out Attribute_ID;
      Success      :    out Boolean)
   is

      Temp_AID : Attribute_ID;

      -- Add an attribute to a tag
      procedure Add_Attribute
        (Schema       : in out Schema_Record;
         Name         : in     E_Strings.T;
         Content_Type : in     Attribute_Type;
         Required     : in     Boolean;
         ID           :    out Attribute_ID)
      --# derives ID     from Schema &
      --#         Schema from *,
      --#                     Content_Type,
      --#                     Name,
      --#                     Required;
      is
      begin
         if (Schema.Attributes.Last_Attribute < Attribute_ID'Last) then
            Schema.Attributes.Last_Attribute                                     :=
              Attribute_ID'Succ (Schema.Attributes.Last_Attribute);
            Schema.Attributes.Attribute_Array (Schema.Attributes.Last_Attribute) :=
              Attribute'(Name         => Name,
                         Content_Type => Content_Type,
                         Required     => Required);
            ID                                                                   := Schema.Attributes.Last_Attribute;
         else
            ID := Null_Attribute;  -- Return the null attribute to indicate failure
         end if;
      end Add_Attribute;

      procedure Attach_Attribute
        (Schema  : in out Schema_Record;
         AID     : in     Attribute_ID;
         TID     : in     Tag_ID;
         Success :    out Boolean)
      --# derives Schema  from *,
      --#                      AID,
      --#                      TID &
      --#         Success from Schema,
      --#                      TID;
      is
         Tmp_Tag : Tag;
      begin
         Tmp_Tag := Schema.Tags.Tag_Array (TID);

         if (Tmp_Tag.Last_Tag_Attribute < Max_Attributes_Per_Tag) then

            Tmp_Tag.Tag_Attributes (Tmp_Tag.Last_Tag_Attribute) := AID;
            Tmp_Tag.Last_Tag_Attribute                          := Tag_Attribute_Array_Index'Succ (Tmp_Tag.Last_Tag_Attribute);

            Schema.Tags.Tag_Array (TID) := Tmp_Tag;
            Success                     := True;
         else
            Success := False;
         end if;
      end Attach_Attribute;

   begin
      Add_Attribute (Schema       => Schema,
                     Name         => Name,
                     Content_Type => Content_Type,
                     Required     => Required,
                     ID           => Temp_AID);

      if not Is_Null_Attribute (AID => Temp_AID) then
         Attach_Attribute (Schema  => Schema,
                           AID     => Temp_AID,
                           TID     => TID,
                           Success => Success);
      else  -- Failed to add the attribute to the attribute database
         Success := False;
      end if;

      ID := Temp_AID;
   end Add_Attribute_To_Tag;

   procedure Add_Child_Tag
     (Schema   : in out Schema_Record;
      TID      : in     Tag_ID;
      Child    : in     Tag_ID;
      Required : in     Boolean;
      Success  :    out Boolean)
   is
   begin
      if (Schema.Tags.Tag_Array (TID).Last_Child < Child_Tag_Array_Index'Last) then

         Schema.Tags.Tag_Array (TID).Child_Tags (Schema.Tags.Tag_Array (TID).Last_Child) :=
           Child_Tag'(Child    => Child,
                      Required => Required);
         Schema.Tags.Tag_Array (TID).Last_Child                                          :=
           Child_Tag_Array_Index'Succ (Schema.Tags.Tag_Array (TID).Last_Child);

         Success := True;
      else
         Success := False;
      end if;
   end Add_Child_Tag;

   procedure Add_CDATA (Schema : in out Schema_Record;
                        TID    : in     Tag_ID) is
   begin
      Schema.Tags.Tag_Array (TID).Allow_CDATA := True;
   end Add_CDATA;

   function CDATA (Schema : in Schema_Record;
                   TID    : in Tag_ID) return Boolean is
   begin
      return Schema.Tags.Tag_Array (TID).Allow_CDATA;
   end CDATA;

   -----------------------------------
   -- ScheamState access and update --
   -----------------------------------

   procedure Init_Schema_State (Schema_State : out Schema_State_Record) is
   begin
      Schema_State := Empty_Schema_State_Record;
   end Init_Schema_State;

   function Tag_Stack_Peek (Schema_State : in Schema_State_Record) return Tag_ID is
   begin
      return Schema_State.Tag_Stack.Stack (Schema_State.Tag_Stack.Current);
   end Tag_Stack_Peek;

   function Tag_Stack_Peek_N (Schema_State : in Schema_State_Record;
                              N            : in Tag_Depth) return Tag_ID is
   begin
      return Schema_State.Tag_Stack.Stack (N);
   end Tag_Stack_Peek_N;

   function Tag_Stack_Depth (Schema_State : in Schema_State_Record) return Tag_Depth is
   begin
      return Schema_State.Tag_Stack.Current;
   end Tag_Stack_Depth;

   function Tag_Stack_Empty (Schema_State : in Schema_State_Record) return Boolean is
   begin
      return (Tag_Stack_Depth (Schema_State => Schema_State) = Tag_Depth'First);
   end Tag_Stack_Empty;

   function Tag_Stack_Full (Schema_State : in Schema_State_Record) return Boolean is
   begin
      return (Tag_Stack_Depth (Schema_State => Schema_State) = Tag_Depth'Last);
   end Tag_Stack_Full;

   procedure Tag_Stack_Push (Schema_State : in out Schema_State_Record;
                             Depth        :    out Tag_Depth;
                             Status       :    out Schema_Status)
   --# derives Depth,
   --#         Schema_State,
   --#         Status       from Schema_State;
   is
      Return_Depth : Tag_Depth := Tag_Depth'First;
   begin
      if Schema_State.Tag_Stack.Current = Tag_Depth'Last then -- Full
         Status := SS_Stack_Full;
      else
         Schema_State.Tag_Stack.Current                                := Tag_Depth'Succ (Schema_State.Tag_Stack.Current);
         Schema_State.Tag_Stack.Stack (Schema_State.Tag_Stack.Current) := Schema_State.Working_Tag.TID;
         Return_Depth                                                  := Schema_State.Tag_Stack.Current;
         Status                                                        := SS_OK;
      end if;

      Depth := Return_Depth;
   end Tag_Stack_Push;

   procedure Tag_Stack_Pop (Schema_State : in out Schema_State_Record;
                            TID          :    out Tag_ID;
                            Status       :    out Schema_Status)
   --# derives Schema_State,
   --#         Status,
   --#         TID          from Schema_State;
   is
   begin

      if Schema_State.Tag_Stack.Current = Tag_Depth'First then -- Empty
         Status := SS_Stack_Empty;
         TID    := Null_Tag;
      else
         TID                            := Tag_Stack_Peek (Schema_State => Schema_State);
         Schema_State.Tag_Stack.Current := Tag_Depth'Pred (Schema_State.Tag_Stack.Current);
         Status                         := SS_OK;
      end if;

   end Tag_Stack_Pop;

   function Get_Working_Attribute_Val
     (Schema_State : in Schema_State_Record;
      TAID         : in Tag_Attribute_Array_Index)
     return         E_Strings.T
   is
   begin
      return E_Strings.Trim (Schema_State.Working_Tag.Attribs (TAID).Val);
   end Get_Working_Attribute_Val;

   function Get_Working_Attribute_ID
     (Schema_State : in Schema_State_Record;
      TAID         : in Tag_Attribute_Array_Index)
     return         Attribute_ID
   is
   begin
      return Schema_State.Working_Tag.Attribs (TAID).AID;
   end Get_Working_Attribute_ID;

   procedure Set_Working_Attribute
     (Schema_State : in out Schema_State_Record;
      TAID         : in     Tag_Attribute_Array_Index;
      AID          : in     Attribute_ID;
      Val          : in     E_Strings.T)
   --# derives Schema_State from *,
   --#                           AID,
   --#                           TAID,
   --#                           Val;
   is
   begin
      Schema_State.Working_Tag.Attribs (TAID).AID := AID;
      Schema_State.Working_Tag.Attribs (TAID).Val := Val;
   end Set_Working_Attribute;

   function Tag_Stack_Hunt_Up (Schema_State : in Schema_State_Record;
                               TID          : in Tag_ID) return Tag_Depth is
      Location : Tag_Depth := Tag_Depth'First;
      Upper    : Tag_Depth;
   begin
      Upper := Tag_Stack_Depth (Schema_State => Schema_State);
      for I in Tag_Depth range Tag_Depth'First .. Upper loop

         --# assert Upper = Upper% and Upper in Tag_Depth;

         if TID = Tag_Stack_Peek_N (Schema_State => Schema_State,
                                    N            => I) then
            Location := I;
            exit;
         end if;

      end loop;

      return Location;
   end Tag_Stack_Hunt_Up;

   function Tag_Stack_Hunt_Down (Schema_State : in Schema_State_Record;
                                 TID          : in Tag_ID) return Tag_Depth is
      Location : Tag_Depth := Tag_Depth'First;
      Upper    : Tag_Depth;
   begin
      Upper := Tag_Stack_Depth (Schema_State => Schema_State);
      for I in reverse Tag_Depth range Tag_Depth'First .. Upper loop

         --# assert Upper = Upper% and Upper in Tag_Depth;

         if TID = Tag_Stack_Peek_N (Schema_State => Schema_State,
                                    N            => I) then
            Location := I;
            exit;
         end if;

      end loop;

      return Location;
   end Tag_Stack_Hunt_Down;

   function Get_Req_Attributes (Schema       : in Schema_Record;
                                Schema_State : in Schema_State_Record) return Tag_Attribute_Array is
      Tag_Attribute_List : Tag_Attribute_Array;

      -- Tag Attributes that we have found.
      RAID      : Tag_Attribute_Array       := Tag_Attribute_Array'(others => Null_Attribute);
      Next_Slot : Tag_Attribute_Array_Index := Tag_Attribute_Array_Index'First;  -- Pointer to end of the list.
   begin
      Tag_Attribute_List := Get_Tag_Attributes (Schema => Schema,
                                                TID    => Schema_State.Working_Tag.TID);

      for Current_Attribute in Tag_Attribute_Array_Index loop
         --# assert Next_Slot >= Tag_Attribute_Array_Index'First and
         --#   Next_Slot <= Current_Attribute;
         if Attribute_Is_Required (Schema => Schema,
                                   AID    => Tag_Attribute_List (Current_Attribute)) then
            RAID (Next_Slot) := Tag_Attribute_List (Current_Attribute);

            -- If there is room for another, increment the Next_Slot.
            -- As both arrays are the same size, if this condition fails then the loop
            -- will exit.
            if Next_Slot < Tag_Attribute_Array_Index'Last then
               Next_Slot := Next_Slot + 1;
            end if;
         end if;
      end loop;

      return RAID;
   end Get_Req_Attributes;

   function Attribute_Is_Set (Schema_State : in Schema_State_Record;
                              AID          : in Attribute_ID) return Boolean is
      Success : Boolean := False;
   begin
      for I in Tag_Attribute_Array_Index loop

         if Schema_State.Working_Tag.Attribs (I).AID = AID then
            Success := True;
            exit;
         end if;
      end loop;

      return Success;
   end Attribute_Is_Set;

   function All_Required_Attributes (Schema       : in Schema_Record;
                                     Schema_State : in Schema_State_Record) return Boolean is
      Required : Tag_Attribute_Array;
      Success  : Boolean := True;
   begin
      Required := Get_Req_Attributes (Schema       => Schema,
                                      Schema_State => Schema_State);

      for I in Tag_Attribute_Array_Index loop
         if not Attribute_Is_Set (Schema_State => Schema_State,
                                  AID          => Required (I)) then
            Success := False;
            exit;
         end if;
      end loop;

      return Success;
   end All_Required_Attributes;

   function Valid_Working_Tag (Schema       : in Schema_Record;
                               Schema_State : in Schema_State_Record) return Boolean is
   begin
      return All_Required_Attributes (Schema       => Schema,
                                      Schema_State => Schema_State) and
        (not (Schema_State.Working_Tag = Empty_Working_Tag));
   end Valid_Working_Tag;

   -----------
   -- Debug --
   -----------

   function Is_Error (Error : in Schema_Status) return Boolean is
   begin
      return not (Error = SS_OK);
   end Is_Error;

   procedure Print_Schema_Error (Error : in Schema_Status) is
      --# hide Print_Schema_Error;
      type Message_Array is array (Schema_Status) of String (1 .. 55);

      Messages : constant Message_Array :=
        Message_Array'
        (SS_OK                 => "Schema state OK                                        ",
         SS_Invalid_Attribute  => "Invalid attribute for working tag                      ",
         SS_Invalid_Tag        => "Invalid tag at this point                              ",
         SS_To_Many_Attributes => "Reached attribute limit                                ",
         SS_Wrong_Content_Type => "Attempt to assign value of incorrect type to attribute ",
         SS_Stack_Full         => "The Schema Stack is full                               ",
         SS_Stack_Empty        => "The Schema Stack is empty                              ",
         SS_Tag_Incomplete     => "One or more required attribute is missing              ",
         SS_Invalid_Depth      => "There are no tags at this depth                        ",
         SS_No_Such_Tag        => "The specified tag is not in the schema                 ",
         SS_Tag_Not_Found      => "Could not find an instance of that tag in the hierarchy");

   begin
      SPARK_IO.Put_Line (SPARK_IO.Standard_Output, Messages (Error), 55);
   end Print_Schema_Error;

   procedure Print_Working_State (Schema       : in Schema_Record;
                                  Schema_State : in Schema_State_Record) is
      --# hide Print_Working_State;

      procedure Print_Tag_Schema (Tag : in Tag_ID) is
      begin
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "<<<<<<<<<< Tag Schema >>>>>>>>>>"));
         E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                               E_Str => X_Str (Str => "Tag : "));
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => Get_Tag_Name (Schema => Schema,
                                                    TID    => Tag));
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => " "));
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "Attributes"));
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "----------"));

         for I in Tag_Attribute_Array_Index loop

            declare
               Tmp_Attribute_ID : constant Attribute_ID := Get_Tag_Attribute (Schema => Schema,
                                                                              TID    => Tag,
                                                                              TAID   => I);
            begin
               if Attribute_Is_Required (Schema => Schema,
                                         AID    => Tmp_Attribute_ID) then
                  E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                        E_Str => X_Str (Str => " * "));
               else
                  E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                        E_Str => X_Str (Str => "   "));
               end if;

               E_Strings.Put_String
                 (File  => SPARK_IO.Standard_Output,
                  E_Str => Get_Attribute_Name (Schema => Schema,
                                               AID    => Tmp_Attribute_ID));

               case Get_Attribute_Type (Schema => Schema,
                                        AID    => Tmp_Attribute_ID) is
                  when At_String =>
                     E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                                         E_Str => X_Str (Str => "  STRING"));
                  when At_Integer =>
                     E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                                         E_Str => X_Str (Str => "  INTEGER"));
                  when At_Float =>
                     E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                                         E_Str => X_Str (Str => "  FLOAT"));
                  when At_Null =>
                     E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                                         E_Str => X_Str (Str => ""));
               end case;

            end;

         end loop;

         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "Child Tags"));
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "----------"));

         for I in Child_Tag_Array_Index loop

            declare
               Tmp_Child : constant Child_Tag := Get_Child_Tag (Schema => Schema,
                                                                TID    => Tag,
                                                                CTID   => I);
            begin
               if Tmp_Child.Required then
                  E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                        E_Str => X_Str (Str => " * "));
               else
                  E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                        E_Str => X_Str (Str => "   "));
               end if;

               E_Strings.Put_Line
                 (File  => SPARK_IO.Standard_Output,
                  E_Str => Get_Tag_Name (Schema => Schema,
                                         TID    => Tmp_Child.Child));

            end;

         end loop;
      end Print_Tag_Schema;

      procedure Print_Working_Tag_State is

         procedure Print_Working_Attribute (Attrib : in Tag_Attribute_Array_Index) is
         begin
            E_Strings.Put_String
              (File  => SPARK_IO.Standard_Output,
               E_Str => Get_Attribute_Name (Schema => Schema,
                                            AID    => Schema_State.Working_Tag.Attribs (Attrib).AID));

            E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                  E_Str => X_Str (Str => " = "));

            E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                                E_Str => Schema_State.Working_Tag.Attribs (Attrib).Val);
         end Print_Working_Attribute;

      begin
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "<<<<<<< Working_Tag State >>>>>>>"));

         for I in Tag_Attribute_Array_Index loop
            Print_Working_Attribute (Attrib => I);
         end loop;
      end Print_Working_Tag_State;

      procedure Print_Stack is
      begin
         E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                             E_Str => X_Str (Str => "<<<<<<<<<< Tag Stack  >>>>>>>>>>"));

         for I in Tag_Depth loop
            E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                  E_Str => X_Str (Str => Tag_Depth'Image (I)));
            E_Strings.Put_String (File  => SPARK_IO.Standard_Output,
                                  E_Str => X_Str (Str => " "));
            E_Strings.Put_Line
              (File  => SPARK_IO.Standard_Output,
               E_Str => Get_Tag_Name (Schema => Schema,
                                      TID    => Tag_Stack_Peek_N (Schema_State => Schema_State,
                                                                  N            => I)));

            exit when I = Schema_State.Tag_Stack.Current;
         end loop;
      end Print_Stack;

   begin
      E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                          E_Str => X_Str (Str => "================"));
      E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                          E_Str => X_Str (Str => "START DEBUG DUMP "));
      E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                          E_Str => X_Str (Str => "================"));

      Print_Tag_Schema (Tag => Schema_State.Working_Tag.TID);
      Print_Tag_Schema (Tag => Tag_Stack_Peek (Schema_State => Schema_State));
      Print_Working_Tag_State;
      Print_Stack;

      E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                          E_Str => X_Str (Str => "================"));
      E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                          E_Str => X_Str (Str => " END DEBUG DUMP "));
      E_Strings.Put_Line (File  => SPARK_IO.Standard_Output,
                          E_Str => X_Str (Str => "================"));
   end Print_Working_State;

   ------------------
   -- Tag Creation --
   ------------------

   -- This should only be used carefully.  It opens a tag without first checking that
   -- it is a legal child of the presently open tag.  This is for use when tags have to
   -- be generated out of order.

   procedure Init_Opening_Tag_No_Check (Schema_State : in out Schema_State_Record;
                                        TID          : in     Tag_ID;
                                        Status       :    out Schema_Status) is
   begin
      if Tag_Stack_Full (Schema_State => Schema_State) then  -- Check that we can actually generate another tag

         Status := SS_Stack_Full;

      else
         if Is_Null_Tag (TID => TID) then
            Status := SS_No_Such_Tag;  -- Null tag.
         else
            Schema_State.Working_Tag :=
              Working_Tag_Type'
              (TID     => TID,
               Attribs => Working_Attribute_Array'(others => Working_Attribute'(AID => Null_Attribute,
                                                                                Val => E_Strings.Empty_String)));
            Status                   := SS_OK;
         end if;

      end if;
   end Init_Opening_Tag_No_Check;

   -- Opening tags
   -- Initialise the opening tag, then add attributes to it.
   -- Then call Output_Opening_Tag to return the string.

   procedure Init_Opening_Tag_By_ID
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      TID          : in     Tag_ID;
      Status       :    out Schema_Status)
   is
   begin
      if Tag_Stack_Full (Schema_State => Schema_State) then  -- Check that we can actually generate another tag

         Status := SS_Stack_Full;

      else
         if Is_Legal_Child (Schema => Schema,
                            Parent => Tag_Stack_Peek (Schema_State => Schema_State),
                            Child  => TID) then

            Schema_State.Working_Tag :=
              Working_Tag_Type'
              (TID     => TID,
               Attribs => Working_Attribute_Array'(others => Working_Attribute'(AID => Null_Attribute,
                                                                                Val => E_Strings.Empty_String)));

            Status := SS_OK;

         else
            Schema_State.Working_Tag := Empty_Working_Tag;
            Status                   := SS_Invalid_Tag;
         end if;
      end if;
   end Init_Opening_Tag_By_ID;

   procedure Init_Opening_Tag
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      Status       :    out Schema_Status)
   is
   begin
      Init_Opening_Tag_By_ID
        (Schema       => Schema,
         Schema_State => Schema_State,
         TID          => Find_Tag (Schema => Schema,
                                   Name   => Name),
         Status       => Status);
   end Init_Opening_Tag;

   procedure Find_Attribute
     (Schema    : in     Schema_Record;
      Tag_Ident : in     Tag_ID;
      Name      : in     E_Strings.T;
      CType     : in     Attribute_Type;
      AID       :    out Attribute_ID;
      Status    :    out Schema_Status)
   --# derives AID,
   --#         Status from CType,
   --#                     Name,
   --#                     Schema,
   --#                     Tag_Ident;
   is
      A_Array : Tag_Attribute_Array;
      Found   : Attribute_ID := Null_Attribute;
   begin
      A_Array := Get_Tag_Attributes (Schema => Schema,
                                     TID    => Tag_Ident);

      for I in Tag_Attribute_Array_Index loop
         if E_Strings.Eq_String (E_Str1 => Name,
                                 E_Str2 => Get_Attribute_Name (Schema => Schema,
                                                               AID    => A_Array (I))) then
            Found := A_Array (I);
            exit;
         end if;
      end loop;

      if Is_Null_Attribute (AID => Found) then
         Status := SS_Invalid_Attribute;
         AID    := Null_Attribute;
      elsif not (Get_Attribute_Type (Schema => Schema,
                                     AID    => Found) = CType) then
         Status := SS_Wrong_Content_Type;
         AID    := Null_Attribute;
      else
         Status := SS_OK;
         AID    := Found;
      end if;
   end Find_Attribute;

   procedure Add_Working_Attribute
     (Schema_State : in out Schema_State_Record;
      AID          : in     Attribute_ID;
      Value        : in     E_Strings.T;
      Status       :    out Schema_Status)
   --# derives Schema_State from *,
   --#                           AID,
   --#                           Value &
   --#         Status       from Schema_State;
   is
      Found : Tag_Attribute_Array_Index := Tag_Attribute_Array_Index'First;
   begin
      -- Find the next free slot
      for I in Tag_Attribute_Array_Index loop
         if Is_Null_Attribute (AID => Get_Working_Attribute_ID (Schema_State => Schema_State,
                                                                TAID         => I)) then
            Found := I;
            exit;
         end if;
      end loop;

      -- Add the attribute to the working tag
      if Is_Null_Attribute (AID => Get_Working_Attribute_ID (Schema_State => Schema_State,
                                                             TAID         => Found)) then
         Set_Working_Attribute (Schema_State, Found, AID, Filter_String (Str => Value));
         Status := SS_OK;
      else
         -- We didn't find a free spot
         Status := SS_To_Many_Attributes;
      end if;
   end Add_Working_Attribute;

   procedure Add_Attribute_Str
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      Value        : in     E_Strings.T;
      Status       :    out Schema_Status)
   is
      Tmp_Attribute : Attribute_ID;
      Tmp_Status    : Schema_Status;
   begin
      -- Find the attribute in the schema
      Find_Attribute
        (Schema    => Schema,
         Tag_Ident => Schema_State.Working_Tag.TID,
         Name      => Name,
         CType     => At_String,
         AID       => Tmp_Attribute,
         Status    => Tmp_Status);

      if not (Tmp_Status = SS_OK) then
         Status := Tmp_Status;
      else
         Add_Working_Attribute (Schema_State => Schema_State,
                                AID          => Tmp_Attribute,
                                Value        => Value,
                                Status       => Status);
      end if;
   end Add_Attribute_Str;

   -- Removes all spaces from an Examiner_String
   -- In XML, a non-string attribute cannot contain spaces.
   function Strip_String (Str : in E_Strings.T) return E_Strings.T is
      Ch         : Character;
      Old_String : E_Strings.T;
      New_String : E_Strings.T := E_Strings.Empty_String;
   begin

      Old_String := Str;

      while (E_Strings.Get_Length (E_Str => Old_String) > 0) loop
         E_Strings.Pop_Char (E_Str => Old_String,
                             Char  => Ch);
         if not (Ch = ' ') then
            E_Strings.Append_Char (E_Str => New_String,
                                   Ch    => Ch);
         end if;
      end loop;

      return New_String;

   end Strip_String;

   procedure Add_Attribute_Int
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      Value        : in     Integer;
      Status       :    out Schema_Status)
   is

      Tmp_Attribute : Attribute_ID;
      Tmp_Status    : Schema_Status;
      Tmp_String    : E_Strings.T;
   begin
      -- Find the attribute in the schema
      Find_Attribute
        (Schema    => Schema,
         Tag_Ident => Schema_State.Working_Tag.TID,
         Name      => Name,
         CType     => At_Integer,
         AID       => Tmp_Attribute,
         Status    => Tmp_Status);

      if not (Tmp_Status = SS_OK) then
         Status := Tmp_Status;
      else
         E_Strings.Put_Int_To_String (Dest     => Tmp_String,
                                      Item     => Value,
                                      Start_Pt => 1,
                                      Base     => 10);

         Add_Working_Attribute
           (Schema_State => Schema_State,
            AID          => Tmp_Attribute,
            Value        => Strip_String (Str => Tmp_String),
            Status       => Status);
      end if;
   end Add_Attribute_Int;

   function Output_Attributes (Schema       : in Schema_Record;
                               Schema_State : in Schema_State_Record) return E_Strings.T is
      Temp_String : E_Strings.T := E_Strings.Empty_String;
   begin
      for I in Tag_Attribute_Array_Index loop

         if not Is_Null_Attribute (AID => Get_Working_Attribute_ID (Schema_State => Schema_State,
                                                                    TAID         => I)) then
            E_Strings.Append_String (E_Str => Temp_String,
                                     Str   => " ");

            E_Strings.Append_Examiner_String
              (E_Str1 => Temp_String,
               E_Str2 => Get_Attribute_Name (Schema => Schema,
                                             AID    => Schema_State.Working_Tag.Attribs (I).AID));

            E_Strings.Append_String (E_Str => Temp_String,
                                     Str   => "=""");
            E_Strings.Append_Examiner_String
              (E_Str1 => Temp_String,
               E_Str2 => Get_Working_Attribute_Val (Schema_State => Schema_State,
                                                    TAID         => I));
            E_Strings.Append_String (E_Str => Temp_String,
                                     Str   => """");
         end if;

         exit when Is_Null_Attribute (AID => Get_Working_Attribute_ID (Schema_State => Schema_State,
                                                                       TAID         => I));

      end loop;

      return Temp_String;
   end Output_Attributes;

   procedure Output_Opening_Tag
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      XML          :    out E_Strings.T;
      Depth        :    out Tag_Depth;
      Status       :    out Schema_Status)
   is
      Temp_String        : E_Strings.T := E_Strings.Empty_String;
      Indent_Temp_String : E_Strings.T := E_Strings.Empty_String;
      Tmp_Depth          : Tag_Depth   := Tag_Depth'First;
      Tmp_Status         : Schema_Status;
   begin
      if Valid_Working_Tag (Schema       => Schema,
                            Schema_State => Schema_State) then

         -- Start with "<tagname "

         E_Strings.Append_String (E_Str => Temp_String,
                                  Str   => "<");
         E_Strings.Append_Examiner_String
           (E_Str1 => Temp_String,
            E_Str2 => Get_Tag_Name (Schema => Schema,
                                    TID    => Schema_State.Working_Tag.TID));

         -- Add the attributes

         E_Strings.Append_Examiner_String
           (E_Str1 => Temp_String,
            E_Str2 => Output_Attributes (Schema       => Schema,
                                         Schema_State => Schema_State));

         -- End the opening Tag
         E_Strings.Append_String (E_Str => Temp_String,
                                  Str   => ">");

         -- Push the tag onto the top of the tagstack;
         Tag_Stack_Push (Schema_State => Schema_State,
                         Depth        => Tmp_Depth,
                         Status       => Tmp_Status);

         XML := E_Strings.Empty_String;
         if (Tmp_Status = SS_Stack_Full) then -- The stack is full
            Depth  := Tmp_Depth;
            Status := Tmp_Status;
         else
            Status := SS_OK;
            Depth  := Tmp_Depth;
            E_Strings.Append_Char (E_Str => Indent_Temp_String,
                                   Ch    => Ada.Characters.Latin_1.LF);
            for I in Tag_Depth range 2 .. Tmp_Depth loop
               E_Strings.Append_Char (E_Str => Indent_Temp_String,
                                      Ch    => ' ');
            end loop;
            E_Strings.Append_Examiner_String (E_Str1 => Indent_Temp_String,
                                              E_Str2 => Temp_String);
            XML := Indent_Temp_String;
         end if;

      else
         Status := SS_Tag_Incomplete;
         Depth  := Tmp_Depth;
         XML    := E_Strings.Empty_String;
      end if;
   end Output_Opening_Tag;

   function Closing_Tag_String
     (Schema       : in Schema_Record;
      Schema_State : in Schema_State_Record;
      TID          : in Tag_ID)
     return         E_Strings.T
   is
      Tmp_String : E_Strings.T := E_Strings.Empty_String;
   begin
      E_Strings.Append_Char (E_Str => Tmp_String,
                             Ch    => Ada.Characters.Latin_1.LF);
      for I in Tag_Depth range 2 .. Tag_Stack_Depth (Schema_State => Schema_State) + 1 loop
         -- Put in some indentation
         E_Strings.Append_Char (E_Str => Tmp_String,
                                Ch    => ' ');
      end loop;
      E_Strings.Append_String (E_Str => Tmp_String,
                               Str   => "</");
      E_Strings.Append_Examiner_String (E_Str1 => Tmp_String,
                                        E_Str2 => Get_Tag_Name (Schema => Schema,
                                                                TID    => TID));
      E_Strings.Append_String (E_Str => Tmp_String,
                               Str   => ">");
      return Tmp_String;
   end Closing_Tag_String;

   -- Closing tags
   procedure Close_Tag
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Depth        : in     Tag_Depth;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status)
   is
      Tmp_String      : E_Strings.T   := E_Strings.Empty_String;
      Closing_Tag     : Tag_ID;
      Tmp_Status      : Schema_Status := SS_OK;
      Closing_Tag_Str : E_Strings.T;
   begin
      if Tag_Stack_Empty (Schema_State => Schema_State) then  -- Everything is already closed

         Status := SS_Stack_Empty;
         XML    := Tmp_String;

      elsif (Depth > Tag_Stack_Depth (Schema_State => Schema_State)) -- Whoops, trying to close an unopened tag
        or
        (Depth = Tag_Depth'First) then  -- or the empty tag.

         Status := SS_Invalid_Depth;
         XML    := Tmp_String;

      else
         while (Depth <= Tag_Stack_Depth (Schema_State => Schema_State)) loop

            Tag_Stack_Pop (Schema_State => Schema_State,
                           TID          => Closing_Tag,
                           Status       => Tmp_Status);

            exit when not (Tmp_Status = SS_OK);

            Closing_Tag_Str := Closing_Tag_String (Schema       => Schema,
                                                   Schema_State => Schema_State,
                                                   TID          => Closing_Tag);
            E_Strings.Append_Examiner_String (E_Str1 => Tmp_String,
                                              E_Str2 => Closing_Tag_Str);

         end loop;

         Status := Tmp_Status;
         XML    := Tmp_String;

      end if;
   end Close_Tag;

   -- Close the lowest tag in the stack that matches TID
   procedure Close_Tag_By_ID
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      TID          : in     Tag_ID;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status)
   is
      Depth : Tag_Depth;
   begin
      Depth := Tag_Stack_Hunt_Up (Schema_State => Schema_State,
                                  TID          => TID);

      if Depth = Tag_Depth'First then  -- Not found

         Status := SS_Tag_Not_Found;
         XML    := E_Strings.Empty_String;

      else
         Close_Tag (Schema       => Schema,
                    Schema_State => Schema_State,
                    Depth        => Depth,
                    XML          => XML,
                    Status       => Status);

      end if;
   end Close_Tag_By_ID;

   -- Close the lowest tag in the stack that matches TID
   procedure Close_Top_Tag_By_ID
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      TID          : in     Tag_ID;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status)
   is
      Depth : Tag_Depth;
   begin
      Depth := Tag_Stack_Hunt_Down (Schema_State => Schema_State,
                                    TID          => TID);

      if Depth = Tag_Depth'First then  -- Not found

         Status := SS_Tag_Not_Found;
         XML    := E_Strings.Empty_String;

      else
         Close_Tag (Schema       => Schema,
                    Schema_State => Schema_State,
                    Depth        => Depth,
                    XML          => XML,
                    Status       => Status);

      end if;
   end Close_Top_Tag_By_ID;

   -- Close the lowest tag in the stack that matches TID
   procedure Close_Tag_By_Name
     (Schema       : in     Schema_Record;
      Schema_State : in out Schema_State_Record;
      Name         : in     E_Strings.T;
      XML          :    out E_Strings.T;
      Status       :    out Schema_Status)
   is
      TID : Tag_ID;
   begin
      TID := Find_Tag (Schema => Schema,
                       Name   => Name);

      if Is_Null_Tag (TID => TID) then
         Status := SS_No_Such_Tag;
         XML    := E_Strings.Empty_String;
      else
         Close_Tag_By_ID (Schema       => Schema,
                          Schema_State => Schema_State,
                          TID          => TID,
                          XML          => XML,
                          Status       => Status);
      end if;
   end Close_Tag_By_Name;

end SPARK_XML;
