-----------------------------------------------------------------------
--  asf-applications-main-tests - Unit tests for Applications
--  Copyright (C) 2011, 2012 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.Test_Caller;

with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

with ASF.Applications.Tests;
with ASF.Applications.Main.Configs;
with ASF.Requests.Mockup;
package body ASF.Applications.Main.Tests is

   use Util.Tests;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Read_Configuration",
                       Test_Read_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Load_Bundle",
                       Test_Load_Bundle'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register,Load_Bundle",
                       Test_Bundle_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Get_Supported_Locales",
                       Test_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      T.App := new ASF.Applications.Main.Application;
      C.Copy (Util.Tests.Get_Properties);
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Applications.Main.Application'Class,
                                        Name   => ASF.Applications.Main.Application_Access);
   begin
      Free (T.App);
   end Tear_Down;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Applications.Tests.Form_Bean_Access := new Applications.Tests.Form_Bean;
   begin
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Read_Configuration (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("config/empty.xml");
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

   end Test_Read_Configuration;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-module.xml");

   begin
      T.App.Register_Class ("ASF.Applications.Tests.Form_Bean", Create_Form_Bean'Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Bean;

   --  ------------------------------
   --  Test loading a resource bundle through the application.
   --  ------------------------------
   procedure Test_Load_Bundle (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Bundle : ASF.Locales.Bundle;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Load_Bundle (Name   => "samples",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Equals (T, "Help", String '(Bundle.Get ("layout_help_label")),
                                "Invalid bundle value");

      T.App.Load_Bundle (Name   => "asf",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Matches (T, ".*greater than.*",
                                 String '(Bundle.Get ("validators.length.maximum")),
                                "Invalid bundle value");
   end Test_Load_Bundle;

   --  ------------------------------
   --  Test application configuration and registration of resource bundles.
   --  ------------------------------
   procedure Test_Bundle_Configuration (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Result : Util.Beans.Basic.Readonly_Bean_Access;
      Ctx    : EL.Contexts.Default.Default_Context;
      Scope  : Scope_Type;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("samplesMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The samplesMsg bundle was not created");

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("defaultMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The defaultMsg bundle was not created");
   end Test_Bundle_Configuration;

   --  ------------------------------
   --  Test locales.
   --  ------------------------------
   procedure Test_Locales (T : in out Test) is
      use Util.Locales;

      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-locales.xml");
      Req       : aliased ASF.Requests.Mockup.Request;
      View      : constant access Applications.Views.View_Handler'Class := T.App.Get_View_Handler;
      Context   : aliased ASF.Contexts.Faces.Faces_Context;
      ELContext : aliased EL.Contexts.Default.Default_Context;
      Locale    : Util.Locales.Locale;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (T.App.Get_Default_Locale),
                                "Invalid default locale");

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Request (Req'Unchecked_Access);
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.3, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, en-gb, en;q=0.8, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "en_GB",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, fr;q=0.7, fr-fr;q=0.8");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "fr_FR",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, ru, it;q=0.8, de;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");
   end Test_Locales;

end ASF.Applications.Main.Tests;

-----------------------------------------------------------------------
--  asf-applications-main-tests - Unit tests for Applications
--  Copyright (C) 2011, 2012, 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 Util.Test_Caller;

with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

with ASF.Applications.Tests;
with ASF.Applications.Main.Configs;
with ASF.Requests.Mockup;
package body ASF.Applications.Main.Tests is

   use Util.Tests;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Read_Configuration",
                       Test_Read_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Load_Bundle",
                       Test_Load_Bundle'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register,Load_Bundle",
                       Test_Bundle_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Get_Supported_Locales",
                       Test_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      T.App := new ASF.Applications.Main.Application;
      C.Copy (Util.Tests.Get_Properties);
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Applications.Main.Application'Class,
                                        Name   => ASF.Applications.Main.Application_Access);
   begin
      Free (T.App);
   end Tear_Down;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Applications.Tests.Form_Bean_Access := new Applications.Tests.Form_Bean;
   begin
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Read_Configuration (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("config/empty.xml");
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

   end Test_Read_Configuration;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-module.xml");

   begin
      T.App.Register_Class ("ASF.Applications.Tests.Form_Bean", Create_Form_Bean'Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Bean;

   --  ------------------------------
   --  Test loading a resource bundle through the application.
   --  ------------------------------
   procedure Test_Load_Bundle (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Bundle : ASF.Locales.Bundle;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Load_Bundle (Name   => "samples",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Equals (T, "Help", String '(Bundle.Get ("layout_help_label")),
                                "Invalid bundle value");

      T.App.Load_Bundle (Name   => "asf",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Matches (T, ".*greater than.*",
                                 String '(Bundle.Get ("validators.length.maximum")),
                                "Invalid bundle value");
   end Test_Load_Bundle;

   --  ------------------------------
   --  Test application configuration and registration of resource bundles.
   --  ------------------------------
   procedure Test_Bundle_Configuration (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path    : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Result  : Util.Beans.Basic.Readonly_Bean_Access;
      Context : aliased ASF.Contexts.Faces.Faces_Context;
      Ctx     : aliased EL.Contexts.Default.Default_Context;
      Scope   : Scope_Type;
   begin
      Context.Set_ELContext (Ctx'Unchecked_Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("samplesMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The samplesMsg bundle was not created");

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("defaultMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The defaultMsg bundle was not created");
   end Test_Bundle_Configuration;

   --  ------------------------------
   --  Test locales.
   --  ------------------------------
   procedure Test_Locales (T : in out Test) is
      use Util.Locales;

      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-locales.xml");
      Req       : aliased ASF.Requests.Mockup.Request;
      View      : constant access Applications.Views.View_Handler'Class := T.App.Get_View_Handler;
      Context   : aliased ASF.Contexts.Faces.Faces_Context;
      ELContext : aliased EL.Contexts.Default.Default_Context;
      Locale    : Util.Locales.Locale;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (T.App.Get_Default_Locale),
                                "Invalid default locale");

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Request (Req'Unchecked_Access);
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.3, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, en-gb, en;q=0.8, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "en_GB",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, fr;q=0.7, fr-fr;q=0.8");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "fr_FR",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, ru, it;q=0.8, de;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");
   end Test_Locales;

end ASF.Applications.Main.Tests;

Fix the Test_Bundle_Configuration that requires a faces context to be executed


with Ada.Text_IO;
with Ada.Exceptions;
with Envs;
with Smart_Pointers;

package body Evaluation is

   use Types;

   function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
		   return Mal_Handle is
      Name, Fn_Body, Res : Mal_Handle;
   begin
      Name := Car (Args);
      pragma Assert (Deref (Name).Sym_Type = Sym,
                     "Def_Fn: expected atom as name");
      Fn_Body := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Fn_Body, Env);
      Envs.Set (Envs.Get_Current, Deref_Sym (Name).Get_Sym, Res);
      return Res;
   end Def_Fn;

   function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle)
		   return Mal_Handle is
      Name, Fn_Body, Res : Mal_Handle;
      Lambda_P : Lambda_Ptr;
   begin
      Name := Car (Args);
      pragma Assert (Deref (Name).Sym_Type = Sym,
                     "Def_Macro: expected atom as name");
      Fn_Body := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Fn_Body, Env);
      Lambda_P := Deref_Lambda (Res);
      Lambda_P.Set_Is_Macro (True);
      Envs.Set (Envs.Get_Current, Deref_Sym (Name).Get_Sym, Res);
      return Res;
   end Def_Macro;

   function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
   return Mal_Handle is
      Res : Mal_Handle;
      E : Envs.Env_Handle;
      LMT : List_Mal_Type;
      LP : Lambda_Ptr;
   begin

      Res := Ast;
      E := Env;

      loop

         if Deref (Res).Sym_Type /= List then
            exit;
         end if;

         LMT := Deref_List (Res).all;

         -- Get the macro in the list from the env
         -- or return null if not applicable.
         LP := Get_Macro (Res, E);

      exit when LP = null or else not LP.Get_Is_Macro;

	  declare
	     Fn_List : Mal_Handle := Cdr (LMT);
	     Params : List_Mal_Type;
	  begin
	     E := Envs.New_Env (E);

	     Params := Deref_List (LP.Get_Params).all;
	     if Envs.Bind (E, Params, Deref_List (Fn_List).all) then

	        Res := Eval (LP.Get_Expr, E);

             end if;

	  end;

      end loop;

      return Res;

   end Macro_Expand;

   function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle)
			   return Mal_Handle is
      Defs, Expr, Res : Mal_Handle;
      E : Envs.Env_Handle;
   begin
      E := Envs.New_Env (Env);
      Defs := Car (Args);
      Deref_List_Class (Defs).Add_Defs (E);
      Expr := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Expr, E);
      return Res;
   end Let_Processing;

   function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
      Res : Boolean;
   begin
      case Deref (MH).Sym_Type is
         when Bool =>
            Res := Deref_Bool (MH).Get_Bool;
         when Sym =>
            return not (Deref_Sym (MH).Get_Sym = "nil");
--         when List =>
--            declare
--               L : List_Mal_Type;
--            begin
--               L := Deref_List (MH).all;
--               Res := not Is_Null (L);
--            end;
         when others => -- Everything else
            Res := True;
      end case;
      return Res;
   end Eval_As_Boolean;

   function Eval_Ast
     (Ast : Mal_Handle; Env : Envs.Env_Handle)
     return Mal_Handle is

      function Call_Eval (A : Mal_Handle) return Mal_Handle is
      begin
         return Eval (A, Env);
      end Call_Eval;

   begin

      case Deref (Ast).Sym_Type is

         when Sym =>

            declare
               Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
            begin
               -- if keyword, return it. Otherwise look it up in the environment.
               if Sym(1) = ':' then
                  return Ast;
               else
                  return Envs.Get (Env, Sym);
               end if;
            exception
               when Envs.Not_Found =>
                  raise Envs.Not_Found with (" '" &  Sym & "' not found ");
            end;

         when List =>

            return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);

         when Lambda =>

            -- Evaluating a lambda in a different Env.
            declare
               L : Lambda_Ptr;
               New_Env : Envs.Env_Handle;
            begin
               L := Deref_Lambda (Ast);
               New_Env := Env;
               -- Make the current Lambda's env the outer of the env param.
               Envs.Set_Outer (New_Env, L.Get_Env);
               -- Make the Lambda's Env.
               L.Set_Env (New_Env);
               return Ast;
            end;

         when others => return Ast;

      end case;

   end Eval_Ast;

   function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle)
			  return Mal_Handle is
      D : List_Mal_Type;
      Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
   begin
      if Debug then
         Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List));
      end if;
      D := Do_List;
      while not Is_Null (D) loop
         Res := Eval (Car (D), Env);
         D := Deref_List (Cdr(D)).all;
      end loop;
      return Res;
   end Do_Processing;

   function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
      Res, First_Elem, FE_0 : Mal_Handle;
      D, Ast : List_Mal_Type;
      L : List_Ptr;
   begin

      if Debug then
         Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
      end if;

      -- Create a New List for the result...
      Res := New_List_Mal_Type (List_List);
      L := Deref_List (Res);

      -- This is the equivalent of Is_Pair
      if Deref (Param).Sym_Type /= List or else
         Is_Null (Deref_List (Param).all) then

         -- return a new list containing: a symbol named "quote" and ast.
         L.Append (New_Symbol_Mal_Type ("quote"));
         L.Append (Param);
         return Res;

      end if;

      -- Ast is a non-empty list at this point.

      Ast := Deref_List (Param).all;

      First_Elem := Car (Ast);

      -- if the first element of ast is a symbol named "unquote":
      if Deref (First_Elem).Sym_Type = Sym and then
         Deref_Sym (First_Elem).Get_Sym = "unquote" then

         -- return the second element of ast.`
         D := Deref_List (Cdr (Ast)).all;
         return Car (D);

      end if;

      -- if the first element of first element of `ast` (`ast[0][0]`)
      -- is a symbol named "splice-unquote"
      if Deref (First_Elem).Sym_Type = List and then
         not Is_Null (Deref_List (First_Elem).all) then

         D := Deref_List (First_Elem).all;
         FE_0 := Car (D);

         if Deref (FE_0).Sym_Type = Sym and then
            Deref_Sym (FE_0).Get_Sym = "splice-unquote" then

            -- return a new list containing: a symbol named "concat",
            L.Append (New_Symbol_Mal_Type ("concat"));

            -- the second element of first element of ast (ast[0][1]),
            D := Deref_List (Cdr (D)).all;
            L.Append (Car (D));

            -- and the result of calling quasiquote with
            -- the second through last element of ast.
            L.Append (Quasi_Quote_Processing (Cdr (Ast)));

            return Res;

         end if;

      end if;

      -- otherwise: return a new list containing: a symbol named "cons",
      L.Append (New_Symbol_Mal_Type ("cons"));

      -- the result of calling quasiquote on first element of ast (ast[0]),
      L.Append (Quasi_Quote_Processing (Car (Ast)));

      -- and result of calling quasiquote with the second through last element of ast.
      L.Append (Quasi_Quote_Processing (Cdr (Ast)));

      return Res;

   end Quasi_Quote_Processing;

   function Catch_Processing
              (Try_Line : Mal_Handle;
               ExStr : Mal_Handle;
               Env : Envs.Env_Handle)
   return Mal_Handle is

      L, CL, CL2, CL3 : List_Mal_Type;
      C : Mal_Handle;
      New_Env : Envs.Env_Handle;

   begin

      L := Deref_List (Try_Line).all;
      C := Car (L);
      -- CL is the list with the catch in.
      CL := Deref_List (C).all;

      CL2 := Deref_List (Cdr (CL)).all;
      New_Env := Envs.New_Env (Env);
      Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr);

      CL3 := Deref_List (Cdr (CL2)).all;
      return Eval (Car (CL3), New_Env);
   end Catch_Processing;

   Mal_Exception_Value : Mal_Handle;

   procedure Set_Mal_Exception_Value (MEV : Mal_Handle) is
   begin
      Mal_Exception_Value := MEV;
   end Set_Mal_Exception_Value;

   function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
		 return Mal_Handle is
      Param : Mal_Handle;
      Env : Envs.Env_Handle;
      First_Elem : Mal_Handle;
   begin

      Param := AParam;
      Env := AnEnv;

  <<Tail_Call_Opt>>

      if Debug then
         Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
      end if;

      Param := Macro_Expand (Param, Env);

      if Debug then
         Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
      end if;

      if Deref (Param).Sym_Type = List and then
	Deref_List (Param).Get_List_Type = List_List then

	 declare
	    L : Mal_Handle := Param;
	    LMT, Rest_List : List_Mal_Type;
	    First_Elem, Rest_Handle : Mal_Handle;
	 begin

	    LMT := Deref_List (L).all;

	    First_Elem := Car (LMT);

	    Rest_Handle := Cdr (LMT);

	    Rest_List := Deref_List (Rest_Handle).all;

	    case Deref (First_Elem).Sym_Type is

	       when Int | Floating | Bool | Str =>

		  return First_Elem;

               when Atom =>

                  return Deref_Atom (First_Elem).Get_Atom;

	       when Sym =>

		  declare
		     Sym_P : Sym_Ptr;
		  begin
		     Sym_P := Deref_Sym (First_Elem);
		     if Sym_P.Get_Sym = "def!" then
			return Def_Fn (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "defmacro!" then
			return Def_Macro (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "macroexpand" then
			return Macro_Expand (Car (Rest_List), Env);
		     elsif Sym_P.Get_Sym = "let*" then
			return Let_Processing (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "do" then
			return Do_Processing (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "if" then
			declare
			   Args : List_Mal_Type := Rest_List;

			   Cond, True_Part, False_Part : Mal_Handle;
			   Cond_Bool : Boolean;
			   pragma Assert (Length (Args) = 2 or Length (Args) = 3,
					  "If_Processing: not 2 or 3 parameters");
			   L : List_Mal_Type;
			begin

			   Cond := Eval (Car (Args), Env);

			   Cond_Bool := Eval_As_Boolean (Cond);

			   if Cond_Bool then
			      L := Deref_List (Cdr (Args)).all;

			      Param := Car (L);
			      goto Tail_Call_Opt;
			      -- was: return Eval (Car (L), Env);
			   else
			      if Length (Args) = 3 then
				 L := Deref_List (Cdr (Args)).all;
				 L := Deref_List (Cdr (L)).all;

				 Param := Car (L);
				 goto Tail_Call_Opt;
				 -- was: return Eval (Car (L), Env);
			      else
				 return New_Symbol_Mal_Type ("nil");
			      end if;
			   end if;
			end;

		     elsif Sym_P.Get_Sym = "quote" then
                        return Car (Rest_List);
		     elsif Sym_P.Get_Sym = "quasiquote" then
		        Param := Quasi_Quote_Processing (Car (Rest_List));
		        goto Tail_Call_Opt;
		     elsif Sym_P.Get_Sym = "try*" then
                        declare
                           Res : Mal_Handle;
                        begin
			   return Eval (Car (Rest_List), Env);
                        exception
                           when Mal_Exception =>
                              Res := Catch_Processing
                                       (Cdr (Rest_List),
                                        Mal_Exception_Value,
                                        Env);
                              Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
                              return Res;
                           when E : others =>
                              return Catch_Processing
                                       (Cdr (Rest_List),
                                        New_String_Mal_Type
                                          (Ada.Exceptions.Exception_Message (E)),
                                        Env);
                        end;
		     else -- not a special form

			-- Apply section
			declare
			   Res : Mal_Handle;
			begin
			   -- Eval the atom.
			   Res := Eval_Ast (L, Env);
			   Param := Res;
			   goto Tail_Call_Opt;
			   -- was: return Eval (Res, Env);
			end;

		     end if;
		  end;

	       when Func =>

		  return Call_Func
		    (Deref_Func (First_Elem).all,
		     Rest_Handle,
		     Env);

	       when Lambda =>

		  declare
		     LP : Lambda_Ptr := Deref_Lambda (First_Elem);
		     Fn_List : Mal_Handle := Cdr (LMT);
		     Params : List_Mal_Type;
		     E : Envs.Env_Handle;
		  begin
		     E := Envs.New_Env (LP.Get_Env);
		     Params := Deref_List (LP.Get_Params).all;
		     if Envs.Bind (E, Params, Deref_List (Fn_List).all) then

		        Param := LP.Get_Expr;
		        Env := E;
		        goto Tail_Call_Opt;
		        -- was: return Eval (LP.Get_Expr, E);

                     else
                        return First_Elem;
                     end if;

		  end;

	       when List =>

		  -- First elem in the list is a list.
		  -- Eval it and then insert it as first elem in the list and
		  -- go again.
		  declare
		     Evaled_List : Mal_Handle;
		     E : Envs.Env_Handle;
		  begin
		     Evaled_List := Eval (First_Elem, Env);
		     if Is_Null (Evaled_List) then
			return Evaled_List;
		     elsif Deref (Evaled_List).Sym_Type = Lambda then
			E := Deref_Lambda (Evaled_List).Get_Env;
		     else
			E := Env;
		     end if;

		     Param := Prepend (Evaled_List, Rest_List);
		     Env := E;
		     goto Tail_Call_Opt;
                     -- was:
		     -- Evaled_List := Prepend (Evaled_List, Rest_List);
		     -- return Eval (Evaled_List, E);
		  end;

	       when Error => return First_Elem;

	       when Node => return New_Error_Mal_Type ("Evaluating a node");

	    end case;

	 end;

      else

         return Eval_Ast (Param, Env);

      end if;

   end Eval;

end Evaluation;

with Ada.Text_IO;
with Ada.Exceptions;
with Envs;
with Smart_Pointers;

package body Evaluation is

   use Types;

   function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
		   return Mal_Handle is
      Name, Fn_Body, Res : Mal_Handle;
   begin
      Name := Car (Args);
      pragma Assert (Deref (Name).Sym_Type = Sym,
                     "Def_Fn: expected atom as name");
      Fn_Body := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Fn_Body, Env);
      Envs.Set (Envs.Get_Current, Deref_Sym (Name).Get_Sym, Res);
      return Res;
   end Def_Fn;

   function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle)
		   return Mal_Handle is
      Name, Fn_Body, Res : Mal_Handle;
      Lambda_P : Lambda_Ptr;
   begin
      Name := Car (Args);
      pragma Assert (Deref (Name).Sym_Type = Sym,
                     "Def_Macro: expected atom as name");
      Fn_Body := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Fn_Body, Env);
      Lambda_P := Deref_Lambda (Res);
      Lambda_P.Set_Is_Macro (True);
      Envs.Set (Envs.Get_Current, Deref_Sym (Name).Get_Sym, Res);
      return Res;
   end Def_Macro;

   function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
   return Mal_Handle is
      Res : Mal_Handle;
      E : Envs.Env_Handle;
      LMT : List_Mal_Type;
      LP : Lambda_Ptr;
   begin

      Res := Ast;
      E := Env;

      loop

         if Deref (Res).Sym_Type /= List then
            exit;
         end if;

         LMT := Deref_List (Res).all;

         -- Get the macro in the list from the env
         -- or return null if not applicable.
         LP := Get_Macro (Res, E);

      exit when LP = null or else not LP.Get_Is_Macro;

	  declare
	     Fn_List : Mal_Handle := Cdr (LMT);
	     Params : List_Mal_Type;
	  begin
	     E := Envs.New_Env (E);

	     Params := Deref_List (LP.Get_Params).all;
	     if Envs.Bind (E, Params, Deref_List (Fn_List).all) then

	        Res := Eval (LP.Get_Expr, E);

             end if;

	  end;

      end loop;

      return Res;

   end Macro_Expand;

   function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle)
			   return Mal_Handle is
      Defs, Expr, Res : Mal_Handle;
      E : Envs.Env_Handle;
   begin
      E := Envs.New_Env (Env);
      Defs := Car (Args);
      Deref_List_Class (Defs).Add_Defs (E);
      Expr := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Expr, E);
      return Res;
   end Let_Processing;

   function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
      Res : Boolean;
   begin
      case Deref (MH).Sym_Type is
         when Bool =>
            Res := Deref_Bool (MH).Get_Bool;
         when Sym =>
            return not (Deref_Sym (MH).Get_Sym = "nil");
--         when List =>
--            declare
--               L : List_Mal_Type;
--            begin
--               L := Deref_List (MH).all;
--               Res := not Is_Null (L);
--            end;
         when others => -- Everything else
            Res := True;
      end case;
      return Res;
   end Eval_As_Boolean;

   function Eval_Ast
     (Ast : Mal_Handle; Env : Envs.Env_Handle)
     return Mal_Handle is

      function Call_Eval (A : Mal_Handle) return Mal_Handle is
      begin
         return Eval (A, Env);
      end Call_Eval;

   begin

      case Deref (Ast).Sym_Type is

         when Sym =>

            declare
               Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
            begin
               -- if keyword, return it. Otherwise look it up in the environment.
               if Sym(1) = ':' then
                  return Ast;
               else
                  return Envs.Get (Env, Sym);
               end if;
            exception
               when Envs.Not_Found =>
                  raise Envs.Not_Found with (" '" &  Sym & "' not found ");
            end;

         when List =>

            return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);

         when Lambda =>

            -- Evaluating a lambda in a different Env.
            declare
               L : Lambda_Ptr;
               New_Env : Envs.Env_Handle;
            begin
               L := Deref_Lambda (Ast);
               New_Env := Env;
               -- Make the current Lambda's env the outer of the env param.
               Envs.Set_Outer (New_Env, L.Get_Env);
               -- Make the Lambda's Env.
               L.Set_Env (New_Env);
               return Ast;
            end;

         when others => return Ast;

      end case;

   end Eval_Ast;

   function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle)
			  return Mal_Handle is
      D : List_Mal_Type;
      Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
   begin
      if Debug then
         Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List));
      end if;
      D := Do_List;
      while not Is_Null (D) loop
         Res := Eval (Car (D), Env);
         D := Deref_List (Cdr(D)).all;
      end loop;
      return Res;
   end Do_Processing;

   function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
      Res, First_Elem, FE_0 : Mal_Handle;
      L : List_Ptr;
      D_Ptr, Ast_P : List_Class_Ptr;
   begin

      if Debug then
         Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
      end if;

      -- Create a New List for the result...
      Res := New_List_Mal_Type (List_List);
      L := Deref_List (Res);

      -- This is the equivalent of Is_Pair
      if Deref (Param).Sym_Type /= List or else
         Is_Null (Deref_List_Class (Param).all) then

         -- return a new list containing: a symbol named "quote" and ast.
         L.Append (New_Symbol_Mal_Type ("quote"));
         L.Append (Param);
         return Res;

      end if;

      -- Ast is a non-empty list at this point.

      Ast_P := Deref_List_Class (Param);

      First_Elem := Car (Ast_P.all);

      -- if the first element of ast is a symbol named "unquote":
      if Deref (First_Elem).Sym_Type = Sym and then
         Deref_Sym (First_Elem).Get_Sym = "unquote" then

         -- return the second element of ast.`
         D_Ptr := Deref_List_Class (Cdr (Ast_P.all));
         return Car (D_Ptr.all);

      end if;

      -- if the first element of first element of `ast` (`ast[0][0]`)
      -- is a symbol named "splice-unquote"
      if Deref (First_Elem).Sym_Type = List and then
         not Is_Null (Deref_List_Class (First_Elem).all) then

         D_Ptr := Deref_List_Class (First_Elem);
         FE_0 := Car (D_Ptr.all);

         if Deref (FE_0).Sym_Type = Sym and then
            Deref_Sym (FE_0).Get_Sym = "splice-unquote" then

            -- return a new list containing: a symbol named "concat",
            L.Append (New_Symbol_Mal_Type ("concat"));

            -- the second element of first element of ast (ast[0][1]),
            D_Ptr := Deref_List_Class (Cdr (D_Ptr.all));
            L.Append (Car (D_Ptr.all));

            -- and the result of calling quasiquote with
            -- the second through last element of ast.
            L.Append (Quasi_Quote_Processing (Cdr (Ast_P.all)));

            return Res;

         end if;

      end if;

      -- otherwise: return a new list containing: a symbol named "cons",
      L.Append (New_Symbol_Mal_Type ("cons"));

      -- the result of calling quasiquote on first element of ast (ast[0]),
      L.Append (Quasi_Quote_Processing (Car (Ast_P.all)));

      -- and result of calling quasiquote with the second through last element of ast.
      L.Append (Quasi_Quote_Processing (Cdr (Ast_P.all)));

      return Res;

   end Quasi_Quote_Processing;

   function Catch_Processing
              (Try_Line : Mal_Handle;
               ExStr : Mal_Handle;
               Env : Envs.Env_Handle)
   return Mal_Handle is

      L, CL, CL2, CL3 : List_Mal_Type;
      C : Mal_Handle;
      New_Env : Envs.Env_Handle;

   begin

      L := Deref_List (Try_Line).all;
      C := Car (L);
      -- CL is the list with the catch in.
      CL := Deref_List (C).all;

      CL2 := Deref_List (Cdr (CL)).all;
      New_Env := Envs.New_Env (Env);
      Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr);

      CL3 := Deref_List (Cdr (CL2)).all;
      return Eval (Car (CL3), New_Env);
   end Catch_Processing;

   Mal_Exception_Value : Mal_Handle;

   procedure Set_Mal_Exception_Value (MEV : Mal_Handle) is
   begin
      Mal_Exception_Value := MEV;
   end Set_Mal_Exception_Value;

   function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
		 return Mal_Handle is
      Param : Mal_Handle;
      Env : Envs.Env_Handle;
      First_Elem : Mal_Handle;
   begin

      Param := AParam;
      Env := AnEnv;

  <<Tail_Call_Opt>>

      if Debug then
         Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
      end if;

      Param := Macro_Expand (Param, Env);

      if Debug then
         Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
      end if;

      if Deref (Param).Sym_Type = List and then
	Deref_List (Param).Get_List_Type = List_List then

	 declare
	    L : Mal_Handle := Param;
	    LMT, Rest_List : List_Mal_Type;
	    First_Elem, Rest_Handle : Mal_Handle;
	 begin

	    LMT := Deref_List (L).all;

	    First_Elem := Car (LMT);

	    Rest_Handle := Cdr (LMT);

	    Rest_List := Deref_List (Rest_Handle).all;

	    case Deref (First_Elem).Sym_Type is

	       when Int | Floating | Bool | Str =>

		  return First_Elem;

               when Atom =>

                  return Deref_Atom (First_Elem).Get_Atom;

	       when Sym =>

		  declare
		     Sym_P : Sym_Ptr;
		  begin
		     Sym_P := Deref_Sym (First_Elem);
		     if Sym_P.Get_Sym = "def!" then
			return Def_Fn (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "defmacro!" then
			return Def_Macro (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "macroexpand" then
			return Macro_Expand (Car (Rest_List), Env);
		     elsif Sym_P.Get_Sym = "let*" then
			return Let_Processing (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "do" then
			return Do_Processing (Rest_List, Env);
		     elsif Sym_P.Get_Sym = "if" then
			declare
			   Args : List_Mal_Type := Rest_List;

			   Cond, True_Part, False_Part : Mal_Handle;
			   Cond_Bool : Boolean;
			   pragma Assert (Length (Args) = 2 or Length (Args) = 3,
					  "If_Processing: not 2 or 3 parameters");
			   L : List_Mal_Type;
			begin

			   Cond := Eval (Car (Args), Env);

			   Cond_Bool := Eval_As_Boolean (Cond);

			   if Cond_Bool then
			      L := Deref_List (Cdr (Args)).all;

			      Param := Car (L);
			      goto Tail_Call_Opt;
			      -- was: return Eval (Car (L), Env);
			   else
			      if Length (Args) = 3 then
				 L := Deref_List (Cdr (Args)).all;
				 L := Deref_List (Cdr (L)).all;

				 Param := Car (L);
				 goto Tail_Call_Opt;
				 -- was: return Eval (Car (L), Env);
			      else
				 return New_Symbol_Mal_Type ("nil");
			      end if;
			   end if;
			end;

		     elsif Sym_P.Get_Sym = "quote" then
                        return Car (Rest_List);
		     elsif Sym_P.Get_Sym = "quasiquote" then
		        Param := Quasi_Quote_Processing (Car (Rest_List));
		        goto Tail_Call_Opt;
		     elsif Sym_P.Get_Sym = "try*" then
                        declare
                           Res : Mal_Handle;
                        begin
			   return Eval (Car (Rest_List), Env);
                        exception
                           when Mal_Exception =>
                              Res := Catch_Processing
                                       (Cdr (Rest_List),
                                        Mal_Exception_Value,
                                        Env);
                              Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
                              return Res;
                           when E : others =>
                              return Catch_Processing
                                       (Cdr (Rest_List),
                                        New_String_Mal_Type
                                          (Ada.Exceptions.Exception_Message (E)),
                                        Env);
                        end;
		     else -- not a special form

			-- Apply section
			declare
			   Res : Mal_Handle;
			begin
			   -- Eval the atom.
			   Res := Eval_Ast (L, Env);
			   Param := Res;
			   goto Tail_Call_Opt;
			   -- was: return Eval (Res, Env);
			end;

		     end if;
		  end;

	       when Func =>

		  return Call_Func
		    (Deref_Func (First_Elem).all,
		     Rest_Handle,
		     Env);

	       when Lambda =>

		  declare
		     LP : Lambda_Ptr := Deref_Lambda (First_Elem);
		     Fn_List : Mal_Handle := Cdr (LMT);
		     Params : List_Mal_Type;
		     E : Envs.Env_Handle;
		  begin
		     E := Envs.New_Env (LP.Get_Env);
		     Params := Deref_List (LP.Get_Params).all;
		     if Envs.Bind (E, Params, Deref_List (Fn_List).all) then

		        Param := LP.Get_Expr;
		        Env := E;
		        goto Tail_Call_Opt;
		        -- was: return Eval (LP.Get_Expr, E);

                     else
                        return First_Elem;
                     end if;

		  end;

	       when List =>

		  -- First elem in the list is a list.
		  -- Eval it and then insert it as first elem in the list and
		  -- go again.
		  declare
		     Evaled_List : Mal_Handle;
		     E : Envs.Env_Handle;
		  begin
		     Evaled_List := Eval (First_Elem, Env);
		     if Is_Null (Evaled_List) then
			return Evaled_List;
		     elsif Deref (Evaled_List).Sym_Type = Lambda then
			E := Deref_Lambda (Evaled_List).Get_Env;
		     else
			E := Env;
		     end if;

		     Param := Prepend (Evaled_List, Rest_List);
		     Env := E;
		     goto Tail_Call_Opt;
                     -- was:
		     -- Evaled_List := Prepend (Evaled_List, Rest_List);
		     -- return Eval (Evaled_List, E);
		  end;

	       when Error => return First_Elem;

	       when Node => return New_Error_Mal_Type ("Evaluating a node");

	    end case;

	 end;

      else

         return Eval_Ast (Param, Env);

      end if;

   end Eval;

end Evaluation;

make quasiquote etc work for vectors

Ada: make quasiquote etc work for vectors


------------------------------------------------------------------------------
-- Copyright (c) 2016, 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.Smaz_Implementations.Base_64 is

   package Tools renames Natools.Smaz_Implementations.Base_64_Tools;

   use type Ada.Streams.Stream_Element_Offset;
   use type Tools.Base_64_Digit;

   ----------------------
   -- Public Interface --
   ----------------------

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Verbatim_Length : out Natural;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Ignored : String (1 .. 2);
      Offset_Backup : Ada.Streams.Stream_Element_Offset;
   begin
      Tools.Next_Digit (Input, Offset, Code);

      if Code <= Last_Code then
         Verbatim_Length := 0;

      elsif Variable_Length_Verbatim then
         if Code < 63 then
            Verbatim_Length := 63 - Natural (Code);
         else
            Tools.Next_Digit (Input, Offset, Code);
            Verbatim_Length := Natural (Code) + 63 - Natural (Last_Code);
         end if;
         Code := 0;

      elsif Code = 63 then
         Tools.Next_Digit (Input, Offset, Code);
         Verbatim_Length := Natural (Code) * 3 + 3;
         Code := 0;

      elsif Code = 62 then
         Offset_Backup := Offset;
         Tools.Decode_Single (Input, Offset, Ignored (1), Code);
         Verbatim_Length := Natural (Code) * 3 + 1;
         Offset := Offset_Backup;
         Code := 0;

      else
         Offset_Backup := Offset;
         Verbatim_Length := (61 - Natural (Code)) * 4;
         Tools.Decode_Double (Input, Offset, Ignored, Code);
         Verbatim_Length := (Verbatim_Length + Natural (Code)) * 3 + 2;
         Offset := Offset_Backup;
         Code := 0;
      end if;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String)
   is
      Ignored : Tools.Base_64_Digit;
      Output_Index : Natural := Output'First - 1;
   begin
      if Output'Length mod 3 = 1 then
         Tools.Decode_Single
           (Input, Offset, Output (Output_Index + 1), Ignored);
         Output_Index := Output_Index + 1;
      elsif Output'Length mod 3 = 2 then
         Tools.Decode_Double
           (Input, Offset,
            Output (Output_Index + 1 .. Output_Index + 2), Ignored);
         Output_Index := Output_Index + 2;
      end if;

      if Output_Index < Output'Last then
         Tools.Decode
           (Input, Offset, Output (Output_Index + 1 .. Output'Last));
      end if;
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      Code : Tools.Base_64_Digit;
   begin
      for I in 1 .. Tools.Image_Length (Verbatim_Length) loop
         Tools.Next_Digit (Input, Offset, Code);
      end loop;
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count is
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Run_Count : constant Natural
              := (Input_Length + Largest_Run - 1) / Largest_Run;
            Last_Run_Size : constant Positive
              := Input_Length - (Run_Count - 1) * Largest_Run;
            Last_Run_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Last_Run_Size > Largest_Single then 2 else 1);
         begin
            return Ada.Streams.Stream_Element_Count (Run_Count)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Last_Run_Size) + Last_Run_Header_Size;
         end;
      else
         declare
            Largest_Prefix : constant Natural
              := (case Input_Length mod 3 is
                  when 1 => 15 * 3 + 1,
                  when 2 => ((62 - Natural (Last_Code)) * 4 - 1) * 3 + 2,
                  when others => 0);
            Prefix_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Largest_Prefix > 0 then 1 else 0);
            Largest_Run : constant Positive := 64 * 3;
            Prefix_Size : constant Natural
              := Natural'Min (Largest_Prefix, Input_Length);
            Run_Count : constant Natural
              := (Input_Length - Prefix_Size + Largest_Run - 1) / Largest_Run;
         begin
            if Run_Count > 0 then
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size)
                 + Ada.Streams.Stream_Element_Count (Run_Count - 1)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Input_Length - Prefix_Size
                                       - (Run_Count - 1) * Largest_Run)
                   + 2;
            else
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size);
            end if;
         end;
      end if;
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit) is
   begin
      Output (Offset) := Tools.Image (Code);
      Offset := Offset + 1;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Index : Positive := Input'First;
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Length, Last : Natural;
         begin
            while Index in Input'Range loop
               Length := Positive'Min (Largest_Run, Input'Last + 1 - Index);

               if Length > Largest_Single then
                  Write_Code (Output, Offset, 63);
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (Length - Largest_Single - 1));
               else
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (63 - Length));
               end if;

               if Length mod 3 = 1 then
                  Tools.Encode_Single (Input (Index), 0, Output, Offset);
                  Index := Index + 1;
                  Length := Length - 1;
               elsif Length mod 3 = 2 then
                  Tools.Encode_Double
                    (Input (Index .. Index + 1), 0, Output, Offset);
                  Index := Index + 2;
                  Length := Length - 2;
               end if;

               if Length > 0 then
                  Last := Index + Length - 1;
                  Tools.Encode (Input (Index .. Last), Output, Offset);
                  Index := Last + 1;
               end if;
            end loop;
         end;
      else
         if Input'Length mod 3 = 1 then
            declare
               Extra_Blocks : constant Natural
                 := Natural'Min (15, Input'Length / 3);
            begin
               Output (Offset) := Tools.Image (62);
               Offset := Offset + 1;

               Tools.Encode_Single
                 (Input (Index), Tools.Single_Byte_Padding (Extra_Blocks),
                  Output, Offset);
               Index := Index + 1;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         elsif Input'Length mod 3 = 2 then
            declare
               Extra_Blocks : constant Natural := Natural'Min
                 (Input'Length / 3,
                  (62 - Natural (Last_Code)) * 4 - 1);
            begin
               Output (Offset)
                 := Tools.Image (61 - Tools.Base_64_Digit (Extra_Blocks / 4));
               Offset := Offset + 1;

               Tools.Encode_Double
                 (Input (Index .. Index + 1),
                  Tools.Double_Byte_Padding (Extra_Blocks mod 4),
                  Output, Offset);
               Index := Index + 2;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         end if;

         pragma Assert ((Input'Last + 1 - Index) mod 3 = 0);

         while Index <= Input'Last loop
            declare
               Block_Count : constant Natural
                 := Natural'Min (64, (Input'Last + 1 - Index) / 3);
            begin
               Output (Offset) := Tools.Image (63);
               Output (Offset + 1)
                 := Tools.Image (Tools.Base_64_Digit (Block_Count - 1));
               Offset := Offset + 2;

               Tools.Encode
                 (Input (Index .. Index + Block_Count * 3 - 1),
                  Output, Offset);
               Index := Index + Block_Count * 3;
            end;
         end loop;
      end if;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_64;

------------------------------------------------------------------------------
-- Copyright (c) 2016-2017, 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.Smaz_Implementations.Base_64 is

   package Tools renames Natools.Smaz_Implementations.Base_64_Tools;

   use type Ada.Streams.Stream_Element_Offset;
   use type Tools.Base_64_Digit;

   ----------------------
   -- Public Interface --
   ----------------------

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Verbatim_Length : out Natural;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Ignored : String (1 .. 2);
      Offset_Backup : Ada.Streams.Stream_Element_Offset;
      Finished : Boolean;
   begin
      Tools.Next_Digit_Or_End (Input, Offset, Code, Finished);

      if Finished then
         Code := Base_64_Tools.Base_64_Digit'Last;
         Verbatim_Length := 0;
         return;
      end if;

      if Code <= Last_Code then
         Verbatim_Length := 0;

      elsif Variable_Length_Verbatim then
         if Code < 63 then
            Verbatim_Length := 63 - Natural (Code);
         else
            Tools.Next_Digit (Input, Offset, Code);
            Verbatim_Length := Natural (Code) + 63 - Natural (Last_Code);
         end if;
         Code := 0;

      elsif Code = 63 then
         Tools.Next_Digit (Input, Offset, Code);
         Verbatim_Length := Natural (Code) * 3 + 3;
         Code := 0;

      elsif Code = 62 then
         Offset_Backup := Offset;
         Tools.Decode_Single (Input, Offset, Ignored (1), Code);
         Verbatim_Length := Natural (Code) * 3 + 1;
         Offset := Offset_Backup;
         Code := 0;

      else
         Offset_Backup := Offset;
         Verbatim_Length := (61 - Natural (Code)) * 4;
         Tools.Decode_Double (Input, Offset, Ignored, Code);
         Verbatim_Length := (Verbatim_Length + Natural (Code)) * 3 + 2;
         Offset := Offset_Backup;
         Code := 0;
      end if;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String)
   is
      Ignored : Tools.Base_64_Digit;
      Output_Index : Natural := Output'First - 1;
   begin
      if Output'Length mod 3 = 1 then
         Tools.Decode_Single
           (Input, Offset, Output (Output_Index + 1), Ignored);
         Output_Index := Output_Index + 1;
      elsif Output'Length mod 3 = 2 then
         Tools.Decode_Double
           (Input, Offset,
            Output (Output_Index + 1 .. Output_Index + 2), Ignored);
         Output_Index := Output_Index + 2;
      end if;

      if Output_Index < Output'Last then
         Tools.Decode
           (Input, Offset, Output (Output_Index + 1 .. Output'Last));
      end if;
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      Code : Tools.Base_64_Digit;
   begin
      for I in 1 .. Tools.Image_Length (Verbatim_Length) loop
         Tools.Next_Digit (Input, Offset, Code);
      end loop;
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count is
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Run_Count : constant Natural
              := (Input_Length + Largest_Run - 1) / Largest_Run;
            Last_Run_Size : constant Positive
              := Input_Length - (Run_Count - 1) * Largest_Run;
            Last_Run_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Last_Run_Size > Largest_Single then 2 else 1);
         begin
            return Ada.Streams.Stream_Element_Count (Run_Count)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Last_Run_Size) + Last_Run_Header_Size;
         end;
      else
         declare
            Largest_Prefix : constant Natural
              := (case Input_Length mod 3 is
                  when 1 => 15 * 3 + 1,
                  when 2 => ((62 - Natural (Last_Code)) * 4 - 1) * 3 + 2,
                  when others => 0);
            Prefix_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Largest_Prefix > 0 then 1 else 0);
            Largest_Run : constant Positive := 64 * 3;
            Prefix_Size : constant Natural
              := Natural'Min (Largest_Prefix, Input_Length);
            Run_Count : constant Natural
              := (Input_Length - Prefix_Size + Largest_Run - 1) / Largest_Run;
         begin
            if Run_Count > 0 then
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size)
                 + Ada.Streams.Stream_Element_Count (Run_Count - 1)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Input_Length - Prefix_Size
                                       - (Run_Count - 1) * Largest_Run)
                   + 2;
            else
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size);
            end if;
         end;
      end if;
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit) is
   begin
      Output (Offset) := Tools.Image (Code);
      Offset := Offset + 1;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Index : Positive := Input'First;
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Length, Last : Natural;
         begin
            while Index in Input'Range loop
               Length := Positive'Min (Largest_Run, Input'Last + 1 - Index);

               if Length > Largest_Single then
                  Write_Code (Output, Offset, 63);
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (Length - Largest_Single - 1));
               else
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (63 - Length));
               end if;

               if Length mod 3 = 1 then
                  Tools.Encode_Single (Input (Index), 0, Output, Offset);
                  Index := Index + 1;
                  Length := Length - 1;
               elsif Length mod 3 = 2 then
                  Tools.Encode_Double
                    (Input (Index .. Index + 1), 0, Output, Offset);
                  Index := Index + 2;
                  Length := Length - 2;
               end if;

               if Length > 0 then
                  Last := Index + Length - 1;
                  Tools.Encode (Input (Index .. Last), Output, Offset);
                  Index := Last + 1;
               end if;
            end loop;
         end;
      else
         if Input'Length mod 3 = 1 then
            declare
               Extra_Blocks : constant Natural
                 := Natural'Min (15, Input'Length / 3);
            begin
               Output (Offset) := Tools.Image (62);
               Offset := Offset + 1;

               Tools.Encode_Single
                 (Input (Index), Tools.Single_Byte_Padding (Extra_Blocks),
                  Output, Offset);
               Index := Index + 1;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         elsif Input'Length mod 3 = 2 then
            declare
               Extra_Blocks : constant Natural := Natural'Min
                 (Input'Length / 3,
                  (62 - Natural (Last_Code)) * 4 - 1);
            begin
               Output (Offset)
                 := Tools.Image (61 - Tools.Base_64_Digit (Extra_Blocks / 4));
               Offset := Offset + 1;

               Tools.Encode_Double
                 (Input (Index .. Index + 1),
                  Tools.Double_Byte_Padding (Extra_Blocks mod 4),
                  Output, Offset);
               Index := Index + 2;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         end if;

         pragma Assert ((Input'Last + 1 - Index) mod 3 = 0);

         while Index <= Input'Last loop
            declare
               Block_Count : constant Natural
                 := Natural'Min (64, (Input'Last + 1 - Index) / 3);
            begin
               Output (Offset) := Tools.Image (63);
               Output (Offset + 1)
                 := Tools.Image (Tools.Base_64_Digit (Block_Count - 1));
               Offset := Offset + 2;

               Tools.Encode
                 (Input (Index .. Index + Block_Count * 3 - 1),
                  Output, Offset);
               Index := Index + Block_Count * 3;
            end;
         end loop;
      end if;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_64;

check end-of-input in Read_Code

smaz_implementations-base_64: check end-of-input in Read_Code


-----------------------------------------------------------------------
--  asf.filters -- ASF Filters
--  Copyright (C) 2010, 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 ASF.Requests;
with ASF.Responses;
with ASF.Servlets;

--  The ASF.Filters package defines the servlet filter
--  interface described in Java Servlet Specification, JSR 315, 6. Filtering.
--
package ASF.Filters is

   --  ------------------------------
   --  Filter interface
   --  ------------------------------
   --  The Filter interface defines one mandatory procedure through
   --  which the request/response pair are passed.
   --
   --  The Filter instance must be registered in the Servlet_Registry
   --  by using the Add_Filter procedure.  The same filter instance is used
   --  to process multiple requests possibly at the same time.
   type Filter is limited interface;
   type Filter_Access is access all Filter'Class;
   type Filter_List is array (Natural range <>) of Filter_Access;
   type Filter_List_Access is access all Filter_List;

   --  The Do_Filter method of the Filter is called by the container each time
   --  a request/response pair is passed through the chain due to a client request
   --  for a resource at the end of the chain.  The Filter_Chain passed in to this
   --  method allows the Filter to pass on the request and response to the next
   --  entity in the chain.
   --
   --  A typical implementation of this method would follow the following pattern:
   --  1. Examine the request
   --  2. Optionally wrap the request object with a custom implementation to
   --     filter content or headers for input filtering
   --  3. Optionally wrap the response object with a custom implementation to
   --     filter content or headers for output filtering
   --  4. Either invoke the next entity in the chain using the FilterChain
   --     object (chain.Do_Filter()),
   --     or, not pass on the request/response pair to the next entity in the
   --     filter chain to block the request processing
   --  5. Directly set headers on the response after invocation of the next
   --     entity in the filter chain.
   procedure Do_Filter (F        : in Filter;
                        Request  : in out Requests.Request'Class;
                        Response : in out Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is abstract;

   --  Called by the servlet container to indicate to a filter that the filter
   --  instance is being placed into service.
   procedure Initialize (Server  : in out Filter;
                         Config  : in ASF.Servlets.Filter_Config) is null;

end ASF.Filters;

-----------------------------------------------------------------------
--  asf-filters -- ASF Filters
--  Copyright (C) 2010, 2015, 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.Filters;

package ASF.Filters renames Servlet.Filters;

Package ASF.Filters moved to Servlet.filters


-----------------------------------------------------------------------
--  serialize-io-jcsv-tests -- Unit tests for CSV parser
--  Copyright (C) 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.Tests;

package Util.Serialize.IO.CSV.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Parser (T : in out Test);

end Util.Serialize.IO.CSV.Tests;

-----------------------------------------------------------------------
--  serialize-io-jcsv-tests -- Unit tests for CSV parser
--  Copyright (C) 2011, 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 Util.Tests;

package Util.Serialize.IO.CSV.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Parser (T : in out Test);

   --  Test the CSV output stream generation.
   procedure Test_Output (T : in out Test);

end Util.Serialize.IO.CSV.Tests;

Declare the Test_Output procedure

Declare the Test_Output procedure


-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_LEVEL,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_START_TIME,
                       F_END_TIME,
                       F_MALLOC_COUNT,
                       F_REALLOC_COUNT,
                       F_FREE_COUNT,
                       F_EVENT_RANGE,
                       F_ID,
                       F_OLD_ADDR,
                       F_GROW_SIZE,
                       F_TIME,
                       F_DURATION,
                       F_EVENT,
                       F_MODE,
                       F_FRAME_ID,
                       F_RANGE_ADDR,
                       F_FRAME_ADDR);

   type Notice_Type is (N_HELP,
                        N_INFO,
                        N_EVENT_ID,
                        N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

   type Justify_Type is (J_LEFT,           --  Justify left   |item    |
                         J_RIGHT,          --  Justify right  |    item|
                         J_CENTER,         --  Justify center |  item  |
                         J_RIGHT_NO_FILL   --  Justify right  |item|
                        );

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the address range and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the time tick as a duration and print it for the given field.
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_LEVEL,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_START_TIME,
                       F_END_TIME,
                       F_MALLOC_COUNT,
                       F_REALLOC_COUNT,
                       F_FREE_COUNT,
                       F_EVENT_RANGE,
                       F_ID,
                       F_OLD_ADDR,
                       F_GROW_SIZE,
                       F_TIME,
                       F_DURATION,
                       F_EVENT,
                       F_NEXT,
                       F_PREVIOUS,
                       F_MODE,
                       F_FRAME_ID,
                       F_RANGE_ADDR,
                       F_FRAME_ADDR);

   type Notice_Type is (N_HELP,
                        N_INFO,
                        N_EVENT_ID,
                        N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

   type Justify_Type is (J_LEFT,           --  Justify left   |item    |
                         J_RIGHT,          --  Justify right  |    item|
                         J_CENTER,         --  Justify center |  item  |
                         J_RIGHT_NO_FILL   --  Justify right  |item|
                        );

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the address range and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the time tick as a duration and print it for the given field.
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

Declare F_NEXT and F_PREVIOUS

Declare F_NEXT and F_PREVIOUS