Overview
Comment: | s_expressions-interpreters: make commands and interpreters read-only during execution |
---|---|
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
07db27cc2f0b154e08c92dfe934dd809 |
User & Date: | nat on 2014-05-14 18:33:17 |
Other Links: | manifest | tags |
Context
2014-05-15
| ||
21:26 | s_expressions-printers-pretty-config: update to match the new read-only interpreters check-in: e3c30c2e3d user: nat tags: trunk | |
2014-05-14
| ||
18:33 | s_expressions-interpreters: make commands and interpreters read-only during execution check-in: 07db27cc2f user: nat tags: trunk | |
2014-05-13
| ||
20:33 | s_expressions-dynamic_interpreter: backup of the current Interpreter interface before making it read-only check-in: d9a7acb07a user: nat tags: trunk | |
Changes
Modified src/natools-s_expressions-interpreters.adb from [25b368150e] to [3c3c74e8b6].
︙ | ︙ | |||
69 70 71 72 73 74 75 | procedure Reset_Fallback (Self : in out Interpreter) is begin Self.Fallback_Name.Reset; end Reset_Fallback; not overriding procedure Execute | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | procedure Reset_Fallback (Self : in out Interpreter) is begin Self.Fallback_Name.Reset; end Reset_Fallback; not overriding procedure Execute (Self : in 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 |
︙ | ︙ | |||
104 105 106 107 108 109 110 | Expression.Next (Event); end loop; end Execute; not overriding procedure Execute | | | | | | | | | | | 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 | Expression.Next (Event); end loop; end Execute; not overriding procedure Execute (Self : in Interpreter; Fallback : in 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 Command'Class)); procedure Process_Atom (Name : in Atom; Cmd : in Command'Class); procedure Process_Exp (Name : in Atom; Cmd : in Command'Class); procedure Dispatch (Process : not null access procedure (Name : in Atom; Cmd : in 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 Command_Maps.Query_Element (Cursor, Process); else Process (Buffer (1 .. Length), Fallback); end if; end if; end Dispatch; procedure Process_Atom (Name : in Atom; Cmd : in Command'Class) is begin Cmd.Execute (State, Context, Name); end Process_Atom; procedure Process_Exp (Name : in Atom; Cmd : in 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; |
︙ | ︙ | |||
185 186 187 188 189 190 191 | Expression.Next (Event); end loop; end Execute; overriding procedure Execute | | | | | | | | | | | | 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 264 265 266 267 268 269 270 271 272 | Expression.Next (Event); end loop; end Execute; overriding procedure Execute (Self : in Interpreter; State : in out Shared_State; Context : in Shared_Context; Name : in Atom) is procedure Process_Atom (Key : in Atom; Cmd : in Command'Class); procedure Process_Atom (Key : in Atom; Cmd : in 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 Command_Maps.Query_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 Command_Maps.Query_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 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 Command'Class); procedure Process_Exp (Name : in Atom; Actual : in 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 Command_Maps.Query_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 Command_Maps.Query_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; |
Modified src/natools-s_expressions-interpreters.ads from [4e8e3fffbf] to [75ac7d4a0a].
︙ | ︙ | |||
39 40 41 42 43 44 45 | Command_Not_Found : exception; type Command is interface; procedure Execute | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | Command_Not_Found : exception; type Command is interface; procedure Execute (Self : in Command; State : in out Shared_State; Context : in Shared_Context; Name : in Atom) is null; -- Execute a single argumentless command procedure Execute (Self : in Command; State : in out Shared_State; Context : in Shared_Context; Cmd : in out Lockable.Descriptor'Class) is null; -- Execute a single command with arguments |
︙ | ︙ | |||
83 84 85 86 87 88 89 | procedure Set_Fallback (Self : in out Interpreter; Name : in Atom); procedure Reset_Fallback (Self : in out Interpreter); not overriding procedure Execute | | | | | | | 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 | procedure Set_Fallback (Self : in out Interpreter; Name : in Atom); procedure Reset_Fallback (Self : in out Interpreter); not overriding procedure Execute (Self : in 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 Interpreter; Fallback : in 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 Interpreter; State : in out Shared_State; Context : in Shared_Context; Name : in Atom); -- Execute a single argumentless command overriding procedure Execute (Self : in Interpreter; State : in out Shared_State; Context : in Shared_Context; Cmd : in out Lockable.Descriptor'Class); -- Execute a single command with arguments private |
︙ | ︙ |
Modified tests/natools-s_expressions-interpreter_tests.adb from [60961f16a8] to [30df107f0e].
︙ | ︙ | |||
60 61 62 63 64 65 66 | ---------------------- -- Recorder Command -- ---------------------- overriding procedure Execute | | | | 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 | ---------------------- -- Recorder Command -- ---------------------- overriding procedure Execute (Self : in 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 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 |
︙ | ︙ | |||
103 104 105 106 107 108 109 | -------------------- -- Raiser Command -- -------------------- overriding procedure Execute | | | | 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 | -------------------- -- Raiser Command -- -------------------- overriding procedure Execute (Self : in 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 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; |
︙ | ︙ | |||
151 152 153 154 155 156 157 | -- Individual Tests -- ---------------------- procedure Test_Basic_Usage (Report : in out NT.Reporter'Class) is Test : NT.Test := Report.Item ("Basic usage"); begin declare | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | -- Individual Tests -- ---------------------- procedure Test_Basic_Usage (Report : in out NT.Reporter'Class) is Test : NT.Test := Report.Item ("Basic usage"); begin declare Inter : constant 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; |
︙ | ︙ | |||
192 193 194 195 196 197 198 | 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 | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | 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 : constant 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")); |
︙ | ︙ | |||
274 275 276 277 278 279 280 | end Test_Inspection; procedure Test_Local_Fallback (Report : in out NT.Reporter'Class) is Test : NT.Test := Report.Item ("Local fallback"); begin declare | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | end Test_Inspection; procedure Test_Local_Fallback (Report : in out NT.Reporter'Class) is Test : NT.Test := Report.Item ("Local fallback"); begin declare Inter : constant 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")); |
︙ | ︙ |
Modified tests/natools-s_expressions-interpreter_tests.ads from [3986bcf3da] to [a5ef199f64].
︙ | ︙ | |||
43 44 45 46 47 48 49 | package Test_Interpreters is new Natools.S_Expressions.Interpreters (Printers.Printer'Class, Boolean); type Recorder is new Test_Interpreters.Command with null record; overriding procedure Execute | | | | | | 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 | package Test_Interpreters is new Natools.S_Expressions.Interpreters (Printers.Printer'Class, Boolean); type Recorder is new Test_Interpreters.Command with null record; overriding procedure Execute (Self : in Recorder; State : in out Printers.Printer'Class; Context : in Boolean; Name : in Atom); overriding procedure Execute (Self : in 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 Raiser; State : in out Printers.Printer'Class; Context : in Boolean; Name : in Atom); overriding procedure Execute (Self : in Raiser; State : in out Printers.Printer'Class; Context : in Boolean; Cmd : in out Lockable.Descriptor'Class); end Natools.S_Expressions.Interpreter_Tests; |