-----------------------------------------------------------------------
--  ADO Databases -- Database Connections
--  Copyright (C) 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log;
with Util.Log.Loggers;

with ADO.SQL;
with Ada.Unchecked_Deallocation;
with System.Address_Image;
package body ADO.Databases is

   use Util.Log;
   use ADO.Drivers;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Databases");

   --  ------------------------------
   --  Get the database connection status.
   --  ------------------------------
   function Get_Status (Database : in Connection) return Connection_Status is
   begin
      if Database.Impl = null then
         return CLOSED;
      else
         return OPEN;
      end if;
   end Get_Status;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      declare
         Query : Query_Statement_Access := Database.Impl.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create_Statement (Query);
      end;
   end Create_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Connection;
                              Query    : in String)
                              return Query_Statement is
   begin
      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      declare
         Stmt : Query_Statement_Access := Database.Impl.all.Create_Statement (null);
      begin
         Append (Query => Stmt.all, SQL => Query);
         return ADO.Statements.Create_Statement (Stmt);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   procedure Load_Schema (Database : in Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      if Database.Impl = null then
         Log.Error ("Database connection is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      Database.Impl.Load_Schema (Schema);
   end Load_Schema;

   --  ------------------------------
   --  Close the database connection
   --  ------------------------------
   procedure Close (Database : in out Connection) is
   begin
      Log.Info ("Closing database connection");

      if Database.Impl /= null then
         Database.Impl.Close;
      end if;
   end Close;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Master_Connection) is
   begin
      Log.Info ("Begin transaction");

      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      Database.Impl.Begin_Transaction;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Master_Connection) is
   begin
      Log.Info ("Commit transaction");

      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      Database.Impl.Commit;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Master_Connection) is
   begin
      Log.Info ("Rollback transaction");

      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "Database implementation is not initialized";
      end if;
      Database.Impl.Rollback;
   end Rollback;

   procedure Execute (Database : in Master_Connection;
                      SQL      : in Query_String) is
   begin
      Log.Info ("Execute: {0}", SQL);

      Database.Impl.Execute (SQL);
   end Execute;

   procedure Execute (Database : in Master_Connection;
                      SQL      : in Query_String;
                      Id       : out Identifier) is
   begin
      Log.Info ("Execute: {0}", SQL);

      Database.Impl.Execute (SQL, Id);
   end Execute;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   function Create_Statement (Database : in Master_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Log.Info ("Create delete statement");

      declare
         Stmt : Delete_Statement_Access := Database.Impl.all.Create_Statement (Table);
      begin
         return Create_Statement (Stmt);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   function Create_Statement (Database : in Master_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Log.Info ("Create insert statement");

      declare
         Stmt : constant Insert_Statement_Access := Database.Impl.all.Create_Statement (Table);
      begin
         return Create_Statement (Stmt.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   function Create_Statement (Database : in Master_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Log.Info ("Create insert statement");

      return Create_Statement (Database.Impl.all.Create_Statement (Table));
   end Create_Statement;

   --  ------------------------------
   --  Adjust the connection reference counter
   --  ------------------------------
   overriding
   procedure Adjust   (Object : in out Connection) is
   begin
      if Object.Impl /= null then
         Log.Debug ("Adjust {0} : {1}", System.Address_Image (Object.Impl.all'Address),
                    Natural'Image (Object.Impl.Count));
         Object.Impl.Count := Object.Impl.Count + 1;
      end if;
   end Adjust;

   --  ------------------------------
   --  Releases the connection reference counter
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Connection) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Database_Connection'Class,
                                    Name   => Database_Connection_Access);

   begin
      if Object.Impl /= null then
         Log.Debug ("Finalize {0} : {1}", System.Address_Image (Object.Impl.all'Address),
                    Natural'Image (Object.Impl.Count));
         Object.Impl.Count := Object.Impl.Count - 1;
         if Object.Impl.Count = 0 then
            Free (Object.Impl);
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Attempts to establish a connection with the data source
   --  that this DataSource object represents.
   --  ------------------------------
   function Get_Connection (Controller : in DataSource)
                           return Master_Connection'Class is
      Connection : ADO.Drivers.Database_Connection_Access;
   begin
      Log.Info ("Get master connection from data-source");

      Controller.Create_Connection (Connection);
      return Master_Connection '(Ada.Finalization.Controlled with
                                 Impl => Connection);
   end Get_Connection;

   --  ------------------------------
   --  Set the master data source
   --  ------------------------------
   procedure Set_Master (Controller : in out Replicated_DataSource;
                         Master     : in DataSource_Access) is
   begin
      Controller.Master := Master;
   end Set_Master;

   --  ------------------------------
   --  Get the master data source
   --  ------------------------------
   function Get_Master (Controller : in Replicated_DataSource)
                       return DataSource_Access is
   begin
      return Controller.Master;
   end Get_Master;

   --  ------------------------------
   --  Set the slave data source
   --  ------------------------------
   procedure Set_Slave (Controller : in out Replicated_DataSource;
                        Slave      : in DataSource_Access) is
   begin
      Controller.Slave := Slave;
   end Set_Slave;

   --  ------------------------------
   --  Get the slave data source
   --  ------------------------------
   function Get_Slave (Controller : in Replicated_DataSource)
                      return DataSource_Access is
   begin
      return Controller.Slave;
   end Get_Slave;

   --  ------------------------------
   --  Get a slave database connection
   --  ------------------------------
   function Get_Slave_Connection (Controller : in Replicated_DataSource)
                                 return Connection'Class is
   begin
      return Controller.Slave.Get_Connection;
   end Get_Slave_Connection;

end ADO.Databases;

-----------------------------------------------------------------------
--  ADO Databases -- Database Connections
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log;
with Util.Log.Loggers;

with Ada.Unchecked_Deallocation;
with System.Address_Image;
with ADO.Statements.Create;
package body ADO.Databases is

   use Util.Log;
   use ADO.Drivers;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Databases");

   --  ------------------------------
   --  Get the database connection status.
   --  ------------------------------
   function Get_Status (Database : in Connection) return Connection_Status is
   begin
      if Database.Impl = null then
         return CLOSED;
      else
         return OPEN;
      end if;
   end Get_Status;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      declare
         Query : constant Query_Statement_Access := Database.Impl.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Query);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Connection;
                              Query    : in String)
                              return Query_Statement is
   begin
      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      declare
         Stmt : constant Query_Statement_Access := Database.Impl.all.Create_Statement (null);
      begin
         Append (Query => Stmt.all, SQL => Query);
         return ADO.Statements.Create.Create_Statement (Stmt);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   procedure Load_Schema (Database : in Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      if Database.Impl = null then
         Log.Error ("Database connection is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      Database.Impl.Load_Schema (Schema);
   end Load_Schema;

   --  ------------------------------
   --  Close the database connection
   --  ------------------------------
   procedure Close (Database : in out Connection) is
   begin
      Log.Info ("Closing database connection");

      if Database.Impl /= null then
         Database.Impl.Close;
      end if;
   end Close;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Master_Connection) is
   begin
      Log.Info ("Begin transaction");

      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      Database.Impl.Begin_Transaction;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Master_Connection) is
   begin
      Log.Info ("Commit transaction");

      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "No connection to the database";
      end if;
      Database.Impl.Commit;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Master_Connection) is
   begin
      Log.Info ("Rollback transaction");

      if Database.Impl = null then
         Log.Error ("Database implementation is not initialized");
         raise NOT_OPEN with "Database implementation is not initialized";
      end if;
      Database.Impl.Rollback;
   end Rollback;

   procedure Execute (Database : in Master_Connection;
                      SQL      : in Query_String) is
   begin
      Log.Info ("Execute: {0}", SQL);

      Database.Impl.Execute (SQL);
   end Execute;

   procedure Execute (Database : in Master_Connection;
                      SQL      : in Query_String;
                      Id       : out Identifier) is
   begin
      Log.Info ("Execute: {0}", SQL);

      Database.Impl.Execute (SQL, Id);
   end Execute;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   function Create_Statement (Database : in Master_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Log.Info ("Create delete statement");

      declare
         Stmt : constant Delete_Statement_Access := Database.Impl.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   function Create_Statement (Database : in Master_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Log.Info ("Create insert statement");

      declare
         Stmt : constant Insert_Statement_Access := Database.Impl.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   function Create_Statement (Database : in Master_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Log.Info ("Create update statement");

      return ADO.Statements.Create.Create_Statement (Database.Impl.all.Create_Statement (Table));
   end Create_Statement;

   --  ------------------------------
   --  Adjust the connection reference counter
   --  ------------------------------
   overriding
   procedure Adjust   (Object : in out Connection) is
   begin
      if Object.Impl /= null then
         Log.Debug ("Adjust {0} : {1}", System.Address_Image (Object.Impl.all'Address),
                    Natural'Image (Object.Impl.Count));
         Object.Impl.Count := Object.Impl.Count + 1;
      end if;
   end Adjust;

   --  ------------------------------
   --  Releases the connection reference counter
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Connection) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Database_Connection'Class,
                                    Name   => Database_Connection_Access);

   begin
      if Object.Impl /= null then
         Log.Debug ("Finalize {0} : {1}", System.Address_Image (Object.Impl.all'Address),
                    Natural'Image (Object.Impl.Count));
         Object.Impl.Count := Object.Impl.Count - 1;
         if Object.Impl.Count = 0 then
            Free (Object.Impl);
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Attempts to establish a connection with the data source
   --  that this DataSource object represents.
   --  ------------------------------
   function Get_Connection (Controller : in DataSource)
                           return Master_Connection'Class is
      Connection : ADO.Drivers.Database_Connection_Access;
   begin
      Log.Info ("Get master connection from data-source");

      Controller.Create_Connection (Connection);
      return Master_Connection '(Ada.Finalization.Controlled with
                                 Impl => Connection);
   end Get_Connection;

   --  ------------------------------
   --  Set the master data source
   --  ------------------------------
   procedure Set_Master (Controller : in out Replicated_DataSource;
                         Master     : in DataSource_Access) is
   begin
      Controller.Master := Master;
   end Set_Master;

   --  ------------------------------
   --  Get the master data source
   --  ------------------------------
   function Get_Master (Controller : in Replicated_DataSource)
                       return DataSource_Access is
   begin
      return Controller.Master;
   end Get_Master;

   --  ------------------------------
   --  Set the slave data source
   --  ------------------------------
   procedure Set_Slave (Controller : in out Replicated_DataSource;
                        Slave      : in DataSource_Access) is
   begin
      Controller.Slave := Slave;
   end Set_Slave;

   --  ------------------------------
   --  Get the slave data source
   --  ------------------------------
   function Get_Slave (Controller : in Replicated_DataSource)
                      return DataSource_Access is
   begin
      return Controller.Slave;
   end Get_Slave;

   --  ------------------------------
   --  Get a slave database connection
   --  ------------------------------
   function Get_Slave_Connection (Controller : in Replicated_DataSource)
                                 return Connection'Class is
   begin
      return Controller.Slave.Get_Connection;
   end Get_Slave_Connection;

end ADO.Databases;

Use the Create_Statement functions now defined in ADO.Statements.Create package


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2022 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

private with Ada.Containers.Indefinite_Holders;

with Orka.Numerics.Tensors;

generic
   with package Tensors is new Orka.Numerics.Tensors (<>);
   type Tensor (<>) is new Tensors.Tensor with private;
package Orka.Numerics.Kalman is
   pragma Preelaborate;

   use type Tensors.Tensor_Dimension;
   use type Tensors.Tensor_Shape;
   use type Tensors.Element_Type;

   subtype Vector is Tensor;
   subtype Matrix is Tensor;

   type Update_Phase is (Time_Update, Measurement_Update);

   type Filter_Kind is (Filter_UKF, Filter_CDKF);

   type State_Covariance is private;

   type Weights_Type (N : Positive; Kind : Filter_Kind) is private;

   type Filter (Kind : Filter_Kind; Dimension_X, Dimension_Z : Positive) is tagged private;

   function State (Object : Filter) return Vector
     with Post => State'Result.Shape = (1 => Object.Dimension_X);

private

   subtype Element_Type is Tensors.Element_Type;

   package Tensor_Holders is new Ada.Containers.Indefinite_Holders (Tensor);

   --  These predicates cannot be applied to the formal types above
   subtype Vector_Holder is Tensor_Holders.Holder
     with Dynamic_Predicate => Tensor_Holders.Constant_Reference (Vector_Holder).Dimensions = 1;
   subtype Matrix_Holder is Tensor_Holders.Holder
     with Dynamic_Predicate => Tensor_Holders.Constant_Reference (Matrix_Holder).Dimensions = 2;

   type Weights_Type (N : Positive; Kind : Filter_Kind) is record
      Mean           : Vector_Holder;
      Scaling_Factor : Element_Type;
      case Kind is
         when Filter_UKF =>
            Covariance : Vector_Holder;
         when Filter_CDKF =>
            Covariance_1 : Vector_Holder;
            Covariance_2 : Vector_Holder;
      end case;
   end record;

   type State_Covariance is record
      State      : Vector_Holder;
      Covariance : Matrix_Holder;
   end record;

   type Filter (Kind : Filter_Kind; Dimension_X, Dimension_Z : Positive) is tagged record
      Process_Noise     : Matrix_Holder;
      Measurement_Noise : Matrix_Holder;

      Weights  : Weights_Type (Dimension_X, Kind);
      Estimate : State_Covariance;
   end record;

   function State (Object : Filter) return Vector is (Object.Estimate.State.Element);

end Orka.Numerics.Kalman;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2022 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

private with Ada.Containers.Indefinite_Holders;

with Orka.Numerics.Tensors;

generic
   with package Tensors is new Orka.Numerics.Tensors (<>);
   type Tensor (<>) is new Tensors.Tensor with private;
package Orka.Numerics.Kalman is
   pragma Preelaborate;

   use type Tensors.Tensor_Dimension;
   use type Tensors.Tensor_Shape;
   use type Tensors.Element_Type;

   subtype Vector is Tensor;
   subtype Matrix is Tensor;

   type Update_Phase is (Time_Update, Measurement_Update);

   type Filter_Kind is (Filter_UKF, Filter_CDKF);

   type State_Covariance is private;

   type Weights_Type (N : Positive; Kind : Filter_Kind) is private;

   type Filter (Kind : Filter_Kind; Dimension_X, Dimension_Z : Positive) is tagged private;

   function State (Object : Filter) return Vector
     with Post => State'Result.Shape = (1 => Object.Dimension_X);

private

   subtype Element_Type is Tensors.Element_Type;

   package Tensor_Holders is new Ada.Containers.Indefinite_Holders (Tensor);

   --  These predicates cannot be applied to the formal types above
   subtype Vector_Holder is Tensor_Holders.Holder
     with Dynamic_Predicate => Vector_Holder.Element.Dimensions = 1;
   subtype Matrix_Holder is Tensor_Holders.Holder
     with Dynamic_Predicate => Matrix_Holder.Element.Dimensions = 2;

   type Weights_Type (N : Positive; Kind : Filter_Kind) is record
      Mean           : Vector_Holder;
      Scaling_Factor : Element_Type;
      case Kind is
         when Filter_UKF =>
            Covariance : Vector_Holder;
         when Filter_CDKF =>
            Covariance_1 : Vector_Holder;
            Covariance_2 : Vector_Holder;
      end case;
   end record;

   type State_Covariance is record
      State      : Vector_Holder;
      Covariance : Matrix_Holder;
   end record;

   type Filter (Kind : Filter_Kind; Dimension_X, Dimension_Z : Positive) is tagged record
      Process_Noise     : Matrix_Holder;
      Measurement_Noise : Matrix_Holder;

      Weights  : Weights_Type (Dimension_X, Kind);
      Estimate : State_Covariance;
   end record;

   function State (Object : Filter) return Vector is (Object.Estimate.State.Element);

end Orka.Numerics.Kalman;

numerics: Fix Dynamic_Predicate to satisfy GNAT FSF 11

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  wiki-streams-html-stream -- Generic Wiki HTML output stream
--  Copyright (C) 2016, 2020, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Wiki.Helpers;
package body Wiki.Streams.Html.Stream is

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Stream'Class);

   --  Write the string to the stream.
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String);

   --  ------------------------------
   --  Set the indentation level for HTML output stream.
   --  ------------------------------
   overriding
   procedure Set_Indent_Level (Writer : in out Html_Output_Stream;
                               Indent : in Natural) is
   begin
      Writer.Indent_Level := Indent;
   end Set_Indent_Level;

   --  ------------------------------
   --  Write an optional newline or space.
   --  ------------------------------
   overriding
   procedure Newline (Writer : in out Html_Output_Stream) is
   begin
      if Writer.Indent_Level > 0 and Writer.Text_Length > 0 then
         Writer.Write (Wiki.Helpers.LF);
         Writer.Empty_Line := True;
      end if;
      Writer.Text_Length := 0;
   end Newline;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
         Stream.Empty_Line := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the string to the stream.
   --  ------------------------------
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Stream.Write (Wiki.Strings.To_WChar (Content (I)));
      end loop;
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      end if;
   end Write_String;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.UString) is
   begin
      if Stream.Close_Start then
         Html.Write_Escape_Attribute (Stream, Name, Wiki.Strings.To_WString (Content));
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is
   begin
      if Stream.Close_Start then
         Stream.Write_Escape_Attribute (Name, Content);
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Start an XML element with the given name.
   --  ------------------------------
   overriding
   procedure Start_Element (Stream : in out Html_Output_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Indent_Pos := Stream.Indent_Pos + Stream.Indent_Level;
      if Stream.Indent_Pos > 1 then
         if not Stream.Empty_Line then
            Stream.Write (Helpers.LF);
         end if;
         for I in 1 .. Stream.Indent_Pos loop
            Stream.Write (' ');
         end loop;
      end if;
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
      Stream.Text_Length := 0;
      Stream.Empty_Line := False;
   end Start_Element;

   --  ------------------------------
   --  Closes an XML element of the given name.
   --  ------------------------------
   overriding
   procedure End_Element (Stream : in out Html_Output_Stream;
                          Name   : in String) is
   begin
      if Stream.Indent_Pos > Stream.Indent_Level then
         Stream.Indent_Pos := Stream.Indent_Pos - Stream.Indent_Level;
      end if;
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         if Stream.Text_Length = 0 then
            if not Stream.Empty_Line and Stream.Indent_Level > 0 then
               Stream.Write (Wiki.Helpers.LF);
            end if;
            if Stream.Indent_Pos > 1 then
               Stream.Write (Helpers.LF);
               for I in 1 .. Stream.Indent_Pos loop
                  Stream.Write (' ');
               end loop;
            end if;
         end if;
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
      if Stream.Indent_Level > 0 then
         Stream.Write (Wiki.Helpers.LF);
         Stream.Empty_Line := True;
      end if;
      Stream.Text_Length := 0;
   end End_Element;

   --  ------------------------------
   --  Write a text escaping any character as necessary.
   --  ------------------------------
   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      Stream.Write_Escape (Content);
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      else
         Stream.Write (' ');
      end if;
   end Write_Wide_Text;

end Wiki.Streams.Html.Stream;

-----------------------------------------------------------------------
--  wiki-streams-html-stream -- Generic Wiki HTML output stream
--  Copyright (C) 2016, 2020, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Wiki.Helpers;
package body Wiki.Streams.Html.Stream is

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Stream'Class);

   --  Write the string to the stream.
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String);

   --  ------------------------------
   --  Set the indentation level for HTML output stream.
   --  ------------------------------
   overriding
   procedure Set_Indent_Level (Writer : in out Html_Output_Stream;
                               Indent : in Natural) is
   begin
      Writer.Indent_Level := Indent;
   end Set_Indent_Level;

   --  ------------------------------
   --  Write an optional newline or space.
   --  ------------------------------
   overriding
   procedure Newline (Writer : in out Html_Output_Stream) is
   begin
      if Writer.Indent_Level > 0 and Writer.Text_Length > 0 then
         Writer.Write (Wiki.Helpers.LF);
         Writer.Empty_Line := True;
      end if;
      Writer.Text_Length := 0;
   end Newline;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
         Stream.Empty_Line := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the string to the stream.
   --  ------------------------------
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Stream.Write (Wiki.Strings.To_WChar (Content (I)));
      end loop;
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      end if;
   end Write_String;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.UString) is
   begin
      if Stream.Close_Start then
         Html.Write_Escape_Attribute (Stream, Name, Wiki.Strings.To_WString (Content));
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is
   begin
      if Stream.Close_Start then
         Stream.Write_Escape_Attribute (Name, Content);
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Start an XML element with the given name.
   --  ------------------------------
   overriding
   procedure Start_Element (Stream : in out Html_Output_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      if Stream.Indent_Pos > 1 then
         if not Stream.Empty_Line then
            Stream.Write (Helpers.LF);
         end if;
         for I in 1 .. Stream.Indent_Pos loop
            Stream.Write (' ');
         end loop;
      end if;
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
      Stream.Text_Length := 0;
      Stream.Empty_Line := False;
      Stream.Indent_Pos := Stream.Indent_Pos + Stream.Indent_Level;
   end Start_Element;

   --  ------------------------------
   --  Closes an XML element of the given name.
   --  ------------------------------
   overriding
   procedure End_Element (Stream : in out Html_Output_Stream;
                          Name   : in String) is
   begin
      if Stream.Indent_Pos >= Stream.Indent_Level then
         Stream.Indent_Pos := Stream.Indent_Pos - Stream.Indent_Level;
      end if;
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         if Stream.Text_Length = 0 then
            if not Stream.Empty_Line and Stream.Indent_Level > 0 then
               Stream.Write (Wiki.Helpers.LF);
            end if;
            if Stream.Indent_Pos > 1 then
               Stream.Write (Helpers.LF);
               for I in 1 .. Stream.Indent_Pos loop
                  Stream.Write (' ');
               end loop;
            end if;
         end if;
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
      if Stream.Indent_Level > 0 then
         Stream.Write (Wiki.Helpers.LF);
         Stream.Empty_Line := True;
      end if;
      Stream.Text_Length := 0;
   end End_Element;

   --  ------------------------------
   --  Write a text escaping any character as necessary.
   --  ------------------------------
   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      Stream.Write_Escape (Content);
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      else
         Stream.Write (' ');
      end if;
   end Write_Wide_Text;

end Wiki.Streams.Html.Stream;

Update indentation of output HTML stream


-----------------------------------------------------------------------
--  wiki-nodes -- Wiki Document Internal representation
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body Wiki.Documents is

   use Wiki.Nodes;

   --  ------------------------------
   --  Append a HTML tag start node to the document.
   --  ------------------------------
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List) is

      Node : constant Node_Type_Access := new Node_Type '(Kind       => N_TAG_START,
                                                          Len        => 0,
                                                          Tag_Start  => Tag,
                                                          Attributes => Attributes,
                                                          Children   => null,
                                                          Parent     => Into.Current);
   begin
      Append (Into, Node);
      Into.Current := Node;
   end Push_Node;

   --  ------------------------------
   --  Pop the HTML tag.
   --  ------------------------------
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag) is
      pragma Unreferenced (Tag);
   begin
      if From.Current /= null then
         From.Current := From.Current.Parent;
      end if;
   end Pop_Node;

   --  ------------------------------
   --  Append a section header at end of the document.
   --  ------------------------------
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive) is
   begin
      Append (Into, new Node_Type '(Kind   => N_HEADER,
                                    Len    => Header'Length,
                                    Header => Header,
                                    Level  => Level));
   end Append;

   --  ------------------------------
   --  Append a node to the document.
   --  ------------------------------
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access) is
   begin
      if Into.Current = null then
         Append (Into.Nodes, Node);
      else
         Append (Into.Current, Node);
      end if;
   end Append;

   --  ------------------------------
   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   --  ------------------------------
   procedure Append (Into : in out Document;
                     Kind : in Simple_Node_Kind) is
   begin
      case Kind is
         when N_LINE_BREAK =>
            Append (Into, new Node_Type '(Kind => N_LINE_BREAK, Len => 0));

         when N_HORIZONTAL_RULE =>
            Append (Into, new Node_Type '(Kind => N_HORIZONTAL_RULE, Len => 0));

         when N_PARAGRAPH =>
            Append (Into, new Node_Type '(Kind => N_PARAGRAPH, Len => 0));

         when N_TOC_DISPLAY =>
            Append (Into, new Node_Type '(Kind => N_TOC_DISPLAY, Len => 0));
            Into.Using_TOC := True;

      end  case;
   end Append;

   --  ------------------------------
   --  Append the text with the given format at end of the document.
   --  ------------------------------
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map) is
   begin
      Append (Into, new Node_Type '(Kind => N_TEXT, Len => Text'Length,
                                    Text => Text, Format => Format));
   end Append;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Append (Into, new Node_Type '(Kind => N_LINK, Len => Name'Length,
                                    Title => Name, Link_Attr => Attributes));
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Append (Into, new Node_Type '(Kind => N_IMAGE, Len => Name'Length,
                                    Title => Name, Link_Attr => Attributes));
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Append (Into, new Node_Type '(Kind => N_QUOTE, Len => Name'Length,
                                    Title => Name, Link_Attr => Attributes));
   end Add_Quote;

   --  ------------------------------
   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   procedure Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
   begin
      if Ordered then
         Append (Into, new Node_Type '(Kind => N_NUM_LIST, Len => 0,
                                       Level => Level, others => <>));
      else
         Append (Into, new Node_Type '(Kind => N_LIST, Len => 0,
                                       Level => Level, others => <>));
      end if;
   end Add_List_Item;

   --  ------------------------------
   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   procedure Add_Blockquote (Into     : in out Document;
                             Level    : in Natural) is
   begin
      Append (Into, new Node_Type '(Kind => N_BLOCKQUOTE, Len => 0,
                                    Level => Level, others => <>));
   end Add_Blockquote;

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString) is
   begin
      Append (Into, new Node_Type '(Kind => N_PREFORMAT, Len => Text'Length,
                                    Preformatted => Text, others => <>));
   end Add_Preformatted;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Node_Type)) is
   begin
      Iterate (Doc.Nodes, Process);
   end Iterate;

   --  ------------------------------
   --  Returns True if the document is empty.
   --  ------------------------------
   function Is_Empty (Doc : in Document) return Boolean is
   begin
      return Wiki.Nodes.Is_Empty (Doc.Nodes);
   end Is_Empty;

   --  ------------------------------
   --  Returns True if the document displays the table of contents by itself.
   --  ------------------------------
   function Is_Using_TOC (Doc : in Document) return Boolean is
   begin
      return Doc.Using_TOC;
   end Is_Using_TOC;

   --  ------------------------------
   --  Get the table of content node associated with the document.
   --  ------------------------------
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Node_List_Ref) is
   begin
      if Wiki.Nodes.Is_Empty (Doc.TOC) then
         Append (Doc.TOC, new Node_Type '(Kind => N_TOC, Len => 0, others => <>));
      end if;
      TOC := Doc.TOC;
   end Get_TOC;

   --  ------------------------------
   --  Get the table of content node associated with the document.
   --  ------------------------------
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Node_List_Ref is
   begin
      return Doc.TOC;
   end Get_TOC;

end Wiki.Documents;

-----------------------------------------------------------------------
--  wiki-nodes -- Wiki Document Internal representation
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body Wiki.Documents is

   use Wiki.Nodes;

   --  ------------------------------
   --  Append a HTML tag start node to the document.
   --  ------------------------------
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List) is

      Node : constant Node_Type_Access := new Node_Type '(Kind       => N_TAG_START,
                                                          Len        => 0,
                                                          Tag_Start  => Tag,
                                                          Attributes => Attributes,
                                                          Children   => null,
                                                          Parent     => Into.Current);
   begin
      Append (Into, Node);
      Into.Current := Node;
   end Push_Node;

   --  ------------------------------
   --  Pop the HTML tag.
   --  ------------------------------
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag) is
      pragma Unreferenced (Tag);
   begin
      if From.Current /= null then
         From.Current := From.Current.Parent;
      end if;
   end Pop_Node;

   --  ------------------------------
   --  Returns True if the current node is the root document node.
   --  ------------------------------
   function Is_Root_Node (Doc : in Document) return Boolean is
   begin
      return Doc.Current = null;
   end Is_Root_Node;

   --  ------------------------------
   --  Append a section header at end of the document.
   --  ------------------------------
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive) is
   begin
      Append (Into, new Node_Type '(Kind   => N_HEADER,
                                    Len    => Header'Length,
                                    Header => Header,
                                    Level  => Level));
   end Append;

   --  ------------------------------
   --  Append a node to the document.
   --  ------------------------------
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access) is
   begin
      if Into.Current = null then
         Append (Into.Nodes, Node);
      else
         Append (Into.Current, Node);
      end if;
   end Append;

   --  ------------------------------
   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   --  ------------------------------
   procedure Append (Into : in out Document;
                     Kind : in Simple_Node_Kind) is
   begin
      case Kind is
         when N_LINE_BREAK =>
            Append (Into, new Node_Type '(Kind => N_LINE_BREAK, Len => 0));

         when N_HORIZONTAL_RULE =>
            Append (Into, new Node_Type '(Kind => N_HORIZONTAL_RULE, Len => 0));

         when N_PARAGRAPH =>
            Append (Into, new Node_Type '(Kind => N_PARAGRAPH, Len => 0));

         when N_TOC_DISPLAY =>
            Append (Into, new Node_Type '(Kind => N_TOC_DISPLAY, Len => 0));
            Into.Using_TOC := True;

      end  case;
   end Append;

   --  ------------------------------
   --  Append the text with the given format at end of the document.
   --  ------------------------------
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map) is
   begin
      Append (Into, new Node_Type '(Kind => N_TEXT, Len => Text'Length,
                                    Text => Text, Format => Format));
   end Append;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Append (Into, new Node_Type '(Kind => N_LINK, Len => Name'Length,
                                    Title => Name, Link_Attr => Attributes));
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Append (Into, new Node_Type '(Kind => N_IMAGE, Len => Name'Length,
                                    Title => Name, Link_Attr => Attributes));
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      Append (Into, new Node_Type '(Kind => N_QUOTE, Len => Name'Length,
                                    Title => Name, Link_Attr => Attributes));
   end Add_Quote;

   --  ------------------------------
   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   procedure Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
   begin
      if Ordered then
         Append (Into, new Node_Type '(Kind => N_NUM_LIST, Len => 0,
                                       Level => Level, others => <>));
      else
         Append (Into, new Node_Type '(Kind => N_LIST, Len => 0,
                                       Level => Level, others => <>));
      end if;
   end Add_List_Item;

   --  ------------------------------
   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   procedure Add_Blockquote (Into     : in out Document;
                             Level    : in Natural) is
   begin
      Append (Into, new Node_Type '(Kind => N_BLOCKQUOTE, Len => 0,
                                    Level => Level, others => <>));
   end Add_Blockquote;

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString) is
   begin
      Append (Into, new Node_Type '(Kind => N_PREFORMAT, Len => Text'Length,
                                    Preformatted => Text, others => <>));
   end Add_Preformatted;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Node_Type)) is
   begin
      Iterate (Doc.Nodes, Process);
   end Iterate;

   --  ------------------------------
   --  Returns True if the document is empty.
   --  ------------------------------
   function Is_Empty (Doc : in Document) return Boolean is
   begin
      return Wiki.Nodes.Is_Empty (Doc.Nodes);
   end Is_Empty;

   --  ------------------------------
   --  Returns True if the document displays the table of contents by itself.
   --  ------------------------------
   function Is_Using_TOC (Doc : in Document) return Boolean is
   begin
      return Doc.Using_TOC;
   end Is_Using_TOC;

   --  ------------------------------
   --  Get the table of content node associated with the document.
   --  ------------------------------
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Node_List_Ref) is
   begin
      if Wiki.Nodes.Is_Empty (Doc.TOC) then
         Append (Doc.TOC, new Node_Type '(Kind => N_TOC, Len => 0, others => <>));
      end if;
      TOC := Doc.TOC;
   end Get_TOC;

   --  ------------------------------
   --  Get the table of content node associated with the document.
   --  ------------------------------
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Node_List_Ref is
   begin
      return Doc.TOC;
   end Get_TOC;

end Wiki.Documents;

Implement Is_Root_Node function

Implement Is_Root_Node function


-----------------------------------------------------------------------
--  mat-readers-marshaller -- Marshalling of data in communication buffer
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with MAT.Types;
with MAT.Events;
package MAT.Readers.Marshaller is

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   --  Get an 8-bit value from the buffer.
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   --  Get a 16-bit value either from big-endian or little endian.
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   --  Get a 32-bit value either from big-endian or little endian.
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   --  Get a 64-bit value either from big-endian or little endian.
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Message_Type) return String;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Msg : in Message_Type) return Ada.Strings.Unbounded.Unbounded_String;

   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Message_Type;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;

   function Get_Target_Size (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size;

   function Get_Target_Addr (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr;

   function Get_Target_Uint32 (Msg  : in Message_Type;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32;

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Message_Type;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

-----------------------------------------------------------------------
--  mat-readers-marshaller -- Marshalling of data in communication buffer
--  Copyright (C) 2014, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with MAT.Types;
with MAT.Events;
package MAT.Readers.Marshaller is

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   --  Get an 8-bit value from the buffer.
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   --  Get a 16-bit value either from big-endian or little endian.
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   --  Get a 32-bit value either from big-endian or little endian.
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   --  Get a 64-bit value either from big-endian or little endian.
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Message_Type) return String;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Msg : in Message_Type) return Ada.Strings.Unbounded.Unbounded_String;

   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Message_Type;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;

   function Get_Target_Size (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size;

   function Get_Target_Addr (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr;

   function Get_Target_Uint32 (Msg  : in Message_Type;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32;

   function Get_Target_Process_Ref (Msg  : in Message_Type;
                                    Kind : in MAT.Events.Attribute_Type)
                                    return MAT.Types.Target_Process_Ref;

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Message_Type;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

Declare Get_Target_Process_Ref function

Declare Get_Target_Process_Ref function


-----------------------------------------------------------------------
--  core-factory -- Factory for Core UI Components
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ASF.Components.Html.Text;
with ASF.Components.Html.Lists;
with ASF.Components.Core;
with ASF.Views.Nodes;
with Util.Strings.Escapes; use Util.Strings;
with EL.Functions.Default;
package body ASF.Components.Util.Factory is

   function Create_View return UIComponent_Access;
   function Create_Parameter return UIComponent_Access;

   --  ------------------------------
   --  Create an UIView component
   --  ------------------------------
   function Create_View return UIComponent_Access is
   begin
      return new ASF.Components.Core.UIView;
   end Create_View;

   --  ------------------------------
   --  Create an UIParameter component
   --  ------------------------------
   function Create_Parameter return UIComponent_Access is
   begin
      return new ASF.Components.Core.UIParameter;
   end Create_Parameter;

   use ASF.Views.Nodes;

   URI        : aliased constant String := "http://code.google.com/p/ada-asf/util";
   VIEW_TAG   : aliased constant String := "view";
   PARAM_TAG  : aliased constant String := "param";
   LIST_TAG   : aliased constant String := "list";

   Core_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => PARAM_TAG'Access,
               Component => Create_Parameter'Access,
               Tag       => Create_Component_Node'Access),
         2 => (Name      => VIEW_TAG'Access,
               Component => Create_View'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Core_Bindings'Access);

   --  ------------------------------
   --  Get the HTML component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

   --  Truncate the string representation represented by Value to
   --  the length specified by Size.
   function Escape_Javascript (Value : EL.Objects.Object) return EL.Objects.Object;

   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
   begin
      Mapper.Set_Function (Name      => "escapeJavaScript",
                           Namespace => URI,
                           Func      => Escape_Javascript'Access);
   end Set_Functions;

   function Escape_Javascript (Value : EL.Objects.Object) return EL.Objects.Object is
      Result  : Ada.Strings.Unbounded.Unbounded_String;
      Content : constant String := EL.Objects.To_String (Value);
   begin
      Escapes.Escape_Javascript (Content => Content,
                                 Into    => Result);
      return EL.Objects.To_Object (Result);
   end Escape_Javascript;

begin
   ASF.Factory.Check (Core_Factory);
end ASF.Components.Util.Factory;

-----------------------------------------------------------------------
--  core-factory -- Factory for Core UI Components
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ASF.Components.Core;
with ASF.Views.Nodes;
with Util.Strings.Transforms; use Util.Strings;
with EL.Functions.Default;
package body ASF.Components.Util.Factory is

   function Create_View return UIComponent_Access;
   function Create_Parameter return UIComponent_Access;

   --  ------------------------------
   --  Create an UIView component
   --  ------------------------------
   function Create_View return UIComponent_Access is
   begin
      return new ASF.Components.Core.UIView;
   end Create_View;

   --  ------------------------------
   --  Create an UIParameter component
   --  ------------------------------
   function Create_Parameter return UIComponent_Access is
   begin
      return new ASF.Components.Core.UIParameter;
   end Create_Parameter;

   use ASF.Views.Nodes;

   URI        : aliased constant String := "http://code.google.com/p/ada-asf/util";
   VIEW_TAG   : aliased constant String := "view";
   PARAM_TAG  : aliased constant String := "param";
   LIST_TAG   : aliased constant String := "list";

   Core_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => PARAM_TAG'Access,
               Component => Create_Parameter'Access,
               Tag       => Create_Component_Node'Access),
         2 => (Name      => VIEW_TAG'Access,
               Component => Create_View'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Core_Bindings'Access);

   --  ------------------------------
   --  Get the HTML component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

   --  Truncate the string representation represented by Value to
   --  the length specified by Size.
   function Escape_Javascript (Value : EL.Objects.Object) return EL.Objects.Object;

   --  Escape the string using XML escape rules.
   function Escape_Xml (Value : EL.Objects.Object) return EL.Objects.Object;

   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
   begin
      Mapper.Set_Function (Name      => "escapeJavaScript",
                           Namespace => URI,
                           Func      => Escape_Javascript'Access);
      Mapper.Set_Function (Name      => "escapeXml",
                           Namespace => URI,
                           Func      => Escape_Xml'Access);
   end Set_Functions;

   function Escape_Javascript (Value : EL.Objects.Object) return EL.Objects.Object is
      Result  : Ada.Strings.Unbounded.Unbounded_String;
      Content : constant String := EL.Objects.To_String (Value);
   begin
      Transforms.Escape_Javascript (Content => Content,
                                    Into    => Result);
      return EL.Objects.To_Object (Result);
   end Escape_Javascript;

   function Escape_Xml (Value : EL.Objects.Object) return EL.Objects.Object is
      Result  : Ada.Strings.Unbounded.Unbounded_String;
      Content : constant String := EL.Objects.To_String (Value);
   begin
      Transforms.Escape_Xml (Content => Content,
                             Into    => Result);
      return EL.Objects.To_Object (Result);
   end Escape_Xml;

begin
   ASF.Factory.Check (Core_Factory);
end ASF.Components.Util.Factory;

Add escapeXml function

Add escapeXml function


-----------------------------------------------------------------------
--  asf.server -- ASF Server
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Finalization;
with Ada.Strings.Unbounded;

with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
package ASF.Server is

   type Container is tagged limited private;

   --  Register the application to serve requests
   procedure Register_Application (Server  : in out Container;
                                   URI     : in String;
                                   Context : in ASF.Servlets.Servlet_Registry_Access);

   --  Remove the application
   procedure Remove_Application (Server  : in out Container;
                                 Context : in ASF.Servlets.Servlet_Registry_Access);

   --  Start the applications that have been registered.
   procedure Start (Server : in out Container);

   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   procedure Service (Server   : in Container;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class);

   --  Get the current registry associated with the current request being processed
   --  by the current thread.  Returns null if there is no current request.
   function Current return ASF.Servlets.Servlet_Registry_Access;

   --  Give access to the current request and response object to the Process
   --  procedure.  If there is no current request for the thread, do nothing.
   procedure Update_Context (Process : not null access
                               procedure (Request  : in out Requests.Request'Class;
                                          Response : in out Responses.Response'Class));

private

   --  Binding to record the ASF applications and bind them to URI prefixes.
   --  It is expected that the number of ASF applications is small (1-10 per server).
   type Binding is record
      Context  : ASF.Servlets.Servlet_Registry_Access;
      Base_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Binding_Array is array (Natural range <>) of Binding;
   type Binding_Array_Access is access all Binding_Array;

   type Container is new Ada.Finalization.Limited_Controlled with record
      Nb_Bindings  : Natural := 0;
      Applications : Binding_Array_Access := null;
      Default      : ASF.Servlets.Servlet_Registry;
      Is_Started   : Boolean := False;
   end record;

   type Request_Context is record
      Application : ASF.Servlets.Servlet_Registry_Access;
      Request     : ASF.Requests.Request_Access;
      Response    : ASF.Responses.Response_Access;
   end record;

   --  Set the current registry.  This is called by Service once the
   --  registry is identified from the URI.
   procedure Set_Context (Context : in Request_Context);

   --  Release the storage.
   overriding
   procedure Finalize (Server : in out Container);

end ASF.Server;

-----------------------------------------------------------------------
--  asf-server -- ASF Server
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Servlet.Server;
package ASF.Server renames Servlet.Server;

Package ASF.Server moved to Servlet.Server


------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Atom_Buffers is

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count) is
      Old_Size, New_Size : Count := 0;
   begin
      if Buffer.Used + Length <= Buffer.Available then
         return;
      end if;

      Old_Size := Buffer.Available;
      New_Size := Buffer.Used + Length;

      if Buffer.Ref.Is_Empty then
         declare
            function Create return Atom;

            function Create return Atom is
            begin
               return Atom'(1 .. New_Size => <>);
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      else
         declare
            function Create return Atom;

            Old_Accessor : constant Atom_Refs.Accessor := Buffer.Ref.Query;

            function Create return Atom is
            begin
               return Result : Atom (1 .. New_Size) do
                  Result (1 .. Old_Size) := Old_Accessor.Data.all;
               end return;
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      end if;

      Buffer.Available := New_Size;
   end Preallocate;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom) is
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1 .. Buffer.Used + Data'Length)
        := Data;
      Buffer.Used := Buffer.Used + Data'Length;
   end Append;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet) is
   begin
      Preallocate (Buffer, 1);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1) := Data;
      Buffer.Used := Buffer.Used + 1;
   end Append;

   procedure Append_Reverse (Buffer : in out Atom_Buffer; Data : in Atom) is
      procedure Process (Target : in out Atom);

      procedure Process (Target : in out Atom) is
      begin
         for I in reverse Data'Range loop
            Buffer.Used := Buffer.Used + 1;
            Target (Buffer.Used) := Data (I);
         end loop;
      end Process;
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update (Process'Access);
   end Append_Reverse;

   procedure Invert (Buffer : in out Atom_Buffer) is
      procedure Process (Data : in out Atom);

      procedure Process (Data : in out Atom) is
         Low : Count := Data'First;
         High : Count := Buffer.Used;
         Tmp : Octet;
      begin
         while Low < High loop
            Tmp := Data (Low);
            Data (Low) := Data (High);
            Data (High) := Tmp;
            Low := Low + 1;
            High := High - 1;
         end loop;
      end Process;
   begin
      if not Buffer.Ref.Is_Empty then
         Buffer.Ref.Update (Process'Access);
      end if;
   end Invert;

   function Length (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Used;
   end Length;

   function Data (Buffer : Atom_Buffer) return Atom is
   begin
      if Buffer.Ref.Is_Empty then
         pragma Assert (Buffer.Available = 0 and Buffer.Used = 0);
         return Null_Atom;
      else
         return Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
      end if;
   end Data;

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor is
      function Create return Atom;

      function Create return Atom is
      begin
         return Null_Atom;
      end Create;
   begin
      if Buffer.Ref.Is_Empty then
         return Atom_Refs.Create (Create'Access).Query;
      else
         return Buffer.Ref.Query;
      end if;
   end Raw_Query;

   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Buffer.Ref.Is_Empty then
         Process.all (Null_Atom);
      else
         Process.all (Buffer.Ref.Query.Data.all (1 .. Buffer.Used));
      end if;
   end Query;

   procedure Read
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count)
   is
      Transmit : constant Count := Count'Min (Data'Length, Buffer.Used);
   begin
      Length := Buffer.Used;

      if Buffer.Ref.Is_Empty then
         pragma Assert (Length = 0);
         null;
      else
         Data (Data'First .. Data'First + Transmit - 1)
           := Buffer.Ref.Query.Data.all (1 .. Transmit);
      end if;
   end Read;

   function Element (Buffer : Atom_Buffer; Position : Count) return Octet is
   begin
      return Buffer.Ref.Query.Data.all (Position);
   end Element;

   procedure Pop (Buffer : in out Atom_Buffer; Data : out Octet) is
   begin
      Data := Buffer.Ref.Query.Data.all (Buffer.Used);
      Buffer.Used := Buffer.Used - 1;
   end Pop;

   procedure Hard_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Ref.Reset;
      Buffer.Available := 0;
      Buffer.Used := 0;
   end Hard_Reset;

   procedure Soft_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Used := 0;
   end Soft_Reset;

end Natools.S_Expressions.Atom_Buffers;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Atom_Buffers is

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count) is
      Old_Size, New_Size : Count := 0;
   begin
      if Buffer.Used + Length <= Buffer.Available then
         return;
      end if;

      Old_Size := Buffer.Available;
      New_Size := Buffer.Used + Length;

      if Buffer.Ref.Is_Empty then
         declare
            function Create return Atom;

            function Create return Atom is
            begin
               return Atom'(1 .. New_Size => <>);
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      else
         declare
            function Create return Atom;

            Old_Accessor : constant Atom_Refs.Accessor := Buffer.Ref.Query;

            function Create return Atom is
            begin
               return Result : Atom (1 .. New_Size) do
                  Result (1 .. Old_Size) := Old_Accessor.Data.all;
               end return;
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      end if;

      Buffer.Available := New_Size;
   end Preallocate;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom) is
   begin
      if Data'Length > 0 then
         Preallocate (Buffer, Data'Length);
         Buffer.Ref.Update.Data.all
           (Buffer.Used + 1 .. Buffer.Used + Data'Length)
           := Data;
         Buffer.Used := Buffer.Used + Data'Length;
      end if;
   end Append;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet) is
   begin
      Preallocate (Buffer, 1);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1) := Data;
      Buffer.Used := Buffer.Used + 1;
   end Append;

   procedure Append_Reverse (Buffer : in out Atom_Buffer; Data : in Atom) is
      procedure Process (Target : in out Atom);

      procedure Process (Target : in out Atom) is
      begin
         for I in reverse Data'Range loop
            Buffer.Used := Buffer.Used + 1;
            Target (Buffer.Used) := Data (I);
         end loop;
      end Process;
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update (Process'Access);
   end Append_Reverse;

   procedure Invert (Buffer : in out Atom_Buffer) is
      procedure Process (Data : in out Atom);

      procedure Process (Data : in out Atom) is
         Low : Count := Data'First;
         High : Count := Buffer.Used;
         Tmp : Octet;
      begin
         while Low < High loop
            Tmp := Data (Low);
            Data (Low) := Data (High);
            Data (High) := Tmp;
            Low := Low + 1;
            High := High - 1;
         end loop;
      end Process;
   begin
      if not Buffer.Ref.Is_Empty then
         Buffer.Ref.Update (Process'Access);
      end if;
   end Invert;

   function Length (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Used;
   end Length;

   function Data (Buffer : Atom_Buffer) return Atom is
   begin
      if Buffer.Ref.Is_Empty then
         pragma Assert (Buffer.Available = 0 and Buffer.Used = 0);
         return Null_Atom;
      else
         return Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
      end if;
   end Data;

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor is
      function Create return Atom;

      function Create return Atom is
      begin
         return Null_Atom;
      end Create;
   begin
      if Buffer.Ref.Is_Empty then
         return Atom_Refs.Create (Create'Access).Query;
      else
         return Buffer.Ref.Query;
      end if;
   end Raw_Query;

   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Buffer.Ref.Is_Empty then
         Process.all (Null_Atom);
      else
         Process.all (Buffer.Ref.Query.Data.all (1 .. Buffer.Used));
      end if;
   end Query;

   procedure Read
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count)
   is
      Transmit : constant Count := Count'Min (Data'Length, Buffer.Used);
   begin
      Length := Buffer.Used;

      if Buffer.Ref.Is_Empty then
         pragma Assert (Length = 0);
         null;
      else
         Data (Data'First .. Data'First + Transmit - 1)
           := Buffer.Ref.Query.Data.all (1 .. Transmit);
      end if;
   end Read;

   function Element (Buffer : Atom_Buffer; Position : Count) return Octet is
   begin
      return Buffer.Ref.Query.Data.all (Position);
   end Element;

   procedure Pop (Buffer : in out Atom_Buffer; Data : out Octet) is
   begin
      Data := Buffer.Ref.Query.Data.all (Buffer.Used);
      Buffer.Used := Buffer.Used - 1;
   end Pop;

   procedure Hard_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Ref.Reset;
      Buffer.Available := 0;
      Buffer.Used := 0;
   end Hard_Reset;

   procedure Soft_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Used := 0;
   end Soft_Reset;

end Natools.S_Expressions.Atom_Buffers;

s_expressions-atom_buffers: fix exception when appending an empty atom to an empty buffer


-----------------------------------------------------------------------
--  Frames - Representation of stack frames
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with MAT.Types; use MAT.Types;
with MAT.Events;
package MAT.Frames is

   Not_Found : exception;

   type Frame is limited private;
   type Frame_Ptr is access all Frame;

   subtype PC_Table is MAT.Events.Frame_Table;

   function Parent (F : in Frame_Ptr) return Frame_Ptr;
   --  Return the parent frame.

   function Backtrace (F : in Frame_Ptr) return PC_Table;
   --  Returns the backtrace of the current frame (up to the root).

   function Calls (F : in Frame_Ptr) return PC_Table;
   --  Returns all the direct calls made by the current frame.

   function Count_Children (F : in Frame_Ptr;
                            Recursive : in Boolean := False) return Natural;
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.

   function Current_Depth (F : in Frame_Ptr) return Natural;
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).

   function Create_Root return Frame_Ptr;
   --  Create a root for stack frame representation.

   procedure Destroy (Tree : in out Frame_Ptr);
   --  Destroy the frame tree recursively.

   procedure Release (F : in Frame_Ptr);
   --  Release the frame when its reference is no longer necessary.

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr);

   function Find (F : in Frame_Ptr;
                  Pc : in Target_Addr) return Frame_Ptr;
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.

   function Find (F : in Frame_Ptr;
                  Pc : in Pc_Table) return Frame_Ptr;
   --

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural);
private

   Frame_Group_Size : constant Natural := 4;

   subtype Local_Depth_Type is Natural range 0 .. Frame_Group_Size;

   subtype Frame_Table is Pc_Table (1 .. Local_Depth_Type'Last);

   type Frame is record
      Parent   : Frame_Ptr := null;
      Next     : Frame_Ptr := null;
      Children : Frame_Ptr := null;
      Used     : Natural   := 0;
      Depth    : Natural   := 0;
      Calls    : Frame_Table;
      Local_Depth : Local_Depth_Type := 0;
   end record;

end MAT.Frames;

-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with MAT.Types;
with MAT.Events;
package MAT.Frames is

   Not_Found : exception;

   type Frame_Type is private;

   subtype Frame_Table is MAT.Events.Frame_Table;

   --  Return the parent frame.
   function Parent (Frame : in Frame_Type) return Frame_Type;

   --  Returns the backtrace of the current frame (up to the root).
   function Backtrace (Frame : in Frame_Type) return Frame_Table;

   --  Returns all the direct calls made by the current frame.
   function Calls (Frame : in Frame_Type) return Frame_Table;

   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural;

   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   function Current_Depth (F : in Frame_Type) return Natural;

   --  Create a root for stack frame representation.
   function Create_Root return Frame_Type;

   --  Destroy the frame tree recursively.
   procedure Destroy (Tree : in out Frame_Type);

   --  Release the frame when its reference is no longer necessary.
   procedure Release (Frame : in Frame_Type);

   procedure Insert (Frame : in Frame_Type;
                     Pc : in Frame_Table;
                     Result : out Frame_Type);

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type;

   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural);
private

   Frame_Group_Size : constant Natural := 4;

   subtype Local_Depth_Type is Natural range 0 .. Frame_Group_Size;

   subtype Mini_Frame_Table is Frame_Table (1 .. Local_Depth_Type'Last);

   type Frame;
   type Frame_Type is access all Frame;

   type Frame is record
      Parent   : Frame_Type := null;
      Next     : Frame_Type := null;
      Children : Frame_Type := null;
      Used     : Natural   := 0;
      Depth    : Natural   := 0;
      Calls    : Mini_Frame_Table;
      Local_Depth : Local_Depth_Type := 0;
   end record;

end MAT.Frames;

Refactor the frame implementation - Define Frame_Type - Keep Frame a private type - Fix parameter names