ADDED src/natools-s_expressions-dynamic_interpreters.adb Index: src/natools-s_expressions-dynamic_interpreters.adb ================================================================== --- src/natools-s_expressions-dynamic_interpreters.adb +++ src/natools-s_expressions-dynamic_interpreters.adb @@ -0,0 +1,272 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +package body Natools.S_Expressions.Dynamic_Interpreters is + + ----------------- + -- Interpreter -- + ----------------- + + procedure Add_Command + (Self : in out Interpreter; + Name : in Atom; + Cmd : in Command'Class) is + begin + Self.Commands.Insert (Name, Cmd); + Self.Max_Length := Count'Max (Self.Max_Length, Name'Length); + end Add_Command; + + + procedure Add + (Self : in out Interpreter; + Name : in String; + Cmd : in Command'Class) is + begin + Self.Add_Command (To_Atom (Name), Cmd); + end Add; + + + function Has_Command (Self : Interpreter; Name : Atom) return Boolean is + begin + return Self.Commands.Contains (Name); + end Has_Command; + + + function Is_Empty (Self : Interpreter) return Boolean is + begin + return Self.Commands.Is_Empty; + end Is_Empty; + + + procedure Set_Fallback + (Self : in out Interpreter; + Name : in Atom) + is + function Create return Atom; + + function Create return Atom is + begin + return Name; + end Create; + begin + Self.Fallback_Name.Replace (Create'Access); + end Set_Fallback; + + + procedure Reset_Fallback (Self : in out Interpreter) is + begin + Self.Fallback_Name.Reset; + end Reset_Fallback; + + + not overriding procedure Execute + (Self : in out Interpreter; + Expression : in out Lockable.Descriptor'Class; + State : in out Shared_State; + Context : in Shared_Context) + is + Event : Events.Event := Expression.Current_Event; + Lock_State : Lockable.Lock_State; + begin + loop + case Event is + when Events.Add_Atom => + Self.Execute (State, Context, Expression.Current_Atom); + when Events.Open_List => + Expression.Lock (Lock_State); + begin + Expression.Next (Event); + if Event = Events.Add_Atom then + Self.Execute (State, Context, Expression); + end if; + exception + when others => + Expression.Unlock (Lock_State, False); + raise; + end; + Expression.Unlock (Lock_State); + when Events.Close_List | Events.End_Of_Input | Events.Error => + exit; + end case; + + Expression.Next (Event); + end loop; + end Execute; + + + not overriding procedure Execute + (Self : in out Interpreter; + Fallback : in out Command'Class; + Expression : in out Lockable.Descriptor'Class; + State : in out Shared_State; + Context : in Shared_Context) + is + procedure Dispatch (Process : not null access procedure + (Name : in Atom; Cmd : in out Command'Class)); + procedure Process_Atom (Name : in Atom; Cmd : in out Command'Class); + procedure Process_Exp (Name : in Atom; Cmd : in out Command'Class); + + procedure Dispatch (Process : not null access procedure + (Name : in Atom; Cmd : in out Command'Class)) + is + procedure Process_Fallback (Name : in Atom); + + procedure Process_Fallback (Name : in Atom) is + begin + Process (Name, Fallback); + end Process_Fallback; + + Buffer : Atom (1 .. Self.Max_Length); + Length : Count; + Cursor : Command_Maps.Cursor; + begin + Expression.Read_Atom (Buffer, Length); + if Length > Self.Max_Length then + Expression.Query_Atom (Process_Fallback'Access); + else + Cursor := Self.Commands.Find (Buffer (1 .. Length)); + if Command_Maps.Has_Element (Cursor) then + Self.Commands.Update_Element (Cursor, Process); + else + Process (Buffer (1 .. Length), Fallback); + end if; + end if; + end Dispatch; + + procedure Process_Atom (Name : in Atom; Cmd : in out Command'Class) is + begin + Cmd.Execute (State, Context, Name); + end Process_Atom; + + procedure Process_Exp (Name : in Atom; Cmd : in out Command'Class) is + pragma Unreferenced (Name); + begin + Cmd.Execute (State, Context, Expression); + end Process_Exp; + + Event : Events.Event := Expression.Current_Event; + Lock_State : Lockable.Lock_State; + begin + loop + case Event is + when Events.Add_Atom => + Dispatch (Process_Atom'Access); + + when Events.Open_List => + Expression.Lock (Lock_State); + begin + Expression.Next (Event); + if Event = Events.Add_Atom then + Dispatch (Process_Exp'Access); + end if; + exception + when others => + Expression.Unlock (Lock_State, False); + raise; + end; + Expression.Unlock (Lock_State); + + when Events.Close_List | Events.End_Of_Input | Events.Error => + exit; + end case; + + Expression.Next (Event); + end loop; + end Execute; + + + overriding procedure Execute + (Self : in out Interpreter; + State : in out Shared_State; + Context : in Shared_Context; + Name : in Atom) + is + procedure Process_Atom (Key : in Atom; Cmd : in out Command'Class); + + procedure Process_Atom (Key : in Atom; Cmd : in out Command'Class) is + pragma Unreferenced (Key); + begin + Cmd.Execute (State, Context, Name); + end Process_Atom; + + Cursor : Command_Maps.Cursor; + begin + if Name'Length <= Self.Max_Length then + Cursor := Self.Commands.Find (Name); + if Command_Maps.Has_Element (Cursor) then + Self.Commands.Update_Element (Cursor, Process_Atom'Access); + return; + end if; + end if; + + if not Self.Fallback_Name.Is_Empty then + Cursor := Self.Commands.Find (Self.Fallback_Name.Query.Data.all); + if Command_Maps.Has_Element (Cursor) then + Self.Commands.Update_Element (Cursor, Process_Atom'Access); + return; + end if; + end if; + + raise Command_Not_Found + with "Unknown command """ & To_String (Name) & '"'; + end Execute; + + + overriding procedure Execute + (Self : in out Interpreter; + State : in out Shared_State; + Context : in Shared_Context; + Cmd : in out Lockable.Descriptor'Class) + is + procedure Process_Exp (Name : in Atom; Actual : in out Command'Class); + + procedure Process_Exp (Name : in Atom; Actual : in out Command'Class) is + pragma Unreferenced (Name); + begin + Actual.Execute (State, Context, Cmd); + end Process_Exp; + + Buffer : Atom (1 .. Self.Max_Length); + Length : Count; + Cursor : Command_Maps.Cursor; + begin + if Cmd.Current_Event /= Events.Add_Atom then + return; + end if; + + Cmd.Read_Atom (Buffer, Length); + + if Length <= Self.Max_Length then + Cursor := Self.Commands.Find (Buffer (1 .. Length)); + if Command_Maps.Has_Element (Cursor) then + Self.Commands.Update_Element (Cursor, Process_Exp'Access); + return; + end if; + end if; + + if not Self.Fallback_Name.Is_Empty then + Cursor := Self.Commands.Find (Self.Fallback_Name.Query.Data.all); + if Command_Maps.Has_Element (Cursor) then + Self.Commands.Update_Element (Cursor, Process_Exp'Access); + return; + end if; + end if; + + raise Command_Not_Found + with "Unknown command """ & To_String (Cmd.Current_Atom) & '"'; + end Execute; + +end Natools.S_Expressions.Dynamic_Interpreters; ADDED src/natools-s_expressions-dynamic_interpreters.ads Index: src/natools-s_expressions-dynamic_interpreters.ads ================================================================== --- src/natools-s_expressions-dynamic_interpreters.ads +++ src/natools-s_expressions-dynamic_interpreters.ads @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.S_Expressions.Dynamic_Interpreters provides an implemntation of -- +-- a dispatching command interpreter. The base list of a given S-expression -- +-- is considered as list of command, either argumentless (atoms) or with a -- +-- S-expression argument (sublist). Sublists that don't start with an atom -- +-- are silently ignored and can be used as comments. -- +-- -- +-- Formal types represent common objets for all the command, Shared_State -- +-- begin read/write while Shared_Context is read-only. -- +------------------------------------------------------------------------------ + +with Natools.S_Expressions.Lockable; + +private with Ada.Containers.Indefinite_Ordered_Maps; +private with Natools.S_Expressions.Atom_Refs; + +generic + type Shared_State (<>) is limited private; + type Shared_Context (<>) is limited private; + +package Natools.S_Expressions.Dynamic_Interpreters is + pragma Preelaborate (Dynamic_Interpreters); + + Command_Not_Found : exception; + + + type Command is interface; + + procedure Execute + (Self : in out Command; + State : in out Shared_State; + Context : in Shared_Context; + Name : in Atom) + is null; + -- Execute a single argumentless command + + procedure Execute + (Self : in out Command; + State : in out Shared_State; + Context : in Shared_Context; + Cmd : in out Lockable.Descriptor'Class) + is null; + -- Execute a single command with arguments + + + type Null_Command is new Command with null record; + + Do_Nothing : Null_Command := Null_Command'(null record); + + + type Interpreter is new Command with private; + + procedure Add_Command + (Self : in out Interpreter; + Name : in Atom; + Cmd : in Command'Class); + + procedure Add + (Self : in out Interpreter; + Name : in String; + Cmd : in Command'Class); + + function Has_Command (Self : Interpreter; Name : Atom) return Boolean; + + function Is_Empty (Self : Interpreter) return Boolean; + + procedure Set_Fallback + (Self : in out Interpreter; + Name : in Atom); + + procedure Reset_Fallback (Self : in out Interpreter); + + not overriding procedure Execute + (Self : in out Interpreter; + Expression : in out Lockable.Descriptor'Class; + State : in out Shared_State; + Context : in Shared_Context); + -- Execute an expression, raising Command_Not_Found on unknown commands + + not overriding procedure Execute + (Self : in out Interpreter; + Fallback : in out Command'Class; + Expression : in out Lockable.Descriptor'Class; + State : in out Shared_State; + Context : in Shared_Context); + -- Execute an expression with temporary fallback for unknown commands + + overriding procedure Execute + (Self : in out Interpreter; + State : in out Shared_State; + Context : in Shared_Context; + Name : in Atom); + -- Execute a single argumentless command + + overriding procedure Execute + (Self : in out Interpreter; + State : in out Shared_State; + Context : in Shared_Context; + Cmd : in out Lockable.Descriptor'Class); + -- Execute a single command with arguments + + +private + + type Exception_Command is new Command with null record; + + package Command_Maps is new Ada.Containers.Indefinite_Ordered_Maps + (Atom, Command'Class, Less_Than); + + type Interpreter is new Command with record + Commands : Command_Maps.Map; + Max_Length : Count := 0; + Fallback_Name : Atom_Refs.Reference; + end record; + +end Natools.S_Expressions.Dynamic_Interpreters; ADDED tests/natools-s_expressions-dynamic_interpreter_tests.adb Index: tests/natools-s_expressions-dynamic_interpreter_tests.adb ================================================================== --- tests/natools-s_expressions-dynamic_interpreter_tests.adb +++ tests/natools-s_expressions-dynamic_interpreter_tests.adb @@ -0,0 +1,399 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Natools.S_Expressions.Caches; +with Natools.S_Expressions.Test_Tools; + +package body Natools.S_Expressions.Dynamic_Interpreter_Tests is + + function Test_Interpreter return Test_Interpreters.Interpreter; + + function Invalid_Commands return Caches.Reference; + + + ------------------------ + -- Helper Subprograms -- + ------------------------ + + function Invalid_Commands return Caches.Reference is + Cache : Caches.Reference; + Short : constant Atom := To_Atom ("not-cmd"); + Long : constant Atom := To_Atom ("not-a-command"); + begin + Cache.Append_Atom (Short); + Cache.Open_List; + Cache.Append_Atom (Short); + Cache.Append_Atom (To_Atom ("arg")); + Cache.Close_List; + Cache.Append_Atom (Long); + Cache.Open_List; + Cache.Append_Atom (Long); + Cache.Open_List; + Cache.Close_List; + Cache.Close_List; + return Cache; + end Invalid_Commands; + + + function Test_Interpreter return Test_Interpreters.Interpreter is + Template : Recorder; + begin + return Inter : Test_Interpreters.Interpreter do + Inter.Add_Command (To_Atom ("cmd"), Template); + Inter.Add_Command (To_Atom ("command"), Template); + end return; + end Test_Interpreter; + + + + ---------------------- + -- Recorder Command -- + ---------------------- + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom) + is + pragma Unreferenced (Self); + begin + if Context then + State.Append_Atom (Name); + end if; + end Execute; + + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class) + is + pragma Unreferenced (Self); + begin + if not Context then + return; + end if; + + declare + Buffer : aliased Test_Tools.Memory_Stream; + Serializer : Printers.Canonical (Buffer'Access); + begin + Printers.Transfer (Cmd, Serializer); + State.Open_List; + State.Append_Atom (Buffer.Get_Data); + State.Close_List; + end; + end Execute; + + + + -------------------- + -- Raiser Command -- + -------------------- + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom) + is + pragma Unreferenced (Self, State, Context, Name); + begin + raise Special_Exception; + end Execute; + + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class) + is + pragma Unreferenced (Self, State, Context, Cmd); + begin + raise Special_Exception; + end Execute; + + + + ------------------------- + -- Complete Test Suite -- + ------------------------- + + procedure All_Tests (Report : in out NT.Reporter'Class) is + begin + Test_Basic_Usage (Report); + Test_Unknown_Commands (Report); + Test_Premanent_Fallback (Report); + Test_Local_Fallback (Report); + Test_Exception_Fallback (Report); + Test_Inspection (Report); + end All_Tests; + + + + ---------------------- + -- Individual Tests -- + ---------------------- + + procedure Test_Basic_Usage (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Basic usage"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : Caches.Reference; + Cursor : Caches.Cursor; + begin + Input.Append_Atom (To_Atom ("cmd")); + Input.Open_List; + Input.Append_Atom (To_Atom ("cmd")); + Input.Append_Atom (To_Atom ("foo")); + Input.Append_Atom (To_Atom ("bar")); + Input.Close_List; + Input.Append_Atom (To_Atom ("command")); + Input.Open_List; + Input.Open_List; + Input.Append_Atom (To_Atom ("comment")); + Input.Close_List; + Input.Close_List; + Input.Open_List; + Input.Append_Atom (To_Atom ("command")); + Input.Open_List; + Input.Close_List; + Input.Close_List; + + Cursor := Input.First; + + Buffer.Set_Expected (To_Atom + ("3:cmd(15:3:cmd3:foo3:bar)7:command(11:7:command())")); + + Inter.Execute (Cursor, Printer, True); + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Basic_Usage; + + + procedure Test_Exception_Fallback (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Local fallback raising an exception"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : Caches.Reference; + Cursor : Caches.Cursor; + Fallback : Raiser; + begin + Input.Append_Atom (To_Atom ("cmd")); + Input.Open_List; + Input.Append_Atom (To_Atom ("unknown")); + Input.Append_Atom (To_Atom ("argument")); + Input.Close_List; + Input.Close_List; + Input.Open_List; + Input.Append_Atom (To_Atom ("command")); + Input.Close_List; + Cursor := Input.First; + + Buffer.Set_Expected (To_Atom ("3:cmd")); + + begin + Inter.Execute (Fallback, Cursor, Printer, True); + Test.Fail ("No exception raised"); + exception + when Special_Exception => null; + when Error : others => + Test.Fail ("Wrong exception raised:"); + Test.Report_Exception (Error, NT.Fail); + end; + + Buffer.Check_Stream (Test); + + Test_Tools.Next_And_Check (Test, Cursor, To_Atom ("argument"), 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 1); + Test_Tools.Next_And_Check (Test, Cursor, To_Atom ("command"), 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check (Test, Cursor, Events.End_Of_Input, 0); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Exception_Fallback; + + + procedure Test_Inspection (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Inspection"); + begin + declare + Inter : Test_Interpreters.Interpreter; + begin + if not Inter.Is_Empty then + Test.Fail ("Default interpreter is not empty"); + end if; + + if Inter.Has_Command (To_Atom ("cmd")) then + Test.Fail ("Default interpreter has command ""cmd"""); + end if; + + Inter := Test_Interpreter; + + if Inter.Is_Empty then + Test.Fail ("Test interpreter is empty"); + end if; + + if not Inter.Has_Command (To_Atom ("cmd")) then + Test.Fail ("Test interpreter has not command ""cmd"""); + end if; + + if Inter.Has_Command (To_Atom ("not-a-cmd")) then + Test.Fail ("Test interpreter has command ""not-a-cmd"""); + end if; + + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Inspection; + + + procedure Test_Local_Fallback (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Local fallback"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : Caches.Reference := Invalid_Commands; + Cursor : Caches.Cursor := Input.First; + Fallback : Recorder; + begin + Input.Append_Atom (To_Atom ("cmd")); + Buffer.Set_Expected (To_Atom + ("7:not-cmd(14:7:not-cmd3:arg)13:not-a-command" + & "(18:13:not-a-command())3:cmd")); + + Inter.Execute (Fallback, Cursor, Printer, True); + + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Local_Fallback; + + + procedure Test_Premanent_Fallback (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Permanent fallback"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : constant Caches.Reference := Invalid_Commands; + Cursor : Caches.Cursor := Input.First; + begin + Buffer.Set_Expected (To_Atom + ("7:not-cmd(14:7:not-cmd3:arg)13:not-a-command" + & "(18:13:not-a-command())")); + + Inter.Set_Fallback (To_Atom ("cmd")); + Inter.Execute (Cursor, Printer, True); + + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Premanent_Fallback; + + + procedure Test_Unknown_Commands (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Unknown commands"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : constant Caches.Reference := Invalid_Commands; + Cursor : Caches.Cursor := Input.First; + begin + Inter.Set_Fallback (To_Atom ("cmd")); + Inter.Reset_Fallback; + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after not-cmd"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after not-cmd"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 1); + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after (not-cmd)"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after (not-cmd)"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, To_Atom ("arg"), 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check + (Test, Cursor, To_Atom ("not-a-command"), 0); + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after not-a-command"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after not-a-command"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 1); + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after not-a-command"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after not-a-command"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 2); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check (Test, Cursor, Events.End_Of_Input, 0); + + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Unknown_Commands; + +end Natools.S_Expressions.Dynamic_Interpreter_Tests; ADDED tests/natools-s_expressions-dynamic_interpreter_tests.ads Index: tests/natools-s_expressions-dynamic_interpreter_tests.ads ================================================================== --- tests/natools-s_expressions-dynamic_interpreter_tests.ads +++ tests/natools-s_expressions-dynamic_interpreter_tests.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.S_Expressions.Dynamic_Interpreter_Tests provides a test suite -- +-- for the dyamic version of S-expression interpreters. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +private with Natools.S_Expressions.Dynamic_Interpreters; +private with Natools.S_Expressions.Lockable; +private with Natools.S_Expressions.Printers; + +package Natools.S_Expressions.Dynamic_Interpreter_Tests is + pragma Preelaborate (Dynamic_Interpreter_Tests); + + package NT renames Natools.Tests; + + procedure All_Tests (Report : in out NT.Reporter'Class); + + procedure Test_Basic_Usage (Report : in out NT.Reporter'Class); + procedure Test_Exception_Fallback (Report : in out NT.Reporter'Class); + procedure Test_Inspection (Report : in out NT.Reporter'Class); + procedure Test_Local_Fallback (Report : in out NT.Reporter'Class); + procedure Test_Premanent_Fallback (Report : in out NT.Reporter'Class); + procedure Test_Unknown_Commands (Report : in out NT.Reporter'Class); + +private + + package Test_Interpreters is new Natools.S_Expressions.Dynamic_Interpreters + (Printers.Printer'Class, Boolean); + + type Recorder is new Test_Interpreters.Command with null record; + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom); + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class); + + Special_Exception : exception; + + type Raiser is new Test_Interpreters.Command with null record; + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom); + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class); + +end Natools.S_Expressions.Dynamic_Interpreter_Tests; Index: tests/test_all.adb ================================================================== --- tests/test_all.adb +++ tests/test_all.adb @@ -24,10 +24,11 @@ with Natools.Getopt_Long_Tests; with Natools.HMAC_Tests; with Natools.Reference_Tests; with Natools.S_Expressions.Atom_Buffers.Tests; with Natools.S_Expressions.Cache_Tests; +with Natools.S_Expressions.Dynamic_Interpreter_Tests; with Natools.S_Expressions.Encodings.Tests; with Natools.S_Expressions.Interpreter_Tests; with Natools.S_Expressions.Lockable.Tests; with Natools.S_Expressions.Parsers.Tests; with Natools.S_Expressions.Printers.Tests; @@ -87,10 +88,14 @@ Report.End_Section; Report.Section ("S_Expressions.Caches"); Natools.S_Expressions.Cache_Tests.All_Tests (Report); Report.End_Section; + + Report.Section ("S_Expressions.Dynamic_Interpreters"); + Natools.S_Expressions.Dynamic_Interpreter_Tests.All_Tests (Report); + Report.End_Section; Report.Section ("S_Expressions.Encodings"); Natools.S_Expressions.Encodings.Tests.All_Tests (Report); Report.End_Section;