ADDED src/natools-s_expressions-lockable.adb Index: src/natools-s_expressions-lockable.adb ================================================================== --- src/natools-s_expressions-lockable.adb +++ src/natools-s_expressions-lockable.adb @@ -0,0 +1,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 Index: src/natools-s_expressions-lockable.ads ================================================================== --- src/natools-s_expressions-lockable.ads +++ src/natools-s_expressions-lockable.ads @@ -0,0 +1,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;