Overview
| Comment: | s_expression-interpreters: new package providing a S-expression interpreter which dispatch to client-provided commands |
|---|---|
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
6e4b5836c5d2de67cef1ae8054c0f03d |
| User & Date: | nat on 2014-03-12 21:26:44 |
| Other Links: | manifest | tags |
Context
|
2014-03-13
| ||
| 21:12 | Add missing Preelaborate pragmas check-in: d53403fc11 user: nat tags: trunk | |
|
2014-03-12
| ||
| 21:26 | s_expression-interpreters: new package providing a S-expression interpreter which dispatch to client-provided commands check-in: 6e4b5836c5 user: nat tags: trunk | |
|
2014-03-11
| ||
| 19:33 | coverage.sh: add more configuration variables for better flexibility check-in: 577fa9c3d6 user: nat tags: trunk | |
Changes
Added src/natools-s_expressions-interpreters.adb version [db1846c47e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
------------------------------------------------------------------------------
-- 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.Interpreters is
---------------------
-- Atom Comparison --
---------------------
function Less_Than (Left, Right : Atom) return Boolean is
begin
return Left'Length < Right'Length
or else (Left'Length = Right'Length and then Left < Right);
end Less_Than;
-----------------
-- 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 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.Interpreters;
|
Added src/natools-s_expressions-interpreters.ads version [36f18e7166].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
------------------------------------------------------------------------------
-- 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.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_Buffers;
generic
type Shared_State (<>) is limited private;
type Shared_Context (<>) is limited private;
package Natools.S_Expressions.Interpreters is
pragma Preelaborate (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 Interpreter is new Command with private;
procedure Add_Command
(Self : in out Interpreter;
Name : in Atom;
Cmd : in Command'Class);
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;
function Less_Than (Left, Right : Atom) return Boolean;
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_Buffers.Atom_Refs.Reference;
end record;
end Natools.S_Expressions.Interpreters;
|