Natools

Check-in [e61f083c1a]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:s_expressions-lockable: new package with an interface and a wrapper to lock a descriptor in the current sub-expression
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e61f083c1abac040beb6cd15215db8f8d8e3a91d
User & Date: nat on 2014-02-28 19:00:53
Other Links: manifest | tags
Context
2014-03-01
11:25
s_expressions-lockable-tests: new package with a test suite for lock level stack check-in: 0bbab0a171 user: nat tags: trunk
2014-02-28
19:00
s_expressions-lockable: new package with an interface and a wrapper to lock a descriptor in the current sub-expression check-in: e61f083c1a user: nat tags: trunk
2014-02-27
20:01
s_expressions-test_tools: add a Context argument to helper procedures check-in: f4b78c09f0 user: nat tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added src/natools-s_expressions-lockable.adb version [a27ae30975]. 




















































































































































































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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

------------------------------------------------------------------------------
-- 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.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Lockable is

   ----------------
   -- Lock Stack --
   ----------------

   procedure Push_Level
     (Stack : in out Lock_Stack;
      Level : in Natural;
      State : out Lock_State) is
   begin
      State := (Depth => Stack.Depth, Level => Stack.Level);
      Stack := (Depth => Stack.Depth + 1, Level => Level);
   end Push_Level;


   procedure Pop_Level
     (Stack : in out Lock_Stack;
      State : in Lock_State;
      Allow_Gap : in Boolean := False) is
   begin
      if State.Depth = 0 then
         raise Constraint_Error with "Invalid stack state";
      elsif State.Depth >= Stack.Depth then
         raise Constraint_Error with "Trying to Pop a state outside of Stack";
      elsif not Allow_Gap and then State.Depth < Stack.Depth - 1 then
         raise Constraint_Error
           with "Trying to Pop several items without Allow_Gap";
      end if;

      Stack := (Depth => State.Depth, Level => State.Level);
   end Pop_Level;


   function Current_Level (Stack : Lock_Stack) return Natural is
   begin
      return Stack.Level;
   end Current_Level;



   -------------------------------------
   -- Lockable Wrapper Implementation --
   -------------------------------------

   function Current_Event (Object : in Wrapper) return Events.Event is
   begin
      if Object.Finished then
         return Events.End_Of_Input;
      else
         return Object.Backend.Current_Event;
      end if;
   end Current_Event;


   function Current_Atom (Object : in Wrapper) return Atom is
   begin
      if Object.Finished then
         raise Program_Error with "Current_Atom on finished wrapper";
      else
         return Object.Backend.Current_Atom;
      end if;
   end Current_Atom;


   function Current_Level (Object : in Wrapper) return Natural is
   begin
      if Object.Finished then
         return 0;
      else
         return Object.Backend.Current_Level - Current_Level (Object.Stack);
      end if;
   end Current_Level;


   procedure Query_Atom
     (Object : in Wrapper;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Finished then
         raise Program_Error with "Query_Atom on finished wrapper";
      else
         Object.Backend.Query_Atom (Process);
      end if;
   end Query_Atom;


   procedure Read_Atom
     (Object : in Wrapper;
      Data : out Atom;
      Length : out Count) is
   begin
      if Object.Finished then
         raise Program_Error with "Read_Atom on finished wrapper";
      else
         Object.Backend.Read_Atom (Data, Length);
      end if;
   end Read_Atom;


   procedure Next
     (Object : in out Wrapper;
      Event : out Events.Event) is
   begin
      if Object.Finished then
         Event := Events.Error;
         return;
      end if;

      Object.Backend.Next (Event);

      if Event = Events.Close_List
        and then Object.Backend.Current_Level < Current_Level (Object.Stack)
      then
         Object.Finished := True;
         Event := Events.End_Of_Input;
      end if;
   end Next;


   procedure Lock
     (Object : in out Wrapper;
      State : out Lock_State) is
   begin
      Push_Level (Object.Stack, Object.Backend.Current_Level, State);
   end Lock;


   procedure Unlock
     (Object : in out Wrapper;
      State : in out Lock_State;
      Finish : in Boolean := True)
   is
      Previous_Level : constant Natural := Current_Level (Object.Stack);
   begin
      Pop_Level (Object.Stack, State);
      State := (0, 0);

      if Finish then
         declare
            Event : Events.Event;
         begin
            Event := Object.Backend.Current_Event;
            loop
               case Event is
                  when Events.Open_List | Events.Add_Atom =>
                     null;
                  when Events.Close_List =>
                     exit when Object.Backend.Current_Level < Previous_Level;
                  when Events.Error | Events.End_Of_Input =>
                     exit;
               end case;
               Object.Backend.Next (Event);
            end loop;
         end;
      end if;

      Object.Finished := Object.Backend.Current_Level
        < Current_Level (Object.Stack);
   end Unlock;

end Natools.S_Expressions.Lockable;








Added src/natools-s_expressions-lockable.ads version [836dd2af49].























































































































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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

------------------------------------------------------------------------------
-- 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.Lockable provides an interface for Descriptor that --
-- can be locked in the current nesting level, returning End_Of_Input       --
-- instead of Close_List of that level. That way the descriptor can         --
-- be safely handed to other code fragments without risking scope change.   --
--                                                                          --
-- A Wrapper type is also provided to add a lockable layer on top of a      --
-- basic Descriptor interface, however with the extra overhead of one more  --
-- call.                                                                    --
------------------------------------------------------------------------------

package Natools.S_Expressions.Lockable is
   pragma Pure (Lockable);

   type Lock_Stack is private;
   type Lock_State is private;

   procedure Push_Level
     (Stack : in out Lock_Stack;
      Level : in Natural;
      State : out Lock_State);
      --  Insert Level on top of Stack and return current State

   procedure Pop_Level
     (Stack : in out Lock_Stack;
      State : in Lock_State;
      Allow_Gap : in Boolean := False);
      --  Remove upper part of Stack, up to and including the entry pointed
      --  by State. Constraint_Error is raised if State does not point to a
      --  valid level in the stack, and if Allow_Gap is True and more than
      --  one item would be removed.

   function Current_Level (Stack : Lock_Stack) return Natural;
      --  Return the value on top of the stack


   type Descriptor is limited interface and S_Expressions.Descriptor;

   procedure Lock
     (Object : in out Descriptor;
      State : out Lock_State)
     is abstract;
      --  Turn Object into a state where it cannot reach below or beyond
      --  current nesting level at Lock call.

   procedure Unlock
     (Object : in out Descriptor;
      State : in out Lock_State;
      Finish : in Boolean := True)
     is abstract;
      --  Undo the effects of previous Lock call, and unwind Object until the
      --  end of locked level (unless Finish is False).


   type Wrapper (Backend : access S_Expressions.Descriptor'Class)
     is new Descriptor with private;
      --  Wrapper layer on top of a non-lockable object, albeit with the
      --  performance penalty of an extra layer.

   function Current_Event (Object : in Wrapper) return Events.Event;
   function Current_Atom (Object : in Wrapper) return Atom;
   function Current_Level (Object : in Wrapper) return Natural;
   procedure Query_Atom
     (Object : in Wrapper;
      Process : not null access procedure (Data : in Atom));
   procedure Read_Atom
     (Object : in Wrapper;
      Data : out Atom;
      Length : out Count);
   procedure Next
     (Object : in out Wrapper;
      Event : out Events.Event);

   procedure Lock
     (Object : in out Wrapper;
      State : out Lock_State);
   procedure Unlock
     (Object : in out Wrapper;
      State : in out Lock_State;
      Finish : in Boolean := True);

private

   type Lock_State is record
      Level, Depth : Natural := 0;
   end record;

   type Lock_Stack is record
      Level : Natural := 0;
      Depth : Positive := 1;
   end record;

   type Wrapper (Backend : access S_Expressions.Descriptor'Class)
     is new Descriptor with record
      Stack : Lock_Stack;
      Finished : Boolean := False;
   end record;

end Natools.S_Expressions.Lockable;













This page was generated in about
0.004s by
Fossil 2.23 [47362306a7] 2023-11-01 18:56:47