--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  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 GL.API.Uniforms.Singles;
with GL.API.Uniforms.Doubles;
with GL.API.Uniforms.Ints;
with GL.API.Uniforms.UInts;
with GL.Low_Level;

package body GL.Objects.Programs.Uniforms is

   function Create_Uniform (Object : Program; Location : Int) return Uniform is
   begin
      return Uniform'(Program => Object, Location => Location);
   end Create_Uniform;

   -----------------------------------------------------------------------------
   --                                 Singles                                 --
   -----------------------------------------------------------------------------

   procedure Set_Single (Location : Uniform; Value : Single) is
   begin
      API.Uniforms.Singles.Uniform1 (Location.Program.Reference.GL_Id,
                                     Location.Location, Value);
   end Set_Single;

   procedure Set_Singles (Location : Uniform; V1, V2 : Single) is
   begin
      API.Uniforms.Singles.Uniform2 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2);
   end Set_Singles;

   procedure Set_Single_Vector (Location : Uniform; Value : Singles.Vector2) is
   begin
      API.Uniforms.Singles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, 2, (1 => Value));
   end Set_Single_Vector;

   procedure Set_Singles (Location : Uniform; V1, V2, V3 : Single) is
   begin
      API.Uniforms.Singles.Uniform3 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3);
   end Set_Singles;

   procedure Set_Single_Vector (Location : Uniform; Value : Singles.Vector3) is
   begin
      API.Uniforms.Singles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, 3, (1 => Value));
   end Set_Single_Vector;

   procedure Set_Singles (Location : Uniform; V1, V2, V3, V4 : Single) is
   begin
      API.Uniforms.Singles.Uniform4 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3, V4);
   end Set_Singles;

   procedure Set_Single_Vector (Location : Uniform; Value : Singles.Vector4) is
   begin
      API.Uniforms.Singles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, 4, (1 => Value));
   end Set_Single_Vector;

   procedure Set_Single_Array (Location : Uniform; Value : Single_Array) is
   begin
      API.Uniforms.Singles.Uniform1v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Array;

   procedure Set_Single_Vectors (Location : Uniform; Value : Singles.Vector2_Array) is
   begin
      API.Uniforms.Singles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Vectors;

   procedure Set_Single_Vectors (Location : Uniform; Value : Singles.Vector3_Array) is
   begin
      API.Uniforms.Singles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Vectors;

   procedure Set_Single_Vectors (Location : Uniform; Value : Singles.Vector4_Array) is
   begin
      API.Uniforms.Singles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Vectors;

   procedure Set_Single_Matrix (Location : Uniform; Value : Singles.Matrix2) is
   begin
      API.Uniforms.Singles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Single_Matrix;

   procedure Set_Single_Matrix (Location : Uniform; Value : Singles.Matrix3) is
   begin
      API.Uniforms.Singles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Single_Matrix;

   procedure Set_Single_Matrix (Location : Uniform; Value : Singles.Matrix4) is
   begin
      API.Uniforms.Singles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Single_Matrix;

   procedure Set_Single_Matrices (Location : Uniform; Value : Singles.Matrix2_Array) is
   begin
      API.Uniforms.Singles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Single_Matrices;

   procedure Set_Single_Matrices (Location : Uniform; Value : Singles.Matrix3_Array) is
   begin
      API.Uniforms.Singles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Single_Matrices;

   procedure Set_Single_Matrices (Location : Uniform; Value : Singles.Matrix4_Array) is
   begin
      API.Uniforms.Singles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Single_Matrices;

   -----------------------------------------------------------------------------
   --                                 Doubles                                 --
   -----------------------------------------------------------------------------

   procedure Set_Double (Location : Uniform; Value : Double) is
   begin
      API.Uniforms.Doubles.Uniform1 (Location.Program.Reference.GL_Id,
                                     Location.Location, Value);
   end Set_Double;

   procedure Set_Doubles (Location : Uniform; V1, V2 : Double) is
   begin
      API.Uniforms.Doubles.Uniform2 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2);
   end Set_Doubles;

   procedure Set_Double_Vector (Location : Uniform; Value : Doubles.Vector2) is
   begin
      API.Uniforms.Doubles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, 2, (1 => Value));
   end Set_Double_Vector;

   procedure Set_Doubles (Location : Uniform; V1, V2, V3 : Double) is
   begin
      API.Uniforms.Doubles.Uniform3 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3);
   end Set_Doubles;

   procedure Set_Double_Vector (Location : Uniform; Value : Doubles.Vector3) is
   begin
      API.Uniforms.Doubles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, 3, (1 => Value));
   end Set_Double_Vector;

   procedure Set_Doubles (Location : Uniform; V1, V2, V3, V4 : Double) is
   begin
      API.Uniforms.Doubles.Uniform4 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3, V4);
   end Set_Doubles;

   procedure Set_Double_Vector (Location : Uniform; Value : Doubles.Vector4) is
   begin
      API.Uniforms.Doubles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, 4, (1 => Value));
   end Set_Double_Vector;

   procedure Set_Double_Array (Location : Uniform; Value : Double_Array) is
   begin
      API.Uniforms.Doubles.Uniform1v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Array;

   procedure Set_Double_Vectors (Location : Uniform; Value : Doubles.Vector2_Array) is
   begin
      API.Uniforms.Doubles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Vectors;

   procedure Set_Double_Vectors (Location : Uniform; Value : Doubles.Vector3_Array) is
   begin
      API.Uniforms.Doubles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Vectors;

   procedure Set_Double_Vectors (Location : Uniform; Value : Doubles.Vector4_Array) is
   begin
      API.Uniforms.Doubles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Vectors;

   procedure Set_Double_Matrix (Location : Uniform; Value : Doubles.Matrix2) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Double_Matrix;

   procedure Set_Double_Matrix (Location : Uniform; Value : Doubles.Matrix3) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Double_Matrix;

   procedure Set_Double_Matrix (Location : Uniform; Value : Doubles.Matrix4) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Double_Matrix;

   procedure Set_Double_Matrices (Location : Uniform; Value : Doubles.Matrix2_Array) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Double_Matrices;

   procedure Set_Double_Matrices (Location : Uniform; Value : Doubles.Matrix3_Array) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Double_Matrices;

   procedure Set_Double_Matrices (Location : Uniform; Value : Doubles.Matrix4_Array) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Double_Matrices;

   -----------------------------------------------------------------------------
   --                                 Integers                                --
   -----------------------------------------------------------------------------

   procedure Set_Int (Location : Uniform; Value : Int) is
   begin
      API.Uniforms.Ints.Uniform1 (Location.Program.Reference.GL_Id,
                                  Location.Location, Value);
   end Set_Int;

   procedure Set_Ints (Location : Uniform; V1, V2 : Int) is
   begin
      API.Uniforms.Ints.Uniform2 (Location.Program.Reference.GL_Id,
                                  Location.Location, V1, V2);
   end Set_Ints;

   procedure Set_Int_Vector (Location : Uniform; Value : Ints.Vector2) is
   begin
      API.Uniforms.Ints.Uniform2v (Location.Program.Reference.GL_Id,
                                   Location.Location, 2, (1 => Value));
   end Set_Int_Vector;

   procedure Set_Ints (Location : Uniform; V1, V2, V3 : Int) is
   begin
      API.Uniforms.Ints.Uniform3 (Location.Program.Reference.GL_Id,
                                  Location.Location, V1, V2, V3);
   end Set_Ints;

   procedure Set_Int_Vector (Location : Uniform; Value : Ints.Vector3) is
   begin
      API.Uniforms.Ints.Uniform3v (Location.Program.Reference.GL_Id,
                                   Location.Location, 3, (1 => Value));
   end Set_Int_Vector;

   procedure Set_Ints (Location : Uniform; V1, V2, V3, V4 : Int) is
   begin
      API.Uniforms.Ints.Uniform4 (Location.Program.Reference.GL_Id,
                                  Location.Location, V1, V2, V3, V4);
   end Set_Ints;

   procedure Set_Int_Vector (Location : Uniform; Value : Ints.Vector4) is
   begin
      API.Uniforms.Ints.Uniform4v (Location.Program.Reference.GL_Id,
                                   Location.Location, 4, (1 => Value));
   end Set_Int_Vector;

   procedure Set_Int_Array (Location : Uniform; Value : Int_Array) is
   begin
      API.Uniforms.Ints.Uniform1v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length, Value);
   end Set_Int_Array;

   procedure Set_Int_Vectors (Location : Uniform; Value : Ints.Vector2_Array) is
   begin
      API.Uniforms.Ints.Uniform2v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length * 2, Value);
   end Set_Int_Vectors;

   procedure Set_Int_Vectors (Location : Uniform; Value : Ints.Vector3_Array) is
   begin
      API.Uniforms.Ints.Uniform3v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length * 3, Value);
   end Set_Int_Vectors;

   procedure Set_Int_Vectors (Location : Uniform; Value : Ints.Vector4_Array) is
   begin
      API.Uniforms.Ints.Uniform4v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length * 4, Value);
   end Set_Int_Vectors;

   -----------------------------------------------------------------------------
   --                            Unsigned Integers                            --
   -----------------------------------------------------------------------------

   procedure Set_UInt (Location : Uniform; Value : UInt) is
   begin
      API.Uniforms.UInts.Uniform1 (Location.Program.Reference.GL_Id,
                                   Location.Location, Value);
   end Set_UInt;

   procedure Set_UInts (Location : Uniform; V1, V2 : UInt) is
   begin
      API.Uniforms.UInts.Uniform2 (Location.Program.Reference.GL_Id,
                                   Location.Location, V1, V2);
   end Set_UInts;

   procedure Set_UInt_Vector (Location : Uniform; Value : UInts.Vector2) is
   begin
      API.Uniforms.UInts.Uniform2v (Location.Program.Reference.GL_Id,
                                    Location.Location, 2, (1 => Value));
   end Set_UInt_Vector;

   procedure Set_UInts (Location : Uniform; V1, V2, V3 : UInt) is
   begin
      API.Uniforms.UInts.Uniform3 (Location.Program.Reference.GL_Id,
                                   Location.Location, V1, V2, V3);
   end Set_UInts;

   procedure Set_UInt_Vector (Location : Uniform; Value : UInts.Vector3) is
   begin
      API.Uniforms.UInts.Uniform3v (Location.Program.Reference.GL_Id,
                                    Location.Location, 3, (1 => Value));
   end Set_UInt_Vector;

   procedure Set_UInts (Location : Uniform; V1, V2, V3, V4 : UInt) is
   begin
      API.Uniforms.UInts.Uniform4 (Location.Program.Reference.GL_Id,
                                   Location.Location, V1, V2, V3, V4);
   end Set_UInts;

   procedure Set_UInt_Vector (Location : Uniform; Value : UInts.Vector4) is
   begin
      API.Uniforms.UInts.Uniform4v (Location.Program.Reference.GL_Id,
                                    Location.Location, 4, (1 => Value));
   end Set_UInt_Vector;

   procedure Set_UInt_Array (Location : Uniform; Value : UInt_Array) is
   begin
      API.Uniforms.UInts.Uniform1v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Array;

   procedure Set_UInt_Vectors (Location : Uniform; Value : UInts.Vector2_Array) is
   begin
      API.Uniforms.UInts.Uniform2v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Vectors;

   procedure Set_UInt_Vectors (Location : Uniform; Value : UInts.Vector3_Array) is
   begin
      API.Uniforms.UInts.Uniform3v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Vectors;

   procedure Set_UInt_Vectors (Location : Uniform; Value : UInts.Vector4_Array) is
   begin
      API.Uniforms.UInts.Uniform4v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Vectors;

end GL.Objects.Programs.Uniforms;

--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  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 GL.API.Uniforms.Singles;
with GL.API.Uniforms.Doubles;
with GL.API.Uniforms.Ints;
with GL.API.Uniforms.UInts;
with GL.Low_Level;

package body GL.Objects.Programs.Uniforms is

   function Create_Uniform (Object : Program; Location : Int) return Uniform is
   begin
      return Uniform'(Program => Object, Location => Location);
   end Create_Uniform;

   -----------------------------------------------------------------------------
   --                                 Singles                                 --
   -----------------------------------------------------------------------------

   procedure Set_Single (Location : Uniform; Value : Single) is
   begin
      API.Uniforms.Singles.Uniform1 (Location.Program.Reference.GL_Id,
                                     Location.Location, Value);
   end Set_Single;

   procedure Set_Singles (Location : Uniform; V1, V2 : Single) is
   begin
      API.Uniforms.Singles.Uniform2 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2);
   end Set_Singles;

   procedure Set_Single_Vector (Location : Uniform; Value : Singles.Vector2) is
   begin
      API.Uniforms.Singles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, 1, (1 => Value));
   end Set_Single_Vector;

   procedure Set_Singles (Location : Uniform; V1, V2, V3 : Single) is
   begin
      API.Uniforms.Singles.Uniform3 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3);
   end Set_Singles;

   procedure Set_Single_Vector (Location : Uniform; Value : Singles.Vector3) is
   begin
      API.Uniforms.Singles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, 1, (1 => Value));
   end Set_Single_Vector;

   procedure Set_Singles (Location : Uniform; V1, V2, V3, V4 : Single) is
   begin
      API.Uniforms.Singles.Uniform4 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3, V4);
   end Set_Singles;

   procedure Set_Single_Vector (Location : Uniform; Value : Singles.Vector4) is
   begin
      API.Uniforms.Singles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, 1, (1 => Value));
   end Set_Single_Vector;

   procedure Set_Single_Array (Location : Uniform; Value : Single_Array) is
   begin
      API.Uniforms.Singles.Uniform1v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Array;

   procedure Set_Single_Vectors (Location : Uniform; Value : Singles.Vector2_Array) is
   begin
      API.Uniforms.Singles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Vectors;

   procedure Set_Single_Vectors (Location : Uniform; Value : Singles.Vector3_Array) is
   begin
      API.Uniforms.Singles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Vectors;

   procedure Set_Single_Vectors (Location : Uniform; Value : Singles.Vector4_Array) is
   begin
      API.Uniforms.Singles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Single_Vectors;

   procedure Set_Single_Matrix (Location : Uniform; Value : Singles.Matrix2) is
   begin
      API.Uniforms.Singles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Single_Matrix;

   procedure Set_Single_Matrix (Location : Uniform; Value : Singles.Matrix3) is
   begin
      API.Uniforms.Singles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Single_Matrix;

   procedure Set_Single_Matrix (Location : Uniform; Value : Singles.Matrix4) is
   begin
      API.Uniforms.Singles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Single_Matrix;

   procedure Set_Single_Matrices (Location : Uniform; Value : Singles.Matrix2_Array) is
   begin
      API.Uniforms.Singles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Single_Matrices;

   procedure Set_Single_Matrices (Location : Uniform; Value : Singles.Matrix3_Array) is
   begin
      API.Uniforms.Singles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Single_Matrices;

   procedure Set_Single_Matrices (Location : Uniform; Value : Singles.Matrix4_Array) is
   begin
      API.Uniforms.Singles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Single_Matrices;

   -----------------------------------------------------------------------------
   --                                 Doubles                                 --
   -----------------------------------------------------------------------------

   procedure Set_Double (Location : Uniform; Value : Double) is
   begin
      API.Uniforms.Doubles.Uniform1 (Location.Program.Reference.GL_Id,
                                     Location.Location, Value);
   end Set_Double;

   procedure Set_Doubles (Location : Uniform; V1, V2 : Double) is
   begin
      API.Uniforms.Doubles.Uniform2 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2);
   end Set_Doubles;

   procedure Set_Double_Vector (Location : Uniform; Value : Doubles.Vector2) is
   begin
      API.Uniforms.Doubles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, 1, (1 => Value));
   end Set_Double_Vector;

   procedure Set_Doubles (Location : Uniform; V1, V2, V3 : Double) is
   begin
      API.Uniforms.Doubles.Uniform3 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3);
   end Set_Doubles;

   procedure Set_Double_Vector (Location : Uniform; Value : Doubles.Vector3) is
   begin
      API.Uniforms.Doubles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, 1, (1 => Value));
   end Set_Double_Vector;

   procedure Set_Doubles (Location : Uniform; V1, V2, V3, V4 : Double) is
   begin
      API.Uniforms.Doubles.Uniform4 (Location.Program.Reference.GL_Id,
                                     Location.Location, V1, V2, V3, V4);
   end Set_Doubles;

   procedure Set_Double_Vector (Location : Uniform; Value : Doubles.Vector4) is
   begin
      API.Uniforms.Doubles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, 1, (1 => Value));
   end Set_Double_Vector;

   procedure Set_Double_Array (Location : Uniform; Value : Double_Array) is
   begin
      API.Uniforms.Doubles.Uniform1v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Array;

   procedure Set_Double_Vectors (Location : Uniform; Value : Doubles.Vector2_Array) is
   begin
      API.Uniforms.Doubles.Uniform2v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Vectors;

   procedure Set_Double_Vectors (Location : Uniform; Value : Doubles.Vector3_Array) is
   begin
      API.Uniforms.Doubles.Uniform3v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Vectors;

   procedure Set_Double_Vectors (Location : Uniform; Value : Doubles.Vector4_Array) is
   begin
      API.Uniforms.Doubles.Uniform4v (Location.Program.Reference.GL_Id,
                                      Location.Location, Value'Length, Value);
   end Set_Double_Vectors;

   procedure Set_Double_Matrix (Location : Uniform; Value : Doubles.Matrix2) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Double_Matrix;

   procedure Set_Double_Matrix (Location : Uniform; Value : Doubles.Matrix3) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Double_Matrix;

   procedure Set_Double_Matrix (Location : Uniform; Value : Doubles.Matrix4) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            1, Low_Level.False, (1 => Value));
   end Set_Double_Matrix;

   procedure Set_Double_Matrices (Location : Uniform; Value : Doubles.Matrix2_Array) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix2 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Double_Matrices;

   procedure Set_Double_Matrices (Location : Uniform; Value : Doubles.Matrix3_Array) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix3 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Double_Matrices;

   procedure Set_Double_Matrices (Location : Uniform; Value : Doubles.Matrix4_Array) is
   begin
      API.Uniforms.Doubles.Uniform_Matrix4 (Location.Program.Reference.GL_Id,
                                            Location.Location,
                                            Value'Length, Low_Level.False, Value);
   end Set_Double_Matrices;

   -----------------------------------------------------------------------------
   --                                 Integers                                --
   -----------------------------------------------------------------------------

   procedure Set_Int (Location : Uniform; Value : Int) is
   begin
      API.Uniforms.Ints.Uniform1 (Location.Program.Reference.GL_Id,
                                  Location.Location, Value);
   end Set_Int;

   procedure Set_Ints (Location : Uniform; V1, V2 : Int) is
   begin
      API.Uniforms.Ints.Uniform2 (Location.Program.Reference.GL_Id,
                                  Location.Location, V1, V2);
   end Set_Ints;

   procedure Set_Int_Vector (Location : Uniform; Value : Ints.Vector2) is
   begin
      API.Uniforms.Ints.Uniform2v (Location.Program.Reference.GL_Id,
                                   Location.Location, 1, (1 => Value));
   end Set_Int_Vector;

   procedure Set_Ints (Location : Uniform; V1, V2, V3 : Int) is
   begin
      API.Uniforms.Ints.Uniform3 (Location.Program.Reference.GL_Id,
                                  Location.Location, V1, V2, V3);
   end Set_Ints;

   procedure Set_Int_Vector (Location : Uniform; Value : Ints.Vector3) is
   begin
      API.Uniforms.Ints.Uniform3v (Location.Program.Reference.GL_Id,
                                   Location.Location, 1, (1 => Value));
   end Set_Int_Vector;

   procedure Set_Ints (Location : Uniform; V1, V2, V3, V4 : Int) is
   begin
      API.Uniforms.Ints.Uniform4 (Location.Program.Reference.GL_Id,
                                  Location.Location, V1, V2, V3, V4);
   end Set_Ints;

   procedure Set_Int_Vector (Location : Uniform; Value : Ints.Vector4) is
   begin
      API.Uniforms.Ints.Uniform4v (Location.Program.Reference.GL_Id,
                                   Location.Location, 1, (1 => Value));
   end Set_Int_Vector;

   procedure Set_Int_Array (Location : Uniform; Value : Int_Array) is
   begin
      API.Uniforms.Ints.Uniform1v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length, Value);
   end Set_Int_Array;

   procedure Set_Int_Vectors (Location : Uniform; Value : Ints.Vector2_Array) is
   begin
      API.Uniforms.Ints.Uniform2v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length * 2, Value);
   end Set_Int_Vectors;

   procedure Set_Int_Vectors (Location : Uniform; Value : Ints.Vector3_Array) is
   begin
      API.Uniforms.Ints.Uniform3v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length * 3, Value);
   end Set_Int_Vectors;

   procedure Set_Int_Vectors (Location : Uniform; Value : Ints.Vector4_Array) is
   begin
      API.Uniforms.Ints.Uniform4v (Location.Program.Reference.GL_Id,
                                   Location.Location, Value'Length * 4, Value);
   end Set_Int_Vectors;

   -----------------------------------------------------------------------------
   --                            Unsigned Integers                            --
   -----------------------------------------------------------------------------

   procedure Set_UInt (Location : Uniform; Value : UInt) is
   begin
      API.Uniforms.UInts.Uniform1 (Location.Program.Reference.GL_Id,
                                   Location.Location, Value);
   end Set_UInt;

   procedure Set_UInts (Location : Uniform; V1, V2 : UInt) is
   begin
      API.Uniforms.UInts.Uniform2 (Location.Program.Reference.GL_Id,
                                   Location.Location, V1, V2);
   end Set_UInts;

   procedure Set_UInt_Vector (Location : Uniform; Value : UInts.Vector2) is
   begin
      API.Uniforms.UInts.Uniform2v (Location.Program.Reference.GL_Id,
                                    Location.Location, 1, (1 => Value));
   end Set_UInt_Vector;

   procedure Set_UInts (Location : Uniform; V1, V2, V3 : UInt) is
   begin
      API.Uniforms.UInts.Uniform3 (Location.Program.Reference.GL_Id,
                                   Location.Location, V1, V2, V3);
   end Set_UInts;

   procedure Set_UInt_Vector (Location : Uniform; Value : UInts.Vector3) is
   begin
      API.Uniforms.UInts.Uniform3v (Location.Program.Reference.GL_Id,
                                    Location.Location, 1, (1 => Value));
   end Set_UInt_Vector;

   procedure Set_UInts (Location : Uniform; V1, V2, V3, V4 : UInt) is
   begin
      API.Uniforms.UInts.Uniform4 (Location.Program.Reference.GL_Id,
                                   Location.Location, V1, V2, V3, V4);
   end Set_UInts;

   procedure Set_UInt_Vector (Location : Uniform; Value : UInts.Vector4) is
   begin
      API.Uniforms.UInts.Uniform4v (Location.Program.Reference.GL_Id,
                                    Location.Location, 1, (1 => Value));
   end Set_UInt_Vector;

   procedure Set_UInt_Array (Location : Uniform; Value : UInt_Array) is
   begin
      API.Uniforms.UInts.Uniform1v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Array;

   procedure Set_UInt_Vectors (Location : Uniform; Value : UInts.Vector2_Array) is
   begin
      API.Uniforms.UInts.Uniform2v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Vectors;

   procedure Set_UInt_Vectors (Location : Uniform; Value : UInts.Vector3_Array) is
   begin
      API.Uniforms.UInts.Uniform3v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Vectors;

   procedure Set_UInt_Vectors (Location : Uniform; Value : UInts.Vector4_Array) is
   begin
      API.Uniforms.UInts.Uniform4v (Location.Program.Reference.GL_Id,
                                    Location.Location, Value'Length, Value);
   end Set_UInt_Vectors;

end GL.Objects.Programs.Uniforms;

Fix setters of vector uniforms

gl: Fix setters of vector uniforms

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


-----------------------------------------------------------------------
--  awa-components-wikis -- Wiki rendering component
--  Copyright (C) 2011, 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.Wide_Wide_Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ASF.Contexts.Faces;
with ASF.Components;
with ASF.Components.Html;

with Wiki.Parsers;
with Wiki.Render;
package AWA.Components.Wikis is

   use ASF.Contexts.Faces;

   --  The wiki format of the wiki text.  The valid values are:
   --  dotclear, google, creole, phpbb, mediawiki
   FORMAT_NAME : constant String := "format";

   VALUE_NAME  : constant String := ASF.Components.VALUE_NAME;

   --  The link renderer bean that controls the generation of page and image links.
   LINKS_NAME  : constant String := "links";

   --  ------------------------------
   --  Wiki component
   --  ------------------------------
   --
   --  <awa:wiki value="wiki-text" format="dotclear|google|creole|phpbb" styleClass="class"/>
   --
   type UIWiki is new ASF.Components.Html.UIHtmlComponent with null record;
   type UIWiki_Access is access all UIWiki'Class;

   --  Get the wiki format style.  The format style is obtained from the <b>format</b>
   --  attribute name.
   function Get_Wiki_Style (UI      : in UIWiki;
                            Context : in Faces_Context'Class)
                            return Wiki.Parsers.Wiki_Syntax_Type;

   --  Get the links renderer that must be used to render image and page links.
   function Get_Links_Renderer (UI      : in UIWiki;
                                Context : in Faces_Context'Class)
                                return Wiki.Render.Link_Renderer_Access;

   --  Render the wiki text
   overriding
   procedure Encode_Begin (UI      : in UIWiki;
                           Context : in out Faces_Context'Class);

   use Ada.Strings.Wide_Wide_Unbounded;

   IMAGE_PREFIX_ATTR : constant String := "image_prefix";
   PAGE_PREFIX_ATTR  : constant String := "page_prefix";

   type Link_Renderer_Bean is new Util.Beans.Basic.Bean
     and Wiki.Render.Link_Renderer with record
      Page_Prefix  : Unbounded_Wide_Wide_String;
      Image_Prefix : Unbounded_Wide_Wide_String;
   end record;

   --  Return true if the link is an absolute link.
   function Is_Link_Absolute (Renderer : in Link_Renderer_Bean;
                              Link     : in Unbounded_Wide_Wide_String) return Boolean;

   --  Make a link adding a prefix unless the link is already absolute.
   procedure Make_Link (Renderer : in Link_Renderer_Bean;
                        Link     : in Unbounded_Wide_Wide_String;
                        Prefix   : in Unbounded_Wide_Wide_String;
                        URI      : out Unbounded_Wide_Wide_String);

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Link_Renderer_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Link_Renderer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Get the image link that must be rendered from the wiki image link.
   overriding
   procedure Make_Image_Link (Renderer : in Link_Renderer_Bean;
                              Link     : in Unbounded_Wide_Wide_String;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural);

   --  Get the page link that must be rendered from the wiki page link.
   overriding
   procedure Make_Page_Link (Renderer : in Link_Renderer_Bean;
                             Link     : in Unbounded_Wide_Wide_String;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean);

private

   function Starts_With (Content : in Unbounded_Wide_Wide_String;
                         Item    : in String) return Boolean;

end AWA.Components.Wikis;

-----------------------------------------------------------------------
--  awa-components-wikis -- Wiki rendering component
--  Copyright (C) 2011, 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.Strings.Wide_Wide_Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ASF.Contexts.Faces;
with ASF.Components;
with ASF.Components.Html;

with Wiki.Strings;
with Wiki.Render;
with Wiki.Render.Links;
package AWA.Components.Wikis is

   use ASF.Contexts.Faces;

   --  The wiki format of the wiki text.  The valid values are:
   --  dotclear, google, creole, phpbb, mediawiki
   FORMAT_NAME : constant String := "format";

   VALUE_NAME  : constant String := ASF.Components.VALUE_NAME;

   --  The link renderer bean that controls the generation of page and image links.
   LINKS_NAME  : constant String := "links";

   --  ------------------------------
   --  Wiki component
   --  ------------------------------
   --
   --  <awa:wiki value="wiki-text" format="dotclear|google|creole|phpbb" styleClass="class"/>
   --
   type UIWiki is new ASF.Components.Html.UIHtmlComponent with null record;
   type UIWiki_Access is access all UIWiki'Class;

   --  Get the wiki format style.  The format style is obtained from the <b>format</b>
   --  attribute name.
   function Get_Wiki_Style (UI      : in UIWiki;
                            Context : in Faces_Context'Class)
                            return Wiki.Wiki_Syntax;

   --  Get the links renderer that must be used to render image and page links.
   function Get_Links_Renderer (UI      : in UIWiki;
                                Context : in Faces_Context'Class)
                                return Wiki.Render.Links.Link_Renderer_Access;

   --  Render the wiki text
   overriding
   procedure Encode_Begin (UI      : in UIWiki;
                           Context : in out Faces_Context'Class);

   use Ada.Strings.Wide_Wide_Unbounded;

   IMAGE_PREFIX_ATTR : constant String := "image_prefix";
   PAGE_PREFIX_ATTR  : constant String := "page_prefix";

   type Link_Renderer_Bean is new Util.Beans.Basic.Bean
     and Wiki.Render.Links.Link_Renderer with record
      Page_Prefix  : Unbounded_Wide_Wide_String;
      Image_Prefix : Unbounded_Wide_Wide_String;
   end record;

   --  Make a link adding a prefix unless the link is already absolute.
   procedure Make_Link (Renderer : in Link_Renderer_Bean;
                        Link     : in Wiki.Strings.WString;
                        Prefix   : in Unbounded_Wide_Wide_String;
                        URI      : out Unbounded_Wide_Wide_String);

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Link_Renderer_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Link_Renderer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Get the image link that must be rendered from the wiki image link.
   overriding
   procedure Make_Image_Link (Renderer : in Link_Renderer_Bean;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural);

   --  Get the page link that must be rendered from the wiki page link.
   overriding
   procedure Make_Page_Link (Renderer : in Link_Renderer_Bean;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean);

private

   function Starts_With (Content : in Unbounded_Wide_Wide_String;
                         Item    : in String) return Boolean;

end AWA.Components.Wikis;

Update to use the new Wiki.Render.Links package and interfaces


with AdaBase;
with Connect;
with CommonText;
with Ada.Text_IO;
with AdaBase.Results.Sets;

procedure Bad_Select is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package ARS renames AdaBase.Results.Sets;
   package CT  renames CommonText;

   row : ARS.DataRow_Access;
   sql : String := "SELECT fruit, calories FROM froits " &
                   "WHERE color = 'red'";

begin

   declare
   begin
      CON.connect_database;
   exception
      when others =>
         TIO.Put_Line ("database connect failed.");
         return;
   end;

   CON.STMT := CON.DR.query (sql);

   TIO.Put_Line ("Query successful: " & CON.STMT.successful'Img);

   if not CON.STMT.successful then
      TIO.Put_Line ("  Driver message: " & CON.STMT.last_driver_message);
      TIO.Put_Line ("     Driver code: " & CON.STMT.last_driver_code'Img);
      TIO.Put_Line ("       SQL State: " & CON.STMT.last_sql_state);
      --  Fix SQL typo
      sql (31) := 'u';
      TIO.Put_Line ("");
      TIO.Put_Line ("SQL now: " & sql);
      CON.STMT := CON.DR.query (sql);
      TIO.Put_Line ("Query successful: " & CON.STMT.successful'Img);

      if CON.STMT.fetch_next (row) then
         TIO.Put_Line ("   Number fields:" & row.count'Img);

         CON.STMT.discard_rest;
         TIO.Put_Line ("  Data discarded: " & CON.STMT.data_discarded'Img);
      end if;
   end if;
   CON.DR.disconnect;

end Bad_Select;

with AdaBase;
with Connect;
with CommonText;
with Ada.Text_IO;
with AdaBase.Results.Sets;

procedure Bad_Select is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package ARS renames AdaBase.Results.Sets;
   package CT  renames CommonText;

   row : ARS.DataRow;
   sql : String := "SELECT fruit, calories FROM froits " &
                   "WHERE color = 'red'";

begin

   begin
      CON.connect_database;
   exception
      when others =>
         TIO.Put_Line ("database connect failed.");
         return;
   end;

   declare
      stmt : CON.Stmt_Type := CON.DR.query (sql);
   begin
      TIO.Put_Line ("Query successful: " & stmt.successful'Img);

      if not stmt.successful then
         TIO.Put_Line ("  Driver message: " & stmt.last_driver_message);
         TIO.Put_Line ("     Driver code: " & stmt.last_driver_code'Img);
         TIO.Put_Line ("       SQL State: " & stmt.last_sql_state);
         --  Fix SQL typo
         sql (31) := 'u';
         TIO.Put_Line ("");
         TIO.Put_Line ("SQL now: " & sql);
         stmt := CON.DR.query (sql);
         TIO.Put_Line ("Query successful: " & stmt.successful'Img);

         row := stmt.fetch_next;
         if not row.data_exhausted then
            TIO.Put_Line ("   Number fields:" & row.count'Img);

            stmt.discard_rest;
            TIO.Put_Line ("  Data discarded: " & stmt.data_discarded'Img);
         end if;
      end if;
   end;
   CON.DR.disconnect;

end Bad_Select;

fix bad_select test case

fix bad_select test case


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 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.

with Ada.Unchecked_Conversion;

package body Orka.SIMD.SSE2.Integers.Logical is

   type Unsigned_128 is array (Index_2D) of Unsigned_64
     with Alignment => 16;
   pragma Machine_Attribute (Unsigned_128, "vector_type");

   function And_Not (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pandn128";

   function "and" (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pand128";

   function "or" (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pand128";

   function "xor" (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pand128";

   ----------------------------------------------------------------------------

   function Convert is new Ada.Unchecked_Conversion (m128i, Unsigned_128);
   function Convert is new Ada.Unchecked_Conversion (Unsigned_128, m128i);

   function And_Not (Left, Right : m128i) return m128i is
     (Convert (And_Not (Convert (Left), Convert (Right))));

   function "and" (Left, Right : m128i) return m128i is
     (Convert (Convert (Left) and Convert (Right)));

   function "or" (Left, Right : m128i) return m128i is
     (Convert (Convert (Left) or Convert (Right)));

   function "xor" (Left, Right : m128i) return m128i is
     (Convert (Convert (Left) xor Convert (Right)));

end Orka.SIMD.SSE2.Integers.Logical;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 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.

with Ada.Unchecked_Conversion;

package body Orka.SIMD.SSE2.Integers.Logical is

   type Unsigned_128 is array (Index_2D) of Unsigned_64
     with Alignment => 16;
   pragma Machine_Attribute (Unsigned_128, "vector_type");

   function And_Not (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pandn128";

   function "and" (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pand128";

   function "or" (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_por128";

   function "xor" (Left, Right : Unsigned_128) return Unsigned_128
     with Import, Convention => Intrinsic, External_Name => "__builtin_ia32_pxor128";

   ----------------------------------------------------------------------------

   function Convert is new Ada.Unchecked_Conversion (m128i, Unsigned_128);
   function Convert is new Ada.Unchecked_Conversion (Unsigned_128, m128i);

   function And_Not (Left, Right : m128i) return m128i is
     (Convert (And_Not (Convert (Left), Convert (Right))));

   function "and" (Left, Right : m128i) return m128i is
     (Convert (Convert (Left) and Convert (Right)));

   function "or" (Left, Right : m128i) return m128i is
     (Convert (Convert (Left) or Convert (Right)));

   function "xor" (Left, Right : m128i) return m128i is
     (Convert (Convert (Left) xor Convert (Right)));

end Orka.SIMD.SSE2.Integers.Logical;

simd: Fix import correct SSE2 intrinsic for operators 'or' and 'xor'

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


-----------------------------------------------------------------------
--  util-streams-sockets -- Socket streams
--  Copyright (C) 2012, 2013 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.IO_Exceptions;
package body Util.Streams.Sockets is

   --  -----------------------
   --  Initialize the socket stream.
   --  -----------------------
   procedure Open (Stream  : in out Socket_Stream;
                   Socket  : in GNAT.Sockets.Socket_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Stream.Sock /= GNAT.Sockets.No_Socket then
         raise Ada.IO_Exceptions.Use_Error with "Socket stream is already opened";
      end if;
      Stream.Sock := Socket;
   end Open;

   --  -----------------------
   --  Initialize the socket stream by opening a connection to the server defined in Server.
   --  -----------------------
   procedure Connect (Stream : in out Socket_Stream;
                      Server : in GNAT.Sockets.Sock_Addr_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Stream.Sock /= GNAT.Sockets.No_Socket then
         raise Ada.IO_Exceptions.Use_Error with "Socket stream is already opened";
      end if;
      GNAT.Sockets.Create_Socket (Socket => Stream.Sock,
                                  Family => Server.Family);
      GNAT.Sockets.Connect_Socket (Socket => Stream.Sock,
                                   Server => Server);
   end Connect;

   --  -----------------------
   --  Close the socket stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Socket_Stream) is
   begin
      GNAT.Sockets.Close_Socket (Stream.Sock);
      Stream.Sock := GNAT.Sockets.No_Socket;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Socket_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Last : Ada.Streams.Stream_Element_Offset;
      pragma Unreferenced (Last);
   begin
      GNAT.Sockets.Send_Socket (Stream.Sock, Buffer, Last);
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  -----------------------
   overriding
   procedure Read (Stream : in out Socket_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      GNAT.Sockets.Receive_Socket (Stream.Sock, Into, Last);
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Socket_Stream) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Object.Sock /= GNAT.Sockets.No_Socket then
         Object.Close;
      end if;
   end Finalize;

end Util.Streams.Sockets;

-----------------------------------------------------------------------
--  util-streams-sockets -- Socket streams
--  Copyright (C) 2012, 2013 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.IO_Exceptions;
package body Util.Streams.Sockets is

   --  -----------------------
   --  Initialize the socket stream.
   --  -----------------------
   procedure Open (Stream  : in out Socket_Stream;
                   Socket  : in GNAT.Sockets.Socket_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Stream.Sock /= GNAT.Sockets.No_Socket then
         raise Ada.IO_Exceptions.Use_Error with "Socket stream is already opened";
      end if;
      Stream.Sock := Socket;
   end Open;

   --  -----------------------
   --  Initialize the socket stream by opening a connection to the server defined in Server.
   --  -----------------------
   procedure Connect (Stream : in out Socket_Stream;
                      Server : in GNAT.Sockets.Sock_Addr_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Stream.Sock /= GNAT.Sockets.No_Socket then
         raise Ada.IO_Exceptions.Use_Error with "Socket stream is already opened";
      end if;
      GNAT.Sockets.Create_Socket (Socket => Stream.Sock,
                                  Family => Server.Family);
      GNAT.Sockets.Connect_Socket (Socket => Stream.Sock,
                                   Server => Server);
   end Connect;

   --  -----------------------
   --  Close the socket stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Socket_Stream) is
   begin
      GNAT.Sockets.Close_Socket (Stream.Sock);
      Stream.Sock := GNAT.Sockets.No_Socket;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Socket_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Unused_Last : Ada.Streams.Stream_Element_Offset;
   begin
      GNAT.Sockets.Send_Socket (Stream.Sock, Buffer, Unused_Last);
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  -----------------------
   overriding
   procedure Read (Stream : in out Socket_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      GNAT.Sockets.Receive_Socket (Stream.Sock, Into, Last);
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Socket_Stream) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Object.Sock /= GNAT.Sockets.No_Socket then
         Object.Close;
      end if;
   end Finalize;

end Util.Streams.Sockets;

Fix for GCC 12

Fix for GCC 12


-----------------------------------------------------------------------
--  log.tests -- Unit tests for loggers
--  Copyright (C) 2009, 2010, 2011, 2013, 2015, 2018, 2021 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.Fixed;
with Ada.Directories;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with Util.Log;
with Util.Log.Loggers;
with Util.Files;
with Util.Properties;
with Util.Measures;
package body Util.Log.Tests is

   Log : constant Loggers.Logger := Loggers.Create ("util.log.test");

   procedure Test_Log (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      L.Set_Level (DEBUG_LEVEL);
      Log.Info ("My log message");
      Log.Error ("My error message");
      Log.Debug ("A debug message Not printed");

      L.Info ("An info message");
      L.Info ("A {0} {1} {2} {3}", "info", "message", "not", "printed");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Log;

   procedure Test_Debug (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
      C : Ada.Strings.Unbounded.Unbounded_String;
   begin
      L.Set_Level (DEBUG_LEVEL);
      L.Info ("My log message");
      L.Error ("My error message");
      L.Debug ("A {0} {1} {2} {3}", "debug", "message", "not", "printed");
      L.Debug ("A {0} {1} {2} {3}", C, "message", "printed");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Debug;

   --  Test configuration and creation of file
   procedure Test_File_Appender (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_File_Appender;

   procedure Test_Log_Perf (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test_perf.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.perf", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      for I in 1 .. 1000 loop
         declare
            S : Util.Measures.Stamp;
         begin
            Util.Measures.Report (S, "Util.Measures.Report", 1000);
         end;
      end loop;

      declare
         L : Loggers.Logger := Loggers.Create ("util.log.test.perf");
         S : Util.Measures.Stamp;
      begin
         L.Set_Level (DEBUG_LEVEL);
         for I in 1 .. 1000 loop
            L.Info ("My log message: {0}: {1}", "A message",
                    "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Info message (output)", 1000);

         L.Set_Level (INFO_LEVEL);
         for I in 1 .. 10_000 loop
            L.Debug ("My log message: {0}: {1}", "A message",
                     "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Debug message (no output)", 10_000);
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_Log_Perf;

   --  ------------------------------
   --  Test appending the log on several log files
   --  ------------------------------
   procedure Test_List_Appender (T : in out Test) is
      use Ada.Strings;
      use Ada.Directories;
      Props : Util.Properties.Manager;
   begin
      for I in 1 .. 10 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
            Name : constant String := "log4j.appender.test" & Id;
         begin
            Props.Set (Name, "File");
            Props.Set (Name & ".File", Path);
            Props.Set (Name & ".layout", "date-level-message");
            if I > 5 then
               Props.Set (Name & ".level", "INFO");
            end if;
         end;
      end loop;
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Props.Set ("log4j.appender.test.log.File",
                 Util.Tests.Get_Test_Path ("test-default.log"));
      Props.Set ("log4j.logger.util.log.test.file",
                 "DEBUG,test4,test1 , test2,test3, test4, test5 ,  test6 , test7,test8,");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
      end;

      --  Check that we have non empty log files (up to test8.log).
      for I in 1 .. 8 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
         begin
            T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
            if I > 5 then
               T.Assert (Ada.Directories.Size (Path) < 100, "Log file "
                         & Path & " should be empty");
            else
               T.Assert (Ada.Directories.Size (Path) > 100, "Log file " & Path & " is empty");
            end if;
         end;
      end loop;
   end Test_List_Appender;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_File_Appender_Modes (T : in out Test) is
      use Ada.Directories;

      Append_Path  : constant String := Util.Tests.Get_Test_Path ("test-append.log");
      Append2_Path : constant String := Util.Tests.Get_Test_Path ("test-append2.log");
      Global_Path  : constant String := Util.Tests.Get_Test_Path ("test-append-global.log");
      Props        : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Append_Path);
      Props.Set ("log4j.appender.test.append", "true");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.appender.test_global", "File");
      Props.Set ("log4j.appender.test_global.File", Global_Path);
      Props.Set ("log4j.appender.test_global.append", "false");
      Props.Set ("log4j.appender.test_global.immediateFlush", "false");
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG");
      Props.Set ("log4j.rootCategory", "DEBUG,test_global,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Error ("This is the error test message");
      end;

      Props.Set ("log4j.appender.test_append", "File");
      Props.Set ("log4j.appender.test_append.File", Append2_Path);
      Props.Set ("log4j.appender.test_append.append", "true");
      Props.Set ("log4j.appender.test_append.immediateFlush", "true");
      Props.Set ("log4j.logger.util.log.test2.file", "DEBUG,test_append,test_global");
      Util.Log.Loggers.Initialize (Props);

      declare
         L1 : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
         L2 : constant Loggers.Logger := Loggers.Create ("util.log.test2.file");
      begin
         L1.Info ("L1-1 Writing a info message");
         L2.Info ("L2-2 {0}: {1}", "Parameter", "Value");
         L1.Info ("L1-3 Done");
         L2.Error ("L2-4 This is the error test2 message");
      end;

      Props.Set ("log4j.appender.test_append.append", "plop");
      Props.Set ("log4j.appender.test_append.immediateFlush", "falsex");
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Util.Log.Loggers.Initialize (Props);

      T.Assert (Ada.Directories.Size (Append_Path) > 100,
                "Log file test-append.log is empty");
      T.Assert (Ada.Directories.Size (Append2_Path) > 100,
                "Log file test-append2.log is empty");
      T.Assert (Ada.Directories.Size (Global_Path) > 100,
                "Log file test-append.log is empty");
   end Test_File_Appender_Modes;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_Console_Appender (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test_err.log");
      Props   : Util.Properties.Manager;
      File    : Ada.Text_IO.File_Type;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Ada.Text_IO.Create (File, Ada.Text_IO.Out_File, Path);
      Ada.Text_IO.Set_Error (File);

      Props.Set ("log4j.appender.test_console", "Console");
      Props.Set ("log4j.appender.test_console.stderr", "true");
      Props.Set ("log4j.appender.test_console.level", "WARN");
      Props.Set ("log4j.rootCategory", "INFO,test_console");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Info ("INFO MESSAGE!");
         L.Warn ("WARN MESSAGE!");
         L.Error ("This {0} {1} {2} test message", "is", "the", "error");
      end;
      Ada.Text_IO.Flush (Ada.Text_IO.Current_Error);
      Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
      Ada.Text_IO.Close (File);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*WARN MESSAGE!", Content,
                                 "Invalid console log (WARN)");
      Util.Tests.Assert_Matches (T, ".*This is the error test message", Content,
                                 "Invalid console log (ERROR)");
   exception
      when others =>
         Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
         raise;

   end Test_Console_Appender;

   procedure Test_Missing_Config (T : in out Test) is
      L : constant Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      Util.Log.Loggers.Initialize ("plop");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
   end Test_Missing_Config;

   procedure Test_Log_Traceback (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test-traceback.log");
      Props   : Util.Properties.Manager;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.appender.test.append", "false");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.rootCategory", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Error ("This is the error test message");
         raise Constraint_Error with "Test";

      exception
         when E : others =>
            L.Error ("Something wrong", E, True);
      end;

      Props.Set ("log4j.rootCategory", "DEBUG,console");
      Props.Set ("log4j.appender.console", "Console");
      Util.Log.Loggers.Initialize (Props);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*Something wrong: Exception CONSTRAINT_ERROR:", Content,
                                 "Invalid console log (ERROR)");
   end Test_Log_Traceback;

   package Caller is new Util.Test_Caller (Test, "Log");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Info",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Debug",
                       Test_Debug'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Set_Level",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Error",
                       Test_Log_Traceback'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Initialize",
                       Test_Missing_Config'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender",
                       Test_File_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender (append)",
                       Test_File_Appender_Modes'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.List_Appender",
                       Test_List_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.Console",
                       Test_Console_Appender'Access);

      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Log (Perf)",
                       Test_Log_Perf'Access);
   end Add_Tests;

end Util.Log.Tests;

-----------------------------------------------------------------------
--  log.tests -- Unit tests for loggers
--  Copyright (C) 2009, 2010, 2011, 2013, 2015, 2018, 2021 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.Fixed;
with Ada.Directories;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with Util.Log;
with Util.Log.Loggers;
with Util.Files;
with Util.Properties;
with Util.Measures;
package body Util.Log.Tests is

   Log : constant Loggers.Logger := Loggers.Create ("util.log.test");

   procedure Test_Log (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      L.Set_Level (DEBUG_LEVEL);
      Log.Info ("My log message");
      Log.Error ("My error message");
      Log.Debug ("A debug message Not printed");

      L.Info ("An info message");
      L.Info ("A {0} {1} {2} {3}", "info", "message", "not", "printed");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Log;

   procedure Test_Debug (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
      C : Ada.Strings.Unbounded.Unbounded_String;
   begin
      L.Set_Level (DEBUG_LEVEL);
      L.Info ("My log message");
      L.Error ("My error message");
      L.Debug ("A {0} {1} {2} {3}", "debug", "message", "not", "printed");
      L.Debug ("A {0} {1} {2} {3}", C, "message", "printed");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Debug;

   --  Test configuration and creation of file
   procedure Test_File_Appender (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_File_Appender;

   procedure Test_Log_Perf (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test_perf.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.perf", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      for I in 1 .. 1000 loop
         declare
            S : Util.Measures.Stamp;
         begin
            Util.Measures.Report (S, "Util.Measures.Report", 1000);
         end;
      end loop;

      declare
         L : Loggers.Logger := Loggers.Create ("util.log.test.perf");
         S : Util.Measures.Stamp;
      begin
         L.Set_Level (DEBUG_LEVEL);
         for I in 1 .. 1000 loop
            L.Info ("My log message: {0}: {1}", "A message",
                    "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Info message (output)", 1000);

         L.Set_Level (INFO_LEVEL);
         for I in 1 .. 10_000 loop
            L.Debug ("My log message: {0}: {1}", "A message",
                     "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Debug message (no output)", 10_000);
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_Log_Perf;

   --  ------------------------------
   --  Test appending the log on several log files
   --  ------------------------------
   procedure Test_List_Appender (T : in out Test) is
      use Ada.Strings;
      use Ada.Directories;
      Props : Util.Properties.Manager;
   begin
      for I in 1 .. 10 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
            Name : constant String := "log4j.appender.test" & Id;
         begin
            Props.Set (Name, "File");
            Props.Set (Name & ".File", Path);
            Props.Set (Name & ".layout", "date-level-message");
            if I > 5 then
               Props.Set (Name & ".level", "INFO");
            end if;
         end;
      end loop;
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Props.Set ("log4j.appender.test.log.File",
                 Util.Tests.Get_Test_Path ("test-default.log"));
      Props.Set ("log4j.logger.util.log.test.file",
                 "DEBUG,test4,test1 , test2,test3, test4, test5 ,  test6 , test7,test8,");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
      end;

      --  Check that we have non empty log files (up to test8.log).
      for I in 1 .. 8 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
         begin
            T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
            if I > 5 then
               T.Assert (Ada.Directories.Size (Path) < 100, "Log file "
                         & Path & " should be empty");
            else
               T.Assert (Ada.Directories.Size (Path) > 100, "Log file " & Path & " is empty");
            end if;
         end;
      end loop;
   end Test_List_Appender;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_File_Appender_Modes (T : in out Test) is
      use Ada.Directories;

      Append_Path  : constant String := Util.Tests.Get_Test_Path ("test-append.log");
      Append2_Path : constant String := Util.Tests.Get_Test_Path ("test-append2.log");
      Global_Path  : constant String := Util.Tests.Get_Test_Path ("test-append-global.log");
      Props        : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Append_Path);
      Props.Set ("log4j.appender.test.append", "true");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.appender.test_global", "File");
      Props.Set ("log4j.appender.test_global.File", Global_Path);
      Props.Set ("log4j.appender.test_global.append", "false");
      Props.Set ("log4j.appender.test_global.immediateFlush", "false");
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG");
      Props.Set ("log4j.rootCategory", "DEBUG,test_global,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Error ("This is the error test message");
      end;

      Props.Set ("log4j.appender.test_append", "File");
      Props.Set ("log4j.appender.test_append.File", Append2_Path);
      Props.Set ("log4j.appender.test_append.append", "true");
      Props.Set ("log4j.appender.test_append.immediateFlush", "true");
      Props.Set ("log4j.logger.util.log.test2.file", "DEBUG,test_append,test_global");
      Util.Log.Loggers.Initialize (Props);

      declare
         L1 : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
         L2 : constant Loggers.Logger := Loggers.Create ("util.log.test2.file");
      begin
         L1.Info ("L1-1 Writing a info message");
         L2.Info ("L2-2 {0}: {1}", "Parameter", "Value");
         L1.Info ("L1-3 Done");
         L2.Error ("L2-4 This is the error test2 message");
      end;

      Props.Set ("log4j.appender.test_append.append", "plop");
      Props.Set ("log4j.appender.test_append.immediateFlush", "falsex");
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Util.Log.Loggers.Initialize (Props);

      T.Assert (Ada.Directories.Size (Append_Path) > 100,
                "Log file test-append.log is empty");
      T.Assert (Ada.Directories.Size (Append2_Path) > 100,
                "Log file test-append2.log is empty");
      T.Assert (Ada.Directories.Size (Global_Path) > 100,
                "Log file test-append.log is empty");
   end Test_File_Appender_Modes;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_Console_Appender (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test_err.log");
      Props   : Util.Properties.Manager;
      File    : Ada.Text_IO.File_Type;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Ada.Text_IO.Create (File, Ada.Text_IO.Out_File, Path);
      Ada.Text_IO.Set_Error (File);

      Props.Set ("log4j.appender.test_console", "Console");
      Props.Set ("log4j.appender.test_console.stderr", "true");
      Props.Set ("log4j.appender.test_console.level", "WARN");
      Props.Set ("log4j.rootCategory", "INFO,test_console");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Info ("INFO MESSAGE!");
         L.Warn ("WARN MESSAGE!");
         L.Error ("This {0} {1} {2} test message", "is", "the", "error");
      end;
      Ada.Text_IO.Flush (Ada.Text_IO.Current_Error);
      Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
      Ada.Text_IO.Close (File);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*WARN MESSAGE!", Content,
                                 "Invalid console log (WARN)");
      Util.Tests.Assert_Matches (T, ".*This is the error test message", Content,
                                 "Invalid console log (ERROR)");
   exception
      when others =>
         Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
         raise;

   end Test_Console_Appender;

   procedure Test_Missing_Config (T : in out Test) is
      pragma Unreferenced (T);
      L : constant Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      Util.Log.Loggers.Initialize ("plop");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
   end Test_Missing_Config;

   procedure Test_Log_Traceback (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test-traceback.log");
      Props   : Util.Properties.Manager;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.appender.test.append", "false");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.rootCategory", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Error ("This is the error test message");
         raise Constraint_Error with "Test";

      exception
         when E : others =>
            L.Error ("Something wrong", E, True);
      end;

      Props.Set ("log4j.rootCategory", "DEBUG,console");
      Props.Set ("log4j.appender.console", "Console");
      Util.Log.Loggers.Initialize (Props);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*Something wrong: Exception CONSTRAINT_ERROR:", Content,
                                 "Invalid console log (ERROR)");
   end Test_Log_Traceback;

   package Caller is new Util.Test_Caller (Test, "Log");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Info",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Debug",
                       Test_Debug'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Set_Level",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Error",
                       Test_Log_Traceback'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Initialize",
                       Test_Missing_Config'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender",
                       Test_File_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender (append)",
                       Test_File_Appender_Modes'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.List_Appender",
                       Test_List_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.Console",
                       Test_Console_Appender'Access);

      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Log (Perf)",
                       Test_Log_Perf'Access);
   end Add_Tests;

end Util.Log.Tests;

Fix compilation warning

Fix compilation warning