From eec4925c2ea989ffceb32831f321e510f5f8f1c6 Mon Sep 17 00:00:00 2001 From: Tobias Reiher Date: Fri, 21 Jan 2022 14:01:56 +0100 Subject: [PATCH] Generate tagged types for sessions Ref. #768 --- defaults.adc | 3 +- examples/apps/dhcp_client/src/channel.adb | 5 +- examples/apps/dhcp_client/src/dhcp_client.adb | 101 +- examples/apps/dhcp_client/src/session.ads | 13 +- rflx/ada.py | 106 +- rflx/generator/allocator.py | 211 ++- rflx/generator/generator.py | 23 +- rflx/generator/session.py | 1436 +++++++++++------ tests/README.md | 3 +- tests/integration/feature_test.py | 8 +- .../generated/rflx-test-session.adb | 204 +-- .../generated/rflx-test-session.ads | 170 +- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../generated/rflx-test-session.adb | 234 ++- .../generated/rflx-test-session.ads | 170 +- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../generated/rflx-test-session.adb | 185 +-- .../generated/rflx-test-session.ads | 129 +- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../generated/rflx-test-session.adb | 168 +- .../generated/rflx-test-session.ads | 159 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 195 +-- .../generated/rflx-test-session.ads | 183 ++- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../generated/rflx-test-session.adb | 148 +- .../generated/rflx-test-session.ads | 167 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 244 +-- .../generated/rflx-test-session.ads | 159 +- .../generated/rflx-test-session_allocator.adb | 24 +- .../generated/rflx-test-session_allocator.ads | 43 +- .../generated/rflx-test-session.adb | 450 ++---- .../generated/rflx-test-session.ads | 156 +- .../generated/rflx-test-session_allocator.adb | 44 +- .../generated/rflx-test-session_allocator.ads | 81 +- .../generated/rflx-test-session.adb | 178 +- .../generated/rflx-test-session.ads | 170 +- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../generated/rflx-test-session.adb | 295 ++-- .../generated/rflx-test-session.ads | 205 ++- .../generated/rflx-test-session_allocator.adb | 29 +- .../generated/rflx-test-session_allocator.ads | 58 +- .../integration/session_functions/config.yml | 4 - .../generated/rflx-test-session.adb | 190 +-- .../generated/rflx-test-session.ads | 192 ++- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../session_functions/src/func.adb | 36 - .../session_functions/src/func.ads | 20 - .../session_functions/src/session.adb | 44 + .../session_functions/src/session.ads | 40 + tests/integration/session_functions/test.rflx | 4 +- .../generated/rflx-test-session.adb | 206 +-- .../generated/rflx-test-session.ads | 159 +- .../generated/rflx-test-session_allocator.adb | 19 +- .../generated/rflx-test-session_allocator.ads | 36 +- .../generated/rflx-b-session.adb | 101 +- .../generated/rflx-b-session.ads | 120 +- .../generated/rflx-b-session_allocator.adb | 14 +- .../generated/rflx-b-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 101 +- .../generated/rflx-test-session.ads | 120 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 140 +- .../generated/rflx-test-session.ads | 159 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 140 +- .../generated/rflx-test-session.ads | 159 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 209 +-- .../generated/rflx-test-session.ads | 151 +- .../generated/rflx-test-session_allocator.adb | 34 +- .../generated/rflx-test-session_allocator.ads | 63 +- .../generated/rflx-test-session.adb | 170 +- .../generated/rflx-test-session.ads | 159 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- .../generated/rflx-test-session.adb | 171 +- .../generated/rflx-test-session.ads | 162 +- .../generated/rflx-test-session_allocator.adb | 14 +- .../generated/rflx-test-session_allocator.ads | 29 +- tests/unit/ada_test.py | 50 +- tests/unit/generator_test.py | 311 ++-- tests/utils.py | 259 +-- 95 files changed, 5738 insertions(+), 4822 deletions(-) delete mode 100644 tests/integration/session_functions/src/func.adb delete mode 100644 tests/integration/session_functions/src/func.ads create mode 100644 tests/integration/session_functions/src/session.adb create mode 100644 tests/integration/session_functions/src/session.ads diff --git a/defaults.adc b/defaults.adc index 899d395aa5..0a67cc9bcd 100644 --- a/defaults.adc +++ b/defaults.adc @@ -1,2 +1,3 @@ -pragma Restrictions (No_Elaboration_Code); +-- pragma Restrictions (No_Elaboration_Code); pragma Restrictions (No_Secondary_Stack); +-- pragma Restrictions (No_Tagged_Type_Registration); diff --git a/examples/apps/dhcp_client/src/channel.adb b/examples/apps/dhcp_client/src/channel.adb index cb0c91585c..c93ca91d1f 100644 --- a/examples/apps/dhcp_client/src/channel.adb +++ b/examples/apps/dhcp_client/src/channel.adb @@ -57,12 +57,11 @@ is SPARK_Mode => Off is Data : constant Ada.Streams.Stream_Element_Array (1 .. Buffer'Length) := To_Ada_Stream (Buffer); - Last : Ada.Streams.Stream_Element_Offset; + Unused_Last : Ada.Streams.Stream_Element_Offset; begin - pragma Unreferenced (Last); GNAT.Sockets.Send_Socket (Socket => Socket, Item => Data, - Last => Last, + Last => Unused_Last, To => GNAT.Sockets.Sock_Addr_Type'(Family => GNAT.Sockets.Family_Inet, Addr => GNAT.Sockets.Inet_Addr ("255.255.255.255"), Port => 67)); diff --git a/examples/apps/dhcp_client/src/dhcp_client.adb b/examples/apps/dhcp_client/src/dhcp_client.adb index bd70eed10a..41fdeb4867 100644 --- a/examples/apps/dhcp_client/src/dhcp_client.adb +++ b/examples/apps/dhcp_client/src/dhcp_client.adb @@ -2,87 +2,86 @@ pragma SPARK_Mode; with Ada.Text_IO; -with GNAT.Sockets; - with RFLX.RFLX_Types; with RFLX.RFLX_Builtin_Types; with RFLX.DHCP_Client.Session; with Channel; +with Session; procedure DHCP_Client is - Socket : GNAT.Sockets.Socket_Type; - - package Session is new RFLX.DHCP_Client.Session; + package DHCP_Client_Session renames RFLX.DHCP_Client.Session; + package Types renames RFLX.RFLX_Types; - procedure Read with + procedure Read (Ctx : in out Session.Context) with Pre => - Session.Initialized - and then Session.Has_Data (Session.C_Channel), + DHCP_Client_Session.Initialized (Ctx) + and then DHCP_Client_Session.Has_Data (Ctx, DHCP_Client_Session.C_Channel), Post => - Session.Initialized + DHCP_Client_Session.Initialized (Ctx) is - use type RFLX.RFLX_Types.Index; - use type RFLX.RFLX_Types.Length; - Buffer : RFLX.RFLX_Types.Bytes (RFLX.RFLX_Types.Index'First .. RFLX.RFLX_Types.Index'First + 4095) + use type Types.Index; + use type Types.Length; + Buffer : Types.Bytes (Types.Index'First .. Types.Index'First + 4095) := (others => 0); + Size : constant Types.Length := DHCP_Client_Session.Read_Buffer_Size (Ctx, DHCP_Client_Session.C_Channel); begin - if Buffer'Length >= Session.Read_Buffer_Size (Session.C_Channel) then - Session.Read - (Session.C_Channel, - Buffer - (Buffer'First - .. Buffer'First - 2 + RFLX.RFLX_Types.Index (Session.Read_Buffer_Size (Session.C_Channel) + 1))); - Channel.Send - (Socket, - Buffer - (Buffer'First - .. Buffer'First - 2 + RFLX.RFLX_Types.Index (Session.Read_Buffer_Size (Session.C_Channel) + 1))); - else - Ada.Text_IO.Put_Line ("Error: read buffer too small"); + if Size = 0 then + Ada.Text_IO.Put_Line ("Error: read buffer size is 0"); + return; end if; + if Buffer'Length < Size then + Ada.Text_IO.Put_Line ("Error: buffer too small"); + return; + end if; + DHCP_Client_Session.Read + (Ctx, + DHCP_Client_Session.C_Channel, + Buffer (Buffer'First .. Buffer'First - 2 + Types.Index (Size + 1))); + Channel.Send + (Ctx.Socket, + Buffer (Buffer'First .. Buffer'First - 2 + Types.Index (Size + 1))); end Read; - procedure Write with + procedure Write (Ctx : in out Session.Context) with Pre => - Session.Initialized - and then Session.Needs_Data (Session.C_Channel), + DHCP_Client_Session.Initialized (Ctx) + and then DHCP_Client_Session.Needs_Data (Ctx, DHCP_Client_Session.C_Channel), Post => - Session.Initialized + DHCP_Client_Session.Initialized (Ctx) is - use type RFLX.RFLX_Types.Index; - use type RFLX.RFLX_Types.Length; - Buffer : RFLX.RFLX_Types.Bytes (RFLX.RFLX_Types.Index'First .. RFLX.RFLX_Types.Index'First + 4095); + use type Types.Index; + use type Types.Length; + Buffer : Types.Bytes (Types.Index'First .. Types.Index'First + 4095); Length : RFLX.RFLX_Builtin_Types.Length; begin - Channel.Receive (Socket, Buffer, Length); + Channel.Receive (Ctx.Socket, Buffer, Length); if Length > 0 - and Length <= Session.Write_Buffer_Size (Session.C_Channel) + and Length <= DHCP_Client_Session.Write_Buffer_Size (Ctx, DHCP_Client_Session.C_Channel) then - Session.Write - (Session.C_Channel, + DHCP_Client_Session.Write + (Ctx, + DHCP_Client_Session.C_Channel, Buffer (Buffer'First .. Buffer'First + RFLX.RFLX_Builtin_Types.Index (Length) - 1)); end if; end Write; + + Ctx : Session.Context; begin - Channel.Initialize (Socket); - Session.Initialize; - while Session.Active loop - pragma Loop_Invariant (Session.Initialized); - for C in Session.Channel'Range loop - pragma Loop_Invariant (Session.Initialized); - if Session.Has_Data (C) then - Read; + Channel.Initialize (Ctx.Socket); + DHCP_Client_Session.Initialize (Ctx); + while DHCP_Client_Session.Active (Ctx) loop + pragma Loop_Invariant (DHCP_Client_Session.Initialized (Ctx)); + for C in DHCP_Client_Session.Channel'Range loop + pragma Loop_Invariant (DHCP_Client_Session.Initialized (Ctx)); + if DHCP_Client_Session.Has_Data (Ctx, C) then + Read (Ctx); end if; - if Session.Needs_Data (C) then - Write; + if DHCP_Client_Session.Needs_Data (Ctx, C) then + Write (Ctx); end if; end loop; - Session.Run; + DHCP_Client_Session.Run (Ctx); end loop; - -- ISSUE: Componolit/Workarounds#32 - pragma Warnings (Off, """*"" is set by ""Finalize"" but not used after the call"); - Session.Finalize; - pragma Warnings (On, """*"" is set by ""Finalize"" but not used after the call"); end DHCP_Client; diff --git a/examples/apps/dhcp_client/src/session.ads b/examples/apps/dhcp_client/src/session.ads index 200be0e513..8a6930a12c 100644 --- a/examples/apps/dhcp_client/src/session.ads +++ b/examples/apps/dhcp_client/src/session.ads @@ -1,5 +1,14 @@ -pragma SPARK_Mode; +with GNAT.Sockets; with RFLX.DHCP_Client.Session; -package Session is new RFLX.DHCP_Client.Session; +package Session with + SPARK_Mode +is + + type Context is new RFLX.DHCP_Client.Session.Context with + record + Socket : GNAT.Sockets.Socket_Type; + end record; + +end Session; diff --git a/rflx/ada.py b/rflx/ada.py index a030f114ad..2b003189d8 100644 --- a/rflx/ada.py +++ b/rflx/ada.py @@ -1,5 +1,7 @@ # pylint: disable=too-many-lines +from __future__ import annotations + import itertools import os from abc import abstractmethod @@ -413,6 +415,10 @@ class Image(Attribute): pass +class Class(Attribute): + pass + + class UnrestrictedAccess(Attribute): @property def _representation(self) -> str: @@ -945,6 +951,32 @@ def definition(self) -> str: return str(self.expr) +class ClassPrecondition(Aspect): + def __init__(self, expr: Expr) -> None: + self.expr = expr + + @property + def mark(self) -> str: + return "Pre'Class" + + @property + def definition(self) -> str: + return str(self.expr) + + +class ClassPostcondition(Aspect): + def __init__(self, expr: Expr) -> None: + self.expr = expr + + @property + def mark(self) -> str: + return "Post'Class" + + @property + def definition(self) -> str: + return str(self.expr) + + class ContractCases(Aspect): def __init__(self, *cases: Tuple[Expr, Expr]) -> None: self.cases = cases @@ -1069,6 +1101,7 @@ def definition(self) -> str: class Annotate(Aspect): def __init__(self, *args: str) -> None: + assert len(args) > 0 self.args = args @property @@ -1081,6 +1114,16 @@ def definition(self) -> str: return f"({args})" +class ElaborateBody(Aspect): + @property + def mark(self) -> str: + return "Elaborate_Body" + + @property + def definition(self) -> str: + return "" + + class FormalDeclaration(Base): @abstractmethod def __str__(self) -> str: @@ -1365,13 +1408,32 @@ def type_definition(self) -> str: class DerivedType(TypeDeclaration): - def __init__(self, identifier: StrID, type_identifier: StrID) -> None: + def __init__( + self, + identifier: StrID, + type_identifier: StrID, + record_extension: Sequence[Component] = None, + ) -> None: super().__init__(identifier) self.type_identifier = ID(type_identifier) + self.record_extension = record_extension @property def type_definition(self) -> str: - return f" new {self.type_identifier}" + extension = "" + + if self.record_extension is not None: + if len(self.record_extension) == 0: + extension = " with null record" + else: + components = ( + (indent("\n".join(map(str, self.record_extension)), 6) + "\n") + if self.record_extension + else "" + ) + extension = f" with\n record\n{components} end record" + + return f" new {self.type_identifier}{extension}" class PrivateType(TypeDeclaration): @@ -1415,17 +1477,23 @@ def type_definition(self) -> str: class Component(Base): def __init__( - self, identifier: StrID, type_identifier: Union[StrID, Expr], default: Expr = None + self, + identifier: StrID, + type_identifier: Union[StrID, Expr], + default: Expr = None, + aliased: bool = False, ) -> None: self.identifier = ID(identifier) self.type_identifier = ( type_identifier if isinstance(type_identifier, Expr) else Variable(type_identifier) ) self.default = default + self.aliased = aliased def __str__(self) -> str: default = f" := {self.default}" if self.default else "" - return f"{self.identifier} : {self.type_identifier}{default};" + aliased = "aliased " if self.aliased else "" + return f"{self.identifier} : {aliased}{self.type_identifier}{default};" class NullComponent(Component): @@ -1458,26 +1526,39 @@ def __str__(self) -> str: class RecordType(TypeDeclaration): - def __init__( + def __init__( # pylint: disable = too-many-arguments self, identifier: StrID, components: List[Component], discriminants: Sequence[Discriminant] = None, variant_part: VariantPart = None, aspects: Sequence[Aspect] = None, + abstract: bool = False, + tagged: bool = False, ) -> None: + assert tagged if abstract else True super().__init__(identifier, discriminants, aspects) self.components = components self.discriminants = discriminants or [] self.variant_part = variant_part + self.abstract = abstract + self.tagged = tagged @property def type_definition(self) -> str: - components = ( - (indent("\n".join(map(str, self.components)), 6) + "\n") if self.components else "" - ) - variant_part = indent(str(self.variant_part), 6) if self.variant_part else "" - return f"\n" f" record\n" f"{components}" f"{variant_part}" f" end record" + abstract = " abstract" if self.abstract else "" + tagged = " tagged" if self.tagged else "" + + if self.components or self.variant_part: + components = ( + (indent("\n".join(map(str, self.components)), 6) + "\n") if self.components else "" + ) + variant_part = indent(str(self.variant_part), 6) if self.variant_part else "" + definition = f"\n record\n{components}{variant_part} end record" + else: + definition = " null record" + + return f"{abstract}{tagged}{definition}" class Statement(Base): @@ -1808,15 +1889,18 @@ def __init__( specification: SubprogramSpecification, aspects: Sequence[Aspect] = None, formal_parameters: Sequence[FormalDeclaration] = None, + abstract: bool = False, ) -> None: super().__init__(specification) self.aspects = aspects or [] self.formal_parameters = formal_parameters + self.abstract = abstract def __str__(self) -> str: + abstract = " is abstract" if self.abstract else "" return ( f"{generic_formal_part(self.formal_parameters)}" - f"{self.specification}{aspect_specification(self.aspects)};" + f"{self.specification}{abstract}{aspect_specification(self.aspects)};" ) diff --git a/rflx/generator/allocator.py b/rflx/generator/allocator.py index 4f69db9fd4..405fe5b6bb 100644 --- a/rflx/generator/allocator.py +++ b/rflx/generator/allocator.py @@ -10,34 +10,33 @@ AndThen, Assignment, Call, + Component, ContextItem, - Declaration, DynamicPredicate, Equal, ExpressionFunctionDeclaration, First, FunctionSpecification, + InOutParameter, Last, NamedAggregate, NotEqual, NullStatement, Number, - ObjectDeclaration, OrElse, + OutParameter, + Parameter, Postcondition, - Pragma, - PragmaStatement, ProcedureSpecification, + RecordType, + Slice, SparkMode, - Statement, - String, SubprogramBody, SubprogramDeclaration, Subtype, UnitPart, UnrestrictedAccess, UseTypeClause, - ValueRange, Variable, WithClause, ) @@ -67,7 +66,7 @@ def __init__(self, session: Session, integration: Integration, prefix: str = "") self._declaration_context: List[ContextItem] = [] self._body_context: List[ContextItem] = [] self._allocation_slots: Dict[Location, int] = {} - self._unit_part = UnitPart(specification=[Pragma("Elaborate_Body")]) + self._unit_part = UnitPart() self._integration = integration global_slots: List[SlotInfo] = self._allocate_global_slots() local_slots: List[SlotInfo] = self._allocate_local_slots() @@ -100,43 +99,66 @@ def body_context(self) -> List[ContextItem]: def unit_part(self) -> UnitPart: return self._unit_part - def _slot_name(self, slot_id: int, qualified: bool = False) -> ID: - base = f"Slot_Ptr_{slot_id}" - return ID(self.unit_identifier * base) if qualified else ID(base) + @property + def required(self) -> bool: + return any( + True + for d in self._session.declarations.values() + if isinstance(d, decl.VariableDeclaration) + and isinstance(d.type_, (rty.Message, rty.Sequence)) + ) - def get_slot_ptr(self, location: Optional[Location]) -> Variable: + def get_slot_ptr(self, location: Optional[Location]) -> ID: assert location is not None slot_id: int = self._allocation_slots[location] - return Variable(self._slot_name(slot_id, qualified=True)) - - def free_buffer(self, identifier: ID, location: Optional[Location]) -> Sequence[Statement]: - assert location is not None - slot_id = self._allocation_slots[location] - return [ - PragmaStatement("Warnings", [Variable("Off"), String("unused assignment")]), - Assignment( - self._slot_name(slot_id, qualified=True), - Variable(identifier), - ), - PragmaStatement("Warnings", [Variable("On"), String("unused assignment")]), - ] + return self._slot_name(slot_id) def get_size(self, variable: rid.ID, state: Optional[rid.ID] = None) -> int: return self._integration.get_size(self._session.identifier, variable, state) + @staticmethod + def _slot_name(slot_id: int) -> ID: + return ID(f"Slot_Ptr_{slot_id}") + @staticmethod def _ptr_type(size: int) -> ID: return ID(f"Slot_Ptr_Type_{size}") - def _create(self, slots: List[NumberedSlotInfo]) -> None: + def _create(self, slots: Sequence[NumberedSlotInfo]) -> None: + self._unit_part += self._create_memory(slots) if slots: self._unit_part += self._create_ptr_subtypes(slots) - self._unit_part += self._create_slots(slots) + self._unit_part += self._create_slots(slots) self._unit_part += self._create_init_pred(slots) + self._unit_part += self._create_uninitialized_pred(slots) self._unit_part += self._create_init_proc(slots) + self._unit_part += self._create_finalize_proc(slots) self._unit_part += self._create_global_allocated_pred(slots) - def _create_ptr_subtypes(self, slots: List[NumberedSlotInfo]) -> UnitPart: + @staticmethod + def _create_memory(slots: Sequence[NumberedSlotInfo]) -> UnitPart: + return UnitPart( + [ + RecordType( + "Memory", + [ + Component( + f"Slot_{slot.slot_id}", + Slice( + Variable(const.TYPES_BYTES), + First(const.TYPES_INDEX), + Add(First(const.TYPES_INDEX), Number(slot.size - 1)), + ), + NamedAggregate(("others", Number(0))), + aliased=True, + ) + for slot in slots + ], + ) + ] + ) + + def _create_ptr_subtypes(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: unit = UnitPart( specification=[ Subtype( @@ -165,45 +187,30 @@ def _create_ptr_subtypes(self, slots: List[NumberedSlotInfo]) -> UnitPart: self._declaration_context.append(UseTypeClause(self._prefix * const.TYPES_BYTES_PTR)) return unit - def _create_slots(self, slots: List[NumberedSlotInfo]) -> UnitPart: - array_decls: List[Declaration] = [ - ObjectDeclaration( - [ID(f"Slot_{slot.slot_id}")], - const.TYPES_BYTES, - aliased=True, - expression=NamedAggregate( - ( - ValueRange( - First(const.TYPES_INDEX), - Add(First(const.TYPES_INDEX), Number(slot.size - 1)), - ), - First(const.TYPES_BYTE), - ) - ), - ) - for slot in slots - ] - - pointer_decls: List[Declaration] = [ - ObjectDeclaration( - [self._slot_name(slot.slot_id)], - self._ptr_type(slot.size), - ) - for slot in slots - ] + def _create_slots(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: self._declaration_context.append(WithClause(self._prefix * const.TYPES_PACKAGE)) - unit = UnitPart(specification=pointer_decls, body=array_decls) - return unit - def _create_init_pred(self, slots: List[NumberedSlotInfo]) -> UnitPart: + return UnitPart( + [ + RecordType( + "Slots", + [ + Component(self._slot_name(slot.slot_id), self._ptr_type(slot.size)) + for slot in slots + ], + ) + ] + ) + + def _create_init_pred(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: return UnitPart( [ ExpressionFunctionDeclaration( - FunctionSpecification("Initialized", "Boolean"), + FunctionSpecification("Initialized", "Boolean", [Parameter(["S"], "Slots")]), And( *[ NotEqual( - Variable(self._slot_name(slot.slot_id)), + Variable("S" * self._slot_name(slot.slot_id)), Variable("null"), ) for slot in slots @@ -213,15 +220,35 @@ def _create_init_pred(self, slots: List[NumberedSlotInfo]) -> UnitPart: ] ) - def _create_global_allocated_pred(self, slots: List[NumberedSlotInfo]) -> UnitPart: + def _create_uninitialized_pred(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: return UnitPart( [ ExpressionFunctionDeclaration( - FunctionSpecification("Global_Allocated", "Boolean"), + FunctionSpecification("Uninitialized", "Boolean", [Parameter(["S"], "Slots")]), And( *[ Equal( - Variable(self._slot_name(slot.slot_id)), + Variable("S" * self._slot_name(slot.slot_id)), + Variable("null"), + ) + for slot in slots + ] + ), + ) + ] + ) + + def _create_global_allocated_pred(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: + return UnitPart( + [ + ExpressionFunctionDeclaration( + FunctionSpecification( + "Global_Allocated", "Boolean", [Parameter(["S"], "Slots")] + ), + And( + *[ + Equal( + Variable("S" * self._slot_name(slot.slot_id)), Variable("null"), ) for slot in slots @@ -229,7 +256,7 @@ def _create_global_allocated_pred(self, slots: List[NumberedSlotInfo]) -> UnitPa ], *[ NotEqual( - Variable(self._slot_name(slot.slot_id)), + Variable("S" * self._slot_name(slot.slot_id)), Variable("null"), ) for slot in slots @@ -240,24 +267,58 @@ def _create_global_allocated_pred(self, slots: List[NumberedSlotInfo]) -> UnitPa ] ) - def _create_init_proc(self, slots: List[NumberedSlotInfo]) -> UnitPart: - assignments: List[Statement] = ( + def _create_init_proc(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: + proc = ProcedureSpecification( + "Initialize", [OutParameter(["S"], "Slots"), Parameter(["M"], "Memory")] + ) + return UnitPart( [ - Assignment( - self._slot_name(slot.slot_id), - UnrestrictedAccess(Variable(ID(f"Slot_{slot.slot_id}"))), + SubprogramDeclaration(proc, [Postcondition(Call("Initialized", [Variable("S")]))]), + ], + [ + SubprogramBody( + proc, + declarations=[], + statements=( + [ + Assignment( + "S" * self._slot_name(slot.slot_id), + UnrestrictedAccess(Variable(ID(f"M.Slot_{slot.slot_id}"))), + ) + for slot in slots + ] + if slots + else [NullStatement()] + ), + aspects=[SparkMode(off=True)], ) - for slot in slots - ] - if slots - else [NullStatement()] + ], ) - proc = ProcedureSpecification(ID("Initialize")) + + def _create_finalize_proc(self, slots: Sequence[NumberedSlotInfo]) -> UnitPart: + proc = ProcedureSpecification("Finalize", [InOutParameter(["S"], "Slots")]) return UnitPart( - [SubprogramDeclaration(proc, [Postcondition(Call("Initialized"))])], + [ + SubprogramDeclaration( + proc, [Postcondition(Call("Uninitialized", [Variable("S")]))] + ), + ], [ SubprogramBody( - proc, declarations=[], statements=assignments, aspects=[SparkMode(off=True)] + proc, + declarations=[], + statements=( + [ + Assignment( + "S" * self._slot_name(slot.slot_id), + Variable("null"), + ) + for slot in slots + ] + if slots + else [NullStatement()] + ), + aspects=[SparkMode(off=True)], ) ], ) diff --git a/rflx/generator/generator.py b/rflx/generator/generator.py index 068e756207..62f903384e 100644 --- a/rflx/generator/generator.py +++ b/rflx/generator/generator.py @@ -52,7 +52,6 @@ IfStatement, In, Indexed, - InitialCondition, InOutParameter, InstantiationUnit, Last, @@ -248,12 +247,13 @@ def __generate(self, model: Model, integration: Integration) -> None: def __create_session(self, session: Session, integration: Integration) -> None: allocator_generator = AllocatorGenerator(session, integration, self.__prefix) - unit = self.__create_unit( - allocator_generator.unit_identifier, - allocator_generator.declaration_context, - allocator_generator.body_context, - ) - unit += allocator_generator.unit_part + if allocator_generator.required: + unit = self.__create_unit( + allocator_generator.unit_identifier, + allocator_generator.declaration_context, + allocator_generator.body_context, + ) + unit += allocator_generator.unit_part session_generator = SessionGenerator( session, allocator_generator, self.__prefix, debug=self.__debug ) @@ -261,8 +261,7 @@ def __create_session(self, session: Session, integration: Integration) -> None: session_generator.unit_identifier, session_generator.declaration_context, session_generator.body_context, - session_generator.formal_parameters, - [InitialCondition(Variable("Uninitialized"))], + configuration_pragmas=[Pragma("Restrictions", [Variable("No_Streams")])], terminating=False, ) unit += session_generator.unit_part @@ -273,15 +272,17 @@ def __create_unit( # pylint: disable = too-many-arguments declaration_context: ty.Sequence[ContextItem] = None, body_context: ty.Sequence[ContextItem] = None, formal_parameters: ty.List[FormalDeclaration] = None, + configuration_pragmas: ty.Sequence[Pragma] = None, aspects: ty.Sequence[Aspect] = None, terminating: bool = True, ) -> PackageUnit: declaration_context = declaration_context if declaration_context else [] body_context = body_context if body_context else [] aspects = aspects if aspects else [] + configuration_pragmas = configuration_pragmas if configuration_pragmas else [] unit = PackageUnit( - [*const.CONFIGURATION_PRAGMAS, *declaration_context], + [*configuration_pragmas, *const.CONFIGURATION_PRAGMAS, *declaration_context], PackageDeclaration( self.__prefix * identifier, formal_parameters=formal_parameters, @@ -291,7 +292,7 @@ def __create_unit( # pylint: disable = too-many-arguments *aspects, ], ), - [*const.CONFIGURATION_PRAGMAS, *body_context], + [*configuration_pragmas, *const.CONFIGURATION_PRAGMAS, *body_context], PackageBody(self.__prefix * identifier, aspects=[SparkMode()]), ) self._units[identifier] = unit diff --git a/rflx/generator/session.py b/rflx/generator/session.py index 101073504d..35e17fd44e 100644 --- a/rflx/generator/session.py +++ b/rflx/generator/session.py @@ -33,6 +33,10 @@ Case, CaseStatement, ChoiceList, + ClassPostcondition, + ClassPrecondition, + Component, + Constrained, ContextItem, Declaration, Declare, @@ -42,8 +46,6 @@ Expr, ExpressionFunctionDeclaration, First, - FormalDeclaration, - FormalSubprogramDeclaration, FunctionSpecification, GenericProcedureInstantiation, Greater, @@ -51,6 +53,7 @@ IfStatement, In, Indexed, + InOutParameter, Last, Length, Less, @@ -72,9 +75,11 @@ Pragma, PragmaStatement, Precondition, + PrivateType, ProcedureSpecification, Raise, RaiseStatement, + RecordType, ReturnStatement, Selected, Size, @@ -148,7 +153,7 @@ def execute(self) -> Sequence[Statement]: ), f'missing exception transition for state "{self.state.identifier}"' return [ Assignment( - "P_Next_State", + "Ctx.P.Next_State", Variable(f"S_{self.state.exception_transition.target}"), ), *self.finalization, @@ -210,7 +215,6 @@ def __init__( self._session_context = SessionContext() self._declaration_context: List[ContextItem] = [] self._body_context: List[ContextItem] = [] - self._formal_parameters: List[FormalDeclaration] = [] self._unit_part = UnitPart() self._create() @@ -227,10 +231,6 @@ def declaration_context(self) -> List[ContextItem]: def body_context(self) -> List[ContextItem]: return self._body_context - @property - def formal_parameters(self) -> List[FormalDeclaration]: - return self._formal_parameters - @property def unit_part(self) -> UnitPart: return self._unit_part @@ -248,127 +248,14 @@ def _model_type(self, identifier: rid.ID) -> model.Type: def _create(self) -> None: self._unit_part = self._create_state_machine() - self._formal_parameters = self._create_formal_parameters(self._session.parameters.values()) self._declaration_context, self._body_context = self._create_context() - def _create_formal_parameters( - self, - parameters: Iterable[decl.FormalDeclaration], - ) -> List[FormalDeclaration]: - result: List[FormalDeclaration] = [] - - for parameter in parameters: - if isinstance(parameter, decl.ChannelDeclaration): - pass - elif isinstance(parameter, decl.FunctionDeclaration): - result.extend(self._create_function_parameters(parameter)) - elif isinstance(parameter, decl.TypeDeclaration): - fail( - f'type declaration "{parameter.identifier}" not yet supported', - Subsystem.GENERATOR, - location=parameter.location, - ) - else: - fatal_fail( - f'unexpected formal parameter "{parameter.identifier}"', - Subsystem.GENERATOR, - location=parameter.location, - ) - - return result - - def _create_function_parameters( - self, function: decl.FunctionDeclaration - ) -> List[FormalDeclaration]: - procedure_parameters: List[Parameter] = [] - - if function.type_ == rty.Undefined(): - fatal_fail( - f'return type of function "{function.identifier}" is undefined', - Subsystem.GENERATOR, - location=function.location, - ) - if function.type_ == rty.OPAQUE: - fatal_fail( - f'Opaque as return type of function "{function.identifier}" not allowed', - Subsystem.GENERATOR, - location=function.location, - ) - if isinstance(function.type_, rty.Sequence): - fail( - f'sequence as return type of function "{function.identifier}" not yet supported', - Subsystem.GENERATOR, - location=function.location, - ) - if isinstance(function.type_, rty.Message): - if not function.type_.is_definite: - fatal_fail( - "non-definite message" - f' in return type of function "{function.identifier}" not allowed', - Subsystem.GENERATOR, - location=function.location, - ) - if any( - isinstance(field_type, rty.Sequence) and not field_type == rty.OPAQUE - for field_type in function.type_.types.values() - ): - fail( - "message containing sequence fields" - f' in return type of function "{function.identifier}" not yet supported', - Subsystem.GENERATOR, - location=function.location, - ) - - procedure_parameters.append( - OutParameter( - [ID(function.identifier)], - ID(self._prefix * function.return_type * "Structure") - if isinstance(function.type_, rty.Message) - else ID("Boolean") - if function.type_ == rty.BOOLEAN - else ID(self._prefix * function.return_type), - ) - ) - - self._session_context.referenced_types.append(function.return_type) - - for a in function.arguments: - if isinstance(a.type_, rty.Sequence) and not a.type_ == rty.OPAQUE: - fail( - f'sequence as parameter of function "{function.identifier}" not yet supported', - Subsystem.GENERATOR, - location=function.location, - ) - procedure_parameters.append( - Parameter( - [ID(a.identifier)], - ID(const.TYPES_BYTES) - if a.type_ == rty.OPAQUE - else ID("Boolean") - if a.type_ == rty.BOOLEAN - else ID(self._prefix * a.type_identifier * "Structure") - if isinstance(a.type_, rty.Message) - else ID(self._prefix * a.type_identifier), - ) - ) - - assert isinstance(a.type_, (rty.Integer, rty.Enumeration, rty.Message, rty.Sequence)) - - self._session_context.referenced_types.append(a.type_.identifier) - - return [ - FormalSubprogramDeclaration( - ProcedureSpecification( - ID(function.identifier), - procedure_parameters, - ) - ) - ] - def _create_context(self) -> Tuple[List[ContextItem], List[ContextItem]]: declaration_context: List[ContextItem] = [] - declaration_context.append(WithClause(self._prefix * self._allocator.unit_identifier)) + if self._allocator.required: + declaration_context.append(WithClause(self._prefix * self._allocator.unit_identifier)) + if self._session_context.used_types or self._session_context.used_types_body: declaration_context.append(WithClause(self._prefix * const.TYPES_PACKAGE)) @@ -438,15 +325,35 @@ def _create_state_machine(self) -> UnitPart: self._session.declarations.values(), session_global=True, ) - - evaluated_declarations.initialization.insert( - 0, CallStatement(ID(self._allocator.unit_identifier * "Initialize")) + assert all( + isinstance(d, ObjectDeclaration) + and len(d.identifiers) == 1 + and isinstance(d.type_identifier, Variable) + for d in evaluated_declarations.global_declarations ) + global_variables = { + d.identifiers[0]: (d.type_identifier.identifier, d.expression) + for d in evaluated_declarations.global_declarations + if isinstance(d, ObjectDeclaration) + and len(d.identifiers) == 1 + and isinstance(d.type_identifier, Variable) + } + + def is_global(identifier: ID) -> bool: + return identifier in global_variables + + composite_globals = [ + d + for d in self._session.declarations.values() + if isinstance(d, decl.VariableDeclaration) + and isinstance(d.type_, (rty.Message, rty.Sequence)) + ] unit = UnitPart() - unit += self._create_uninitialized_function(self._session.declarations.values()) - unit += self._create_states(self._session) - unit += self._create_initialized_function(self._session) + unit += self._create_abstract_functions(self._session.parameters.values()) + unit += self._create_uninitialized_function(composite_globals, is_global) + unit += self._create_initialized_function(composite_globals, is_global) + unit += self._create_states(self._session, is_global) unit += self._create_active_function(self._session) unit += self._create_initialize_procedure( self._session, @@ -465,24 +372,26 @@ def _create_state_machine(self) -> UnitPart: has_writes = bool([write for writes in channel_writes.values() for write in writes]) if has_reads: - unit += self._create_reset_messages_before_write_procedure(self._session) + unit += self._create_reset_messages_before_write_procedure(self._session, is_global) unit += self._create_tick_procedure(self._session, has_reads) unit += self._create_run_procedure(self._session) unit += self._create_state_function() if has_writes: - unit += self._create_has_data_function(channel_writes) - unit += self._create_read_buffer_size_function(channel_writes) - unit += self._create_read_procedure(channel_writes) + unit += self._create_has_data_function(channel_writes, is_global) + unit += self._create_read_buffer_size_function(channel_writes, is_global) + unit += self._create_read_procedure(channel_writes, is_global) if has_reads: unit += self._create_needs_data_function(channel_reads) unit += self._create_write_buffer_size_function(channel_reads) - unit += self._create_write_procedure(channel_reads) + unit += self._create_write_procedure(channel_reads, is_global) return ( - self._create_declarations(self._session, evaluated_declarations.global_declarations) + self._create_use_clauses(self._session_context.used_types) + + self._create_channel_and_state_types(self._session) + + self._create_context_type(self._session.initial, global_variables) + unit ) @@ -515,19 +424,22 @@ def _channel_io( return channels - def _create_declarations( - self, session: model.Session, declarations: Sequence[Declaration] - ) -> UnitPart: + def _create_use_clauses(self, used_types: Sequence[rid.ID]) -> UnitPart: + return UnitPart( + [ + UseTypeClause(self._prefix * ID(t)) + for t in used_types + if not model.is_builtin_type(t) and not model.is_internal_type(t) + ], + ) + + @staticmethod + def _create_channel_and_state_types(session: model.Session) -> UnitPart: channel_params = [ x for x in session.parameters.values() if isinstance(x, decl.ChannelDeclaration) ] return UnitPart( [ - *[ - UseTypeClause(self._prefix * ID(t)) - for t in self._session_context.used_types - if not model.is_builtin_type(t) and not model.is_internal_type(t) - ], *( [ EnumerationType( @@ -540,15 +452,185 @@ def _create_declarations( ), EnumerationType("State", {ID(f"S_{s.identifier}"): None for s in session.states}), ], + ) + + def _create_context_type( + self, initial_state: rid.ID, global_variables: Mapping[ID, Tuple[ID, Optional[Expr]]] + ) -> UnitPart: + return UnitPart( + [ + PrivateType("Private_Context"), + RecordType( + "Context", + [ + Component("P", "Private_Context"), + ], + abstract=True, + tagged=True, + ), + ], private=[ - ObjectDeclaration(["P_Next_State"], "State", Variable(f"S_{session.initial}")), - *declarations, + RecordType( + "Private_Context", + [ + Component("Next_State", "State", Variable(f"S_{initial_state}")), + *[ + Component(identifier, type_identifier, expression) + for identifier, ( + type_identifier, + expression, + ) in global_variables.items() + ], + *( + [ + Component("Slots", self._allocator.unit_identifier * "Slots"), + Component("Memory", self._allocator.unit_identifier * "Memory"), + ] + if global_variables + else [] + ), + ], + ), ], ) - @staticmethod - def _create_uninitialized_function(declarations: Iterable[decl.BasicDeclaration]) -> UnitPart: - specification = FunctionSpecification("Uninitialized", "Boolean") + def _create_abstract_functions( + self, + parameters: Iterable[decl.FormalDeclaration], + ) -> UnitPart: + result: List[Declaration] = [] + + for parameter in parameters: + if isinstance(parameter, decl.ChannelDeclaration): + pass + elif isinstance(parameter, decl.FunctionDeclaration): + result.extend(self._create_abstract_function(parameter)) + elif isinstance(parameter, decl.TypeDeclaration): + fail( + f'type declaration "{parameter.identifier}" not yet supported', + Subsystem.GENERATOR, + location=parameter.location, + ) + else: + fatal_fail( + f'unexpected formal parameter "{parameter.identifier}"', + Subsystem.GENERATOR, + location=parameter.location, + ) + + return UnitPart(result) + + def _create_abstract_function( + self, function: decl.FunctionDeclaration + ) -> List[SubprogramDeclaration]: + procedure_parameters: List[Parameter] = [InOutParameter(["Ctx"], "Context")] + + if function.type_ == rty.Undefined(): + fatal_fail( + f'return type of function "{function.identifier}" is undefined', + Subsystem.GENERATOR, + location=function.location, + ) + if function.type_ == rty.OPAQUE: + fatal_fail( + f'Opaque as return type of function "{function.identifier}" not allowed', + Subsystem.GENERATOR, + location=function.location, + ) + if isinstance(function.type_, rty.Sequence): + fail( + f'sequence as return type of function "{function.identifier}" not yet supported', + Subsystem.GENERATOR, + location=function.location, + ) + if isinstance(function.type_, rty.Message): + if not function.type_.is_definite: + fatal_fail( + "non-definite message" + f' in return type of function "{function.identifier}" not allowed', + Subsystem.GENERATOR, + location=function.location, + ) + if any( + isinstance(field_type, rty.Sequence) and not field_type == rty.OPAQUE + for field_type in function.type_.types.values() + ): + fail( + "message containing sequence fields" + f' in return type of function "{function.identifier}" not yet supported', + Subsystem.GENERATOR, + location=function.location, + ) + + self._session_context.referenced_types.append(function.return_type) + + for a in function.arguments: + if isinstance(a.type_, rty.Sequence) and not a.type_ == rty.OPAQUE: + fail( + f'sequence as parameter of function "{function.identifier}" not yet supported', + Subsystem.GENERATOR, + location=function.location, + ) + procedure_parameters.append( + Parameter( + [ID(a.identifier)], + ID(const.TYPES_BYTES) + if a.type_ == rty.OPAQUE + else ID("Boolean") + if a.type_ == rty.BOOLEAN + else ID(self._prefix * a.type_identifier * "Structure") + if isinstance(a.type_, rty.Message) + else ID(self._prefix * a.type_identifier), + ) + ) + + assert isinstance(a.type_, (rty.Integer, rty.Enumeration, rty.Message, rty.Sequence)) + + self._session_context.referenced_types.append(a.type_.identifier) + + procedure_parameters.append( + OutParameter( + [ID("RFLX_Result")], + ID(self._prefix * function.return_type * "Structure") + if isinstance(function.type_, rty.Message) + else ID("Boolean") + if function.type_ == rty.BOOLEAN + else ID(self._prefix * function.return_type), + ) + ) + + return [ + SubprogramDeclaration( + ProcedureSpecification( + ID(function.identifier), + procedure_parameters, + ), + [ + ClassPrecondition( + And( + Call("Initialized", [Variable("Ctx")]), + *( + [Not(Constrained("RFLX_Result"))] + if isinstance(function.type_, rty.Enumeration) + and function.type_.always_valid + else [] + ), + ) + ), + ClassPostcondition(Call("Initialized", [Variable("Ctx")])), + ], + abstract=True, + ) + ] + + def _create_uninitialized_function( + self, composite_globals: Sequence[decl.VariableDeclaration], is_global: Callable[[ID], bool] + ) -> UnitPart: + specification = FunctionSpecification( + "Uninitialized", + "Boolean", + [Parameter(["Ctx" if composite_globals else "Unused_Ctx"], "Context'Class")], + ) return UnitPart( [ SubprogramDeclaration(specification), @@ -561,24 +643,89 @@ def _create_uninitialized_function(declarations: Iterable[decl.BasicDeclaration] Not( Call( ID(declaration.type_.identifier * "Has_Buffer"), - [Variable(context_id(declaration.identifier))], + [Variable(context_id(declaration.identifier, is_global))], ) ) - for declaration in declarations - if isinstance(declaration, decl.VariableDeclaration) - and isinstance(declaration.type_, (rty.Message, rty.Sequence)) - ] + for declaration in composite_globals + if isinstance(declaration.type_, (rty.Message, rty.Sequence)) + ], + *( + [ + Call( + ID(self._allocator.unit_identifier * "Uninitialized"), + [Variable("Ctx.P.Slots")], + ), + ] + if composite_globals + else [] + ), ), ), ], ) - def _create_states(self, session: model.Session) -> UnitPart: + def _create_initialized_function( + self, composite_globals: Sequence[decl.VariableDeclaration], is_global: Callable[[ID], bool] + ) -> UnitPart: + specification = FunctionSpecification( + "Initialized", + "Boolean", + [Parameter(["Ctx" if composite_globals else "Unused_Ctx"], "Context'Class")], + ) + if composite_globals: + self._session_context.used_types.append(const.TYPES_INDEX) + return UnitPart( + [ + SubprogramDeclaration(specification), + ], + private=[ + ExpressionFunctionDeclaration( + specification, + AndThen( + *[ + e + for d in composite_globals + for e in [ + Call( + ID(d.type_identifier) * "Has_Buffer", + [Variable(context_id(d.identifier, is_global))], + ), + Equal( + Variable(context_id(d.identifier, is_global) * "Buffer_First"), + First(const.TYPES_INDEX), + ), + Equal( + Variable(context_id(d.identifier, is_global) * "Buffer_Last"), + Add( + First(const.TYPES_INDEX), + Number(self._allocator.get_size(d.identifier) - 1), + ), + ), + ] + ], + *( + [ + Call( + ID(self._allocator.unit_identifier * "Global_Allocated"), + [Variable("Ctx.P.Slots")], + ), + ] + if composite_globals + else [] + ), + ), + ), + ], + ) + + def _create_states(self, session: model.Session, is_global: Callable[[ID], bool]) -> UnitPart: unit_body: List[Declaration] = [] for state in session.states: if not state.is_null: - evaluated_declarations = self._evaluate_declarations(state.declarations.values()) + evaluated_declarations = self._evaluate_declarations( + state.declarations.values(), is_global + ) actions = [ s for a in state.actions @@ -590,6 +737,7 @@ def _create_states(self, session: model.Session) -> UnitPart: state, evaluated_declarations.finalization, ), + is_global, ) ] if state.identifier in self._session_context.state_exception: @@ -600,7 +748,10 @@ def _create_states(self, session: model.Session) -> UnitPart: unit_body += [ SubprogramBody( ProcedureSpecification( - ID(state.identifier), [OutParameter(["P_Next_State"], "State")] + ID(state.identifier), + [ + InOutParameter(["Ctx"], "Context'Class"), + ], ), [ *evaluated_declarations.global_declarations, @@ -615,11 +766,12 @@ def _create_states(self, session: model.Session) -> UnitPart: [ ( t.condition.substituted( - self._substitution() + self._substitution(is_global) ).ada_expr(), [ Assignment( - "P_Next_State", Variable(f"S_{t.target}") + "Ctx.P.Next_State", + Variable(f"S_{t.target}"), ) ], ) @@ -627,7 +779,7 @@ def _create_states(self, session: model.Session) -> UnitPart: ], [ Assignment( - "P_Next_State", + "Ctx.P.Next_State", Variable(f"S_{state.transitions[-1].target}"), ) ], @@ -639,62 +791,21 @@ def _create_states(self, session: model.Session) -> UnitPart: *evaluated_declarations.finalization, ], aspects=[ - Precondition(Call("Initialized")), - Postcondition(Call("Initialized")), + Precondition(Call("Initialized", [Variable("Ctx")])), + Postcondition(Call("Initialized", [Variable("Ctx")])), ], ) ] return UnitPart(body=unit_body) - def _create_initialized_function(self, session: model.Session) -> UnitPart: - specification = FunctionSpecification("Initialized", "Boolean") - context_declarations = [ - d - for d in session.declarations.values() - if isinstance(d, decl.VariableDeclaration) - and isinstance(d.type_, (rty.Message, rty.Sequence)) - ] - if context_declarations: - self._session_context.used_types.append(const.TYPES_INDEX) - return UnitPart( - [ - SubprogramDeclaration(specification), - ], - private=[ - ExpressionFunctionDeclaration( - specification, - AndThen( - *[ - e - for d in context_declarations - for e in [ - Call( - ID(d.type_identifier) * "Has_Buffer", - [Variable(context_id(d.identifier))], - ), - Equal( - Variable(context_id(d.identifier) * "Buffer_First"), - First(const.TYPES_INDEX), - ), - Equal( - Variable(context_id(d.identifier) * "Buffer_Last"), - Add( - First(const.TYPES_INDEX), - Number(self._allocator.get_size(d.identifier) - 1), - ), - ), - ] - ], - Call(ID(self._allocator.unit_identifier * "Global_Allocated")), - ), - ), - ], - ) - @staticmethod def _create_active_function(session: model.Session) -> UnitPart: - specification = FunctionSpecification("Active", "Boolean") + specification = FunctionSpecification( + "Active", + "Boolean", + [Parameter(["Ctx" if len(session.states) > 1 else "Unused_Ctx"], "Context'Class")], + ) return UnitPart( [ SubprogramDeclaration(specification), @@ -702,7 +813,9 @@ def _create_active_function(session: model.Session) -> UnitPart: private=[ ExpressionFunctionDeclaration( specification, - NotEqual(Variable("P_Next_State"), Variable(f"S_{session.final}")), + NotEqual(Variable("Ctx.P.Next_State"), Variable(f"S_{session.final}")) + if len(session.states) > 1 + else Variable("False"), ), ], ) @@ -713,14 +826,21 @@ def _create_initialize_procedure( declarations: Sequence[Declaration], initialization: Sequence[Statement], ) -> UnitPart: - specification = ProcedureSpecification("Initialize") + specification = ProcedureSpecification( + "Initialize", [InOutParameter(["Ctx"], "Context'Class")] + ) return UnitPart( [ SubprogramDeclaration( specification, [ - Precondition(Call("Uninitialized")), - Postcondition(And(Call("Initialized"), Call("Active"))), + Precondition(Call("Uninitialized", [Variable("Ctx")])), + Postcondition( + And( + Call("Initialized", [Variable("Ctx")]), + Call("Active", [Variable("Ctx")]), + ) + ), ], ), ], @@ -730,7 +850,7 @@ def _create_initialize_procedure( declarations, [ *initialization, - Assignment("P_Next_State", Variable(f"S_{session.initial}")), + Assignment("Ctx.P.Next_State", Variable(f"S_{session.initial}")), ], ), ], @@ -742,14 +862,21 @@ def _create_finalize_procedure( declarations: Sequence[Declaration], finalization: Sequence[Statement], ) -> UnitPart: - specification = ProcedureSpecification("Finalize") + specification = ProcedureSpecification( + "Finalize", [InOutParameter(["Ctx"], "Context'Class")] + ) return UnitPart( [ SubprogramDeclaration( specification, [ - Precondition(Call("Initialized")), - Postcondition(And(Call("Uninitialized"), Not(Call("Active")))), + Precondition(Call("Initialized", [Variable("Ctx")])), + Postcondition( + And( + Call("Uninitialized", [Variable("Ctx")]), + Not(Call("Active", [Variable("Ctx")])), + ) + ), ], ), ], @@ -759,7 +886,7 @@ def _create_finalize_procedure( declarations, [ *finalization, - Assignment("P_Next_State", Variable(f"S_{session.final}")), + Assignment("Ctx.P.Next_State", Variable(f"S_{session.final}")), ], ), ], @@ -768,10 +895,13 @@ def _create_finalize_procedure( def _create_reset_messages_before_write_procedure( self, session: model.Session, + is_global: Callable[[ID], bool], ) -> UnitPart: self._session_context.used_types_body.append(const.TYPES_BIT_LENGTH) - specification = ProcedureSpecification("Reset_Messages_Before_Write") + specification = ProcedureSpecification( + "Reset_Messages_Before_Write", [InOutParameter(["Ctx"], "Context'Class")] + ) states = [ ( state, @@ -798,7 +928,7 @@ def _create_reset_messages_before_write_procedure( [], [ CaseStatement( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ ( Variable(f"S_{state.identifier}"), @@ -806,14 +936,16 @@ def _create_reset_messages_before_write_procedure( CallStatement( ID(message_type.identifier) * "Reset", [ - Variable(context_id(message)), - Variable(context_id(message) * "First"), + Variable(context_id(message, is_global)), + Variable(context_id(message, is_global) * "First"), Sub( - Variable(context_id(message) * "First"), + Variable( + context_id(message, is_global) * "First" + ), Number(1), ), *[ - Variable(context_id(message) * p) + Variable(context_id(message, is_global) * p) for p in message_type.parameter_types ], ], @@ -828,21 +960,24 @@ def _create_reset_messages_before_write_procedure( ), ], aspects=[ - Precondition(Call("Initialized")), - Postcondition(Call("Initialized")), + Precondition(Call("Initialized", [Variable("Ctx")])), + Postcondition(Call("Initialized", [Variable("Ctx")])), ], ) ], ) def _create_tick_procedure(self, session: model.Session, has_writes: bool) -> UnitPart: - specification = ProcedureSpecification("Tick") + specification = ProcedureSpecification("Tick", [InOutParameter(["Ctx"], "Context'Class")]) return UnitPart( [ Pragma("Warnings", [Variable("Off"), String('subprogram "Tick" has no effect')]), SubprogramDeclaration( specification, - [Precondition(Variable("Initialized")), Postcondition(Variable("Initialized"))], + [ + Precondition(Call("Initialized", [Variable("Ctx")])), + Postcondition(Call("Initialized", [Variable("Ctx")])), + ], ), Pragma("Warnings", [Variable("On"), String('subprogram "Tick" has no effect')]), ], @@ -852,13 +987,13 @@ def _create_tick_procedure(self, session: model.Session, has_writes: bool) -> Un [], [ CaseStatement( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ ( Variable(f"S_{s.identifier}"), [ *self._debug_output(f"State: {s.identifier}"), - CallStatement(ID(s.identifier), [Variable("P_Next_State")]) + CallStatement(ID(s.identifier), [Variable("Ctx")]) if s.identifier != session.final else NullStatement(), ], @@ -866,7 +1001,11 @@ def _create_tick_procedure(self, session: model.Session, has_writes: bool) -> Un for s in session.states ], ), - *([CallStatement("Reset_Messages_Before_Write")] if has_writes else []), + *( + [CallStatement("Reset_Messages_Before_Write", [Variable("Ctx")])] + if has_writes + else [] + ), ], ) ], @@ -887,24 +1026,28 @@ def _create_run_procedure(session: model.Session) -> UnitPart: ) ) ] - specification = ProcedureSpecification("Run") + specification = ProcedureSpecification("Run", [InOutParameter(["Ctx"], "Context'Class")]) return UnitPart( [ Pragma("Warnings", [Variable("Off"), String('subprogram "Run" has no effect')]), SubprogramDeclaration( specification, [ - Precondition(Call("Initialized")), - Postcondition(Call("Initialized")), + Precondition(Call("Initialized", [Variable("Ctx")])), + Postcondition(Call("Initialized", [Variable("Ctx")])), ], ), Pragma("Warnings", [Variable("On"), String('subprogram "Run" has no effect')]), ], [ ExpressionFunctionDeclaration( - FunctionSpecification("In_IO_State", "Boolean"), + FunctionSpecification( + "In_IO_State", + "Boolean", + [Parameter(["Ctx" if io_states else "Unused_Ctx"], "Context'Class")], + ), In( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), ChoiceList(*[Variable(f"S_{state.identifier}") for state in io_states]), ) if io_states @@ -914,12 +1057,17 @@ def _create_run_procedure(session: model.Session) -> UnitPart: specification, [], [ - CallStatement("Tick"), + CallStatement("Tick", [Variable("Ctx")]), While( - And(Call("Active"), Not(Call("In_IO_State"))), + And( + Call("Active", [Variable("Ctx")]), + Not(Call("In_IO_State", [Variable("Ctx")])), + ), [ - PragmaStatement("Loop_Invariant", [Variable("Initialized")]), - CallStatement("Tick"), + PragmaStatement( + "Loop_Invariant", [Call("Initialized", [Variable("Ctx")])] + ), + CallStatement("Tick", [Variable("Ctx")]), ], ), ], @@ -929,7 +1077,9 @@ def _create_run_procedure(session: model.Session) -> UnitPart: @staticmethod def _create_state_function() -> UnitPart: - specification = FunctionSpecification("Next_State", "State") + specification = FunctionSpecification( + "Next_State", "State", [Parameter(["Ctx"], "Context'Class")] + ) return UnitPart( [ SubprogramDeclaration(specification), @@ -937,22 +1087,29 @@ def _create_state_function() -> UnitPart: private=[ ExpressionFunctionDeclaration( specification, - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), ) ], ) @staticmethod - def _create_has_data_function(channel_writes: dict[rid.ID, list[ChannelAccess]]) -> UnitPart: + def _create_has_data_function( + channel_writes: dict[rid.ID, list[ChannelAccess]], + is_global: Callable[[ID], bool], + ) -> UnitPart: specification = FunctionSpecification( - "Has_Data", "Boolean", [Parameter(["Chan"], "Channel")] + "Has_Data", + "Boolean", + [Parameter(["Ctx"], "Context'Class"), Parameter(["Chan"], "Channel")], ) return UnitPart( [ - SubprogramDeclaration(specification, [Precondition(Call("Initialized"))]), + SubprogramDeclaration( + specification, [Precondition(Call("Initialized", [Variable("Ctx")]))] + ), ], - [ + private=[ ExpressionFunctionDeclaration( specification, Case( @@ -961,7 +1118,7 @@ def _create_has_data_function(channel_writes: dict[rid.ID, list[ChannelAccess]]) ( Variable(f"C_{channel}"), Case( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ *[ ( @@ -970,12 +1127,22 @@ def _create_has_data_function(channel_writes: dict[rid.ID, list[ChannelAccess]]) Call( write.message_type * "Structural_Valid_Message", - [Variable(context_id(write.message))], + [ + Variable( + context_id(write.message, is_global) + ) + ], ), Greater( Call( write.message_type * "Byte_Size", - [Variable(context_id(write.message))], + [ + Variable( + context_id( + write.message, is_global + ) + ) + ], ), Number(0), ), @@ -997,14 +1164,18 @@ def _create_has_data_function(channel_writes: dict[rid.ID, list[ChannelAccess]]) @staticmethod def _create_needs_data_function(channel_reads: dict[rid.ID, list[ChannelAccess]]) -> UnitPart: specification = FunctionSpecification( - "Needs_Data", "Boolean", [Parameter(["Chan"], "Channel")] + "Needs_Data", + "Boolean", + [Parameter(["Ctx"], "Context'Class"), Parameter(["Chan"], "Channel")], ) return UnitPart( [ - SubprogramDeclaration(specification, [Precondition(Call("Initialized"))]), + SubprogramDeclaration( + specification, [Precondition(Call("Initialized", [Variable("Ctx")]))] + ), ], - [ + private=[ ExpressionFunctionDeclaration( specification, Case( @@ -1013,7 +1184,7 @@ def _create_needs_data_function(channel_reads: dict[rid.ID, list[ChannelAccess]] ( Variable(f"C_{channel}"), Case( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ *[(Variable(f"S_{read.state}"), TRUE) for read in reads], (Variable("others"), FALSE), @@ -1029,10 +1200,13 @@ def _create_needs_data_function(channel_reads: dict[rid.ID, list[ChannelAccess]] @staticmethod def _create_read_buffer_size_function( - channel_writes: dict[rid.ID, list[ChannelAccess]] + channel_writes: dict[rid.ID, list[ChannelAccess]], + is_global: Callable[[ID], bool], ) -> UnitPart: specification = FunctionSpecification( - "Read_Buffer_Size", const.TYPES_LENGTH, [Parameter(["Chan"], "Channel")] + "Read_Buffer_Size", + const.TYPES_LENGTH, + [Parameter(["Ctx"], "Context'Class"), Parameter(["Chan"], "Channel")], ) return UnitPart( @@ -1041,12 +1215,15 @@ def _create_read_buffer_size_function( specification, [ Precondition( - AndThen(Call("Initialized"), Call("Has_Data", [Variable("Chan")])) + AndThen( + Call("Initialized", [Variable("Ctx")]), + Call("Has_Data", [Variable("Ctx"), Variable("Chan")]), + ) ), ], ), ], - [ + private=[ ExpressionFunctionDeclaration( specification, Case( @@ -1055,14 +1232,18 @@ def _create_read_buffer_size_function( ( Variable(f"C_{channel}"), Case( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ *[ ( Variable(f"S_{write.state}"), Call( write.message_type * "Byte_Size", - [Variable(context_id(write.message))], + [ + Variable( + context_id(write.message, is_global) + ) + ], ), ) for write in writes @@ -1083,19 +1264,24 @@ def _create_write_buffer_size_function( channel_reads: dict[rid.ID, list[ChannelAccess]] ) -> UnitPart: specification = FunctionSpecification( - "Write_Buffer_Size", const.TYPES_LENGTH, [Parameter(["Chan"], "Channel")] + "Write_Buffer_Size", + const.TYPES_LENGTH, + [Parameter(["Unused_Ctx"], "Context'Class"), Parameter(["Chan"], "Channel")], ) return UnitPart( [ SubprogramDeclaration(specification), ], - [ + private=[ ExpressionFunctionDeclaration( specification, Case( Variable("Chan"), [ + # ISSUE: Componolit/RecordFlux#895 + # Size of correspondig buffer must be returned instead of constant + # value. (Variable(f"C_{channel}"), Number(4096) if reads else Number(0)) for channel, reads in channel_reads.items() ], @@ -1104,13 +1290,18 @@ def _create_write_buffer_size_function( ], ) - def _create_read_procedure(self, channel_writes: dict[rid.ID, list[ChannelAccess]]) -> UnitPart: + def _create_read_procedure( + self, + channel_writes: dict[rid.ID, list[ChannelAccess]], + is_global: Callable[[ID], bool], + ) -> UnitPart: self._session_context.used_types.append(const.TYPES_INDEX) self._session_context.used_types.append(const.TYPES_LENGTH) specification = ProcedureSpecification( "Read", [ + Parameter(["Ctx"], "Context'Class"), Parameter(["Chan"], "Channel"), OutParameter(["Buffer"], const.TYPES_BYTES), Parameter(["Offset"], const.TYPES_LENGTH, Number(0)), @@ -1124,8 +1315,8 @@ def _create_read_procedure(self, channel_writes: dict[rid.ID, list[ChannelAccess [ Precondition( AndThen( - Call("Initialized"), - Call("Has_Data", [Variable("Chan")]), + Call("Initialized", [Variable("Ctx")]), + Call("Has_Data", [Variable("Ctx"), Variable("Chan")]), Greater(Length("Buffer"), Number(0)), LessEqual( Variable("Offset"), @@ -1133,12 +1324,12 @@ def _create_read_procedure(self, channel_writes: dict[rid.ID, list[ChannelAccess ), LessEqual( Add(Length("Buffer"), Variable("Offset")), - Call("Read_Buffer_Size", [Variable("Chan")]), + Call("Read_Buffer_Size", [Variable("Ctx"), Variable("Chan")]), ), ) ), Postcondition( - Call("Initialized"), + Call("Initialized", [Variable("Ctx")]), ), ], ), @@ -1250,7 +1441,7 @@ def _create_read_procedure(self, channel_writes: dict[rid.ID, list[ChannelAccess Variable(f"C_{channel}"), [ CaseStatement( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ *[ ( @@ -1260,7 +1451,9 @@ def _create_read_procedure(self, channel_writes: dict[rid.ID, list[ChannelAccess (write.message_type * "Read").flat, [ Variable( - context_id(write.message) + context_id( + write.message, is_global + ) ) ], ), @@ -1286,13 +1479,18 @@ def _create_read_procedure(self, channel_writes: dict[rid.ID, list[ChannelAccess ], ) - def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess]]) -> UnitPart: + def _create_write_procedure( + self, + channel_reads: dict[rid.ID, list[ChannelAccess]], + is_global: Callable[[ID], bool], + ) -> UnitPart: self._session_context.used_types.append(const.TYPES_INDEX) self._session_context.used_types.append(const.TYPES_LENGTH) specification = ProcedureSpecification( "Write", [ + InOutParameter(["Ctx"], "Context'Class"), Parameter(["Chan"], "Channel"), Parameter(["Buffer"], const.TYPES_BYTES), Parameter(["Offset"], const.TYPES_LENGTH, Number(0)), @@ -1306,8 +1504,8 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess [ Precondition( AndThen( - Call("Initialized"), - Call("Needs_Data", [Variable("Chan")]), + Call("Initialized", [Variable("Ctx")]), + Call("Needs_Data", [Variable("Ctx"), Variable("Chan")]), Greater(Length("Buffer"), Number(0)), LessEqual( Variable("Offset"), @@ -1315,12 +1513,12 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess ), LessEqual( Add(Length("Buffer"), Variable("Offset")), - Call("Write_Buffer_Size", [Variable("Chan")]), + Call("Write_Buffer_Size", [Variable("Ctx"), Variable("Chan")]), ), ) ), Postcondition( - Call("Initialized"), + Call("Initialized", [Variable("Ctx")]), ), ], ), @@ -1329,6 +1527,12 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess SubprogramBody( specification, [ + ObjectDeclaration( + ["Write_Buffer_Length"], + const.TYPES_LENGTH, + Call("Write_Buffer_Size", [Variable("Ctx"), Variable("Chan")]), + constant=True, + ), ExpressionFunctionDeclaration( FunctionSpecification( "Write_Pre", @@ -1342,7 +1546,7 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess Greater(Length("Buffer"), Number(0)), Equal( Variable("Context_Buffer_Length"), - Call("Write_Buffer_Size", [Variable("Chan")]), + Variable("Write_Buffer_Length"), ), LessEqual( Variable("Offset"), @@ -1350,7 +1554,7 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess ), LessEqual( Add(Length("Buffer"), Variable("Offset")), - Call("Write_Buffer_Size", [Variable("Chan")]), + Variable("Write_Buffer_Length"), ), ), ), @@ -1411,7 +1615,7 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess ), Equal( Add(Length("Message_Buffer"), Variable("Offset")), - Call("Write_Buffer_Size", [Variable("Chan")]), + Variable("Write_Buffer_Length"), ), ) ), @@ -1443,7 +1647,7 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess Variable(f"C_{channel}"), [ CaseStatement( - Variable("P_Next_State"), + Variable("Ctx.P.Next_State"), [ *[ ( @@ -1453,7 +1657,9 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess (write.message_type * "Write").flat, [ Variable( - context_id(write.message) + context_id( + write.message, is_global + ) ), Variable("Offset"), ], @@ -1483,19 +1689,33 @@ def _create_write_procedure(self, channel_reads: dict[rid.ID, list[ChannelAccess def _evaluate_declarations( self, declarations: Iterable[decl.BasicDeclaration], + is_global: Callable[[ID], bool] = None, session_global: bool = False, ) -> EvaluatedDeclaration: + if session_global: + + def always_true(_: ID) -> bool: + return True + + is_global = always_true + + assert is_global + result = EvaluatedDeclaration() + has_composite_declarations = False for declaration in declarations: if isinstance(declaration, decl.VariableDeclaration): result += self._declare( declaration.identifier, declaration.type_, + is_global, declaration.location, declaration.expression, session_global=session_global, ) + if isinstance(declaration.type_, (rty.Message, rty.Sequence)): + has_composite_declarations |= True elif isinstance(declaration, decl.RenamingDeclaration): fail( f'renaming declaration "{declaration.identifier}" not yet supported', @@ -1509,10 +1729,29 @@ def _evaluate_declarations( location=declaration.location, ) + if session_global and has_composite_declarations: + result.initialization.insert( + 0, + CallStatement( + ID(self._allocator.unit_identifier * "Initialize"), + [Variable("Ctx.P.Slots"), Variable("Ctx.P.Memory")], + ), + ) + result.finalization.append( + CallStatement( + ID(self._allocator.unit_identifier * "Finalize"), + [Variable("Ctx.P.Slots")], + ) + ) + return result def _state_action( - self, state: rid.ID, action: stmt.Statement, exception_handler: ExceptionHandler + self, + state: rid.ID, + action: stmt.Statement, + exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: if isinstance(action, stmt.Assignment): result = self._assign( @@ -1520,12 +1759,13 @@ def _state_action( action.type_, action.expression, exception_handler, + is_global, state, action.location, ) elif isinstance(action, stmt.Append): - result = self._append(action, exception_handler) + result = self._append(action, exception_handler, is_global) elif isinstance(action, stmt.Extend): fail( @@ -1535,10 +1775,10 @@ def _state_action( ) elif isinstance(action, stmt.Reset): - result = self._reset(action) + result = self._reset(action, is_global) elif isinstance(action, stmt.Read): - result = self._read(action) + result = self._read(action, is_global) elif isinstance(action, stmt.Write): result = self._write(action) @@ -1552,10 +1792,11 @@ def _state_action( return [*result, *exception_handler.execute_deferred()] - def _declare( # pylint: disable = too-many-arguments + def _declare( # pylint: disable = too-many-arguments, too-many-branches self, identifier: rid.ID, type_: rty.Type, + is_global: Callable[[ID], bool], alloc_id: Optional[Location], expression: expr.Expr = None, constant: bool = False, @@ -1593,7 +1834,7 @@ def _declare( # pylint: disable = too-many-arguments ObjectDeclaration( [ID(identifier)], object_type, - initialization.substituted(self._substitution()).ada_expr() + initialization.substituted(self._substitution(is_global)).ada_expr() if initialization else None, constant=constant if initialization else False, @@ -1610,6 +1851,13 @@ def _declare( # pylint: disable = too-many-arguments expression.ada_expr() if expression else None, ) ) + if session_global and expression: + result.initialization.append( + Assignment( + variable_id(identifier, is_global), + self._convert_type(expression, type_).ada_expr(), + ), + ) elif isinstance(type_, (rty.Message, rty.Sequence)): if expression is not None: @@ -1622,7 +1870,11 @@ def _declare( # pylint: disable = too-many-arguments type_identifier = self._ada_type(type_.identifier) result.global_declarations.append( - self._declare_context(ID(identifier), type_identifier) + self._declare_context( + ID(identifier), + type_identifier, + (lambda x: False) if session_global else is_global, + ) ) result.initialization_declarations.append(self._declare_buffer(ID(identifier))) result.initialization.extend( @@ -1631,6 +1883,7 @@ def _declare( # pylint: disable = too-many-arguments self._initialize_context( identifier, type_identifier, + is_global, parameters=( { ID(n): First(self._ada_type(t.identifier)) @@ -1644,7 +1897,7 @@ def _declare( # pylint: disable = too-many-arguments ] ) result.finalization.extend( - self._free_context_buffer(ID(identifier), type_identifier, alloc_id) + self._free_context_buffer(ID(identifier), type_identifier, is_global, alloc_id) ) else: @@ -1668,6 +1921,7 @@ def _declare_and_assign( # pylint: disable = too-many-arguments variables: Sequence[Tuple[rid.ID, rty.Type, expr.Expr]], statements: Sequence[Statement], exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], state: rid.ID, alloc_id: Optional[Location], constant: bool = False, @@ -1680,6 +1934,7 @@ def _declare_and_assign( # pylint: disable = too-many-arguments evaluated_declaration = self._declare( k, type_, + is_global, alloc_id, v if initialized_in_declaration else None, constant=constant, @@ -1696,7 +1951,9 @@ def _declare_and_assign( # pylint: disable = too-many-arguments *[ *evaluated_declaration.initialization, *( - self._assign(k, type_, v, local_exception_handler, state, alloc_id) + self._assign( + k, type_, v, local_exception_handler, is_global, state, alloc_id + ) if not initialized_in_declaration else [] ), @@ -1705,6 +1962,7 @@ def _declare_and_assign( # pylint: disable = too-many-arguments variables[1:], statements, exception_handler, + is_global, state, alloc_id, constant, @@ -1721,11 +1979,14 @@ def _assign( # pylint: disable = too-many-arguments target_type: rty.Type, expression: expr.Expr, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], state: rid.ID, alloc_id: Optional[Location], ) -> Sequence[Statement]: if isinstance(expression, expr.MessageAggregate): - return self._assign_to_message_aggregate(target, expression, exception_handler, state) + return self._assign_to_message_aggregate( + target, expression, exception_handler, is_global, state + ) if isinstance(target_type, rty.Message): for v in expression.findall( @@ -1739,25 +2000,27 @@ def _assign( # pylint: disable = too-many-arguments ) if isinstance(expression, expr.Binding): - return self._assign_to_binding(target, expression, exception_handler, state, alloc_id) + return self._assign_to_binding( + target, expression, exception_handler, is_global, state, alloc_id + ) if isinstance(expression, expr.Selected): - return self._assign_to_selected(target, expression, exception_handler) + return self._assign_to_selected(target, expression, exception_handler, is_global) if isinstance(expression, expr.Head): - return self._assign_to_head(target, expression, exception_handler, alloc_id) + return self._assign_to_head(target, expression, exception_handler, is_global, alloc_id) if isinstance(expression, expr.Comprehension): assert isinstance(target_type, rty.Sequence) return self._assign_to_comprehension( - target, target_type, expression, exception_handler, alloc_id + target, target_type, expression, exception_handler, is_global, alloc_id ) if isinstance(expression, expr.Call): - return self._assign_to_call(target, expression, exception_handler) + return self._assign_to_call(target, expression, exception_handler, is_global) if isinstance(expression, expr.Conversion): - return self._assign_to_conversion(target, expression, exception_handler) + return self._assign_to_conversion(target, expression, exception_handler, is_global) if isinstance( expression, @@ -1774,16 +2037,20 @@ def _assign( # pylint: disable = too-many-arguments isinstance(expression.type_, (rty.AnyInteger, rty.Enumeration)) or expression.type_ == rty.OPAQUE ): - value = expression.substituted(self._substitution()) + value = expression.substituted(self._substitution(is_global)) assert isinstance( target_type, (rty.Integer, rty.Enumeration, rty.Message, rty.Sequence) ) return self._if_valid_fields( expression, [ - Assignment(ID(target), self._convert_type(value, target_type).ada_expr()), + Assignment( + variable_id(target, is_global), + self._convert_type(value, target_type).ada_expr(), + ), ], exception_handler, + is_global, ) if isinstance(expression, expr.Variable) and isinstance( @@ -1793,11 +2060,12 @@ def _assign( # pylint: disable = too-many-arguments _unexpected_expression(expression, "in assignment") - def _assign_to_binding( # pylint: disable = too-many-branches + def _assign_to_binding( # pylint: disable = too-many-branches, too-many-locals, too-many-arguments self, target: rid.ID, binding: expr.Binding, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], state: rid.ID, alloc_id: Optional[Location], ) -> Sequence[Statement]: @@ -1855,17 +2123,23 @@ def _assign_to_binding( # pylint: disable = too-many-branches type_, binding.expr, local_exception_handler, + is_global, state, alloc_id=alloc_id, ), exception_handler, + is_global, state, alloc_id=alloc_id, constant=True, ) def _assign_to_selected( - self, target: rid.ID, selected: expr.Selected, exception_handler: ExceptionHandler + self, + target: rid.ID, + selected: expr.Selected, + exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: if not isinstance(selected.prefix, expr.Variable): fail( @@ -1878,7 +2152,7 @@ def _assign_to_selected( assert isinstance(selected.prefix.type_, rty.Message) message_type = ID(selected.prefix.type_.identifier) - message_context = context_id(selected.prefix.identifier) + message_context = context_id(selected.prefix.identifier, is_global) selector = selected.selector if ( @@ -1896,7 +2170,7 @@ def _assign_to_selected( ), [ Assignment( - Variable(ID(target)), + Variable(variable_id(target, is_global)), Call( message_type * f"Get_{selector}", [Variable(message_context)], @@ -1932,6 +2206,7 @@ def _assign_to_message_aggregate( target: rid.ID, message_aggregate: expr.MessageAggregate, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], state: rid.ID, ) -> Sequence[Statement]: assert isinstance(message_aggregate.type_, rty.Message) @@ -1943,7 +2218,7 @@ def _assign_to_message_aggregate( v for v in size.variables() if isinstance(v.type_, (rty.Message, rty.Sequence)) ] required_space = ( - size.substituted(self._substitution()) + size.substituted(self._substitution(is_global)) .substituted( lambda x: expr.Call(const.TYPES_BIT_LENGTH, [x]) if (isinstance(x, expr.Variable) and isinstance(x.type_, rty.AnyInteger)) @@ -1953,7 +2228,7 @@ def _assign_to_message_aggregate( .ada_expr() ) target_type = ID(message_aggregate.type_.identifier) - target_context = context_id(target) + target_context = context_id(target, is_global) parameter_values = [ (f, v, t) for f, v in message_aggregate.field_values.items() @@ -1990,13 +2265,13 @@ def _assign_to_message_aggregate( ], { ID(p): self._convert_type(v, t) - .substituted(self._substitution()) + .substituted(self._substitution(is_global)) .ada_expr() for p, v, t in parameter_values }, ), *self._set_message_fields( - target_type, target_context, message_aggregate, exception_handler + target_type, target_context, message_aggregate, exception_handler, is_global ), ], exception_handler, @@ -2013,7 +2288,9 @@ def _assign_to_message_aggregate( e for v in size_variables if isinstance(v.type_, (rty.Message, rty.Sequence)) - for s in [expr.Size(v).substituted(self._substitution()).ada_expr()] + for s in [ + expr.Size(v).substituted(self._substitution(is_global)).ada_expr() + ] for e in [ LessEqual( s, @@ -2031,11 +2308,12 @@ def _assign_to_message_aggregate( return assign_to_message_aggregate - def _assign_to_head( + def _assign_to_head( # pylint: disable = too-many-locals self, target: rid.ID, head: expr.Head, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], alloc_id: Optional[Location], ) -> Sequence[Statement]: assert isinstance(head.prefix.type_, rty.Sequence) @@ -2055,7 +2333,8 @@ def _assign_to_head( target_type = ID(head.type_.identifier) sequence_type = ID(head.prefix.type_.identifier) - sequence_context = context_id(head.prefix.identifier) + sequence_id = ID(head.prefix.identifier) + sequence_context = context_id(sequence_id, is_global) sequence_identifier = ID(rid.ID(f"{head.prefix}")) if isinstance(head.prefix.type_.element, (rty.Integer, rty.Enumeration)): @@ -2077,7 +2356,7 @@ def _assign_to_head( ), [ Assignment( - Variable(ID(target)), + Variable(variable_id(target, is_global)), Call( sequence_type * "Head", [Variable(sequence_context)], @@ -2095,9 +2374,10 @@ def _assign_to_head( self._session_context.used_types_body.append(const.TYPES_LENGTH) self._session_context.referenced_types_body.append(target_type) - target_context = context_id(target) + target_context = context_id(target, is_global) target_buffer = buffer_id("RFLX_Target_" + target) element_context = ID("RFLX_Head_Ctx") + copied_sequence_context = context_id(copy_id(sequence_id), is_global) with exception_handler.local() as local_exception_handler: return [ self._declare_sequence_copy( @@ -2109,7 +2389,7 @@ def _assign_to_head( ( Call( sequence_type * "Has_Element", - [Variable(copy_id(sequence_context))], + [Variable(copied_sequence_context)], ), [ Declare( @@ -2127,7 +2407,7 @@ def _assign_to_head( CallStatement( sequence_type * "Switch", [ - Variable(copy_id(sequence_context)), + Variable(copied_sequence_context), Variable(element_context), ], ), @@ -2142,6 +2422,7 @@ def _assign_to_head( *self._take_buffer( ID(target), target_type, + is_global, target_buffer, ), self._copy_to_buffer( @@ -2171,7 +2452,7 @@ def _assign_to_head( local_exception_handler, ), *self._update_context( - copy_id(sequence_context), + copied_sequence_context, element_context, sequence_type, ), @@ -2184,17 +2465,19 @@ def _assign_to_head( ) ], exception_handler, + is_global, alloc_id, ), *exception_handler.execute_deferred(), ] - def _assign_to_comprehension( + def _assign_to_comprehension( # pylint: disable = too-many-arguments self, target: rid.ID, target_type: rty.Sequence, comprehension: expr.Comprehension, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], alloc_id: Optional[Location], ) -> Sequence[Statement]: # pylint: disable = too-many-locals @@ -2231,9 +2514,11 @@ def _assign_to_comprehension( comprehension.selector, comprehension.condition, local_exception_handler, + is_global, ) ], exception_handler, + is_global, alloc_id, ), *exception_handler.execute_deferred(), @@ -2263,7 +2548,7 @@ def _assign_to_comprehension( return [ self._if_structural_valid_message( message_type, - context_id(message_id), + context_id(message_id, is_global), [ self._declare_message_field_sequence_copy( message_id, @@ -2282,9 +2567,11 @@ def _assign_to_comprehension( comprehension.selector, comprehension.condition, local_exception_handler, + is_global, ) ], exception_handler, + is_global, alloc_id, ), ], @@ -2302,21 +2589,23 @@ def _assign_to_comprehension( location=comprehension.sequence.location, ) - def _assign_to_call( + def _assign_to_call( # pylint: disable = too-many-locals self, target: rid.ID, call_expr: expr.Call, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: pre_call = [] post_call = [] local_declarations = [] + target_id = variable_id(target, is_global) if isinstance(call_expr.type_, rty.Message): type_identifier = self._ada_type(call_expr.type_.identifier) local_declarations.append( ObjectDeclaration( - [ID(target)], + [target_id], ID(type_identifier) * "Structure", ) ) @@ -2324,8 +2613,8 @@ def _assign_to_call( CallStatement( ID(type_identifier) * "To_Context", [ - Variable(ID(target)), - Variable(context_id(target)), + Variable(target_id), + Variable(context_id(target, is_global)), ], ), ) @@ -2352,7 +2641,7 @@ def _assign_to_call( CallStatement( ID(type_identifier) * "To_Structure", [ - Variable(context_id(a.identifier)), + Variable(context_id(a.identifier, is_global)), Variable(ID(a.identifier)), ], ), @@ -2405,7 +2694,9 @@ def _assign_to_call( Call( type_identifier * "Field_Size", [ - Variable(context_id(a.prefix.identifier)), + Variable( + context_id(a.prefix.identifier, is_global) + ), Variable(type_identifier * f"F_{a.selector}"), ], ), @@ -2421,7 +2712,7 @@ def _assign_to_call( CallStatement( type_identifier * f"Get_{a.selector}", [ - Variable(context_id(a.prefix.identifier)), + Variable(context_id(a.prefix.identifier, is_global)), argument.ada_expr(), ], ), @@ -2434,8 +2725,9 @@ def _assign_to_call( CallStatement( ID(call_expr.identifier), [ - Variable(ID(target)), - *[a.substituted(self._substitution()).ada_expr() for a in arguments], + Variable("Ctx"), + *[a.substituted(self._substitution(is_global)).ada_expr() for a in arguments], + Variable(target_id), ], ) ] @@ -2454,6 +2746,7 @@ def _assign_to_call( ) ], exception_handler, + is_global, ) return call @@ -2471,6 +2764,7 @@ def _assign_to_conversion( target: rid.ID, conversion: expr.Conversion, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: assert isinstance(conversion.type_, rty.Message) assert isinstance(conversion.argument, expr.Selected) @@ -2504,20 +2798,20 @@ def _assign_to_conversion( * self.contains_function_name( refinement.package, pdu.identifier, sdu.identifier, field ), - [Variable(context_id(conversion.argument.prefix.identifier))], + [Variable(context_id(conversion.argument.prefix.identifier, is_global))], ), [ CallStatement( ID(contains_package) * f"Copy_{field}", [ - Variable(context_id(conversion.argument.prefix.identifier)), - Variable(context_id(target)), + Variable(context_id(conversion.argument.prefix.identifier, is_global)), + Variable(context_id(target, is_global)), ], ), CallStatement( ID(sdu.identifier) * "Verify_Message", [ - Variable(context_id(target)), + Variable(context_id(target, is_global)), ], ), ], @@ -2530,6 +2824,7 @@ def _append( self, append: stmt.Append, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: assert isinstance(append.type_, rty.Sequence) @@ -2569,7 +2864,7 @@ def check(sequence_type: ID, required_space: Expr) -> Statement: assert isinstance(append.parameter, expr.Variable) sequence_type = ID(append.type_.identifier) - sequence_context = context_id(append.identifier) + sequence_context = context_id(append.identifier, is_global) element_type = ID(append.type_.element.identifier) return [ @@ -2582,16 +2877,16 @@ def check(sequence_type: ID, required_space: Expr) -> Statement: if isinstance(append.type_.element, rty.Message): sequence_type = ID(append.type_.identifier) - sequence_context = context_id(append.identifier) + sequence_context = context_id(append.identifier, is_global) element_type = ID(append.type_.element.identifier) - element_context = context_id("RFLX_Element_" + append.identifier) + element_context = context_id("RFLX_Element_" + append.identifier, is_global) self._session_context.referenced_types_body.append(element_type) if isinstance(append.parameter, expr.MessageAggregate): required_space = ( self._message_size(append.parameter) - .substituted(self._substitution()) + .substituted(self._substitution(is_global)) .ada_expr() ) else: @@ -2613,6 +2908,7 @@ def check(sequence_type: ID, required_space: Expr) -> Statement: element_context, append.parameters[0], local_exception_handler, + is_global, ) if isinstance(append.parameters[0], expr.MessageAggregate) else [] @@ -2630,14 +2926,14 @@ def check(sequence_type: ID, required_space: Expr) -> Statement: ) @staticmethod - def _read(read: stmt.Read) -> Sequence[Statement]: + def _read(read: stmt.Read, is_global: Callable[[ID], bool]) -> Sequence[Statement]: assert isinstance(read.parameter.type_, rty.Message) if not isinstance(read.parameter, expr.Variable): _unsupported_expression(read.parameter, "in Read statement") target_type = ID(read.parameter.type_.identifier) - target_context = context_id(read.parameter.identifier) + target_context = context_id(read.parameter.identifier, is_global) return [ CallStatement(target_type * "Verify_Message", [Variable(target_context)]), ] @@ -2656,11 +2952,12 @@ def _write( @staticmethod def _reset( reset: stmt.Reset, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: assert isinstance(reset.type_, rty.Message) target_type = ID(reset.type_.identifier) - target_context = context_id(reset.identifier) + target_context = context_id(reset.identifier, is_global) return [ CallStatement( target_type * "Reset", @@ -2674,7 +2971,7 @@ def _message_size(self, message_aggregate: expr.MessageAggregate) -> expr.Expr: assert isinstance(message, model.Message) return message.size({model.Field(f): v for f, v in message_aggregate.field_values.items()}) - def _substitution(self) -> Callable[[expr.Expr], expr.Expr]: + def _substitution(self, is_global: Callable[[ID], bool]) -> Callable[[expr.Expr], expr.Expr]: # pylint: disable = too-many-statements def func(expression: expr.Expr) -> expr.Expr: @@ -2700,12 +2997,12 @@ def func(expression: expr.Expr) -> expr.Expr: assert isinstance(expression.prefix.type_, rty.Message) if expression.selector in expression.prefix.type_.parameter_types: return expr.Selected( - expr.Variable(context_id(expression.prefix.identifier)), + expr.Variable(context_id(expression.prefix.identifier, is_global)), expression.selector, ) return expr.Call( ID(expression.prefix.type_.identifier) * ID(f"Get_{expression.selector}"), - [expr.Variable(context_id(expression.prefix.identifier))], + [expr.Variable(context_id(expression.prefix.identifier, is_global))], ) assert False @@ -2715,13 +3012,13 @@ def func(expression: expr.Expr) -> expr.Expr: if isinstance(expression.prefix.type_, rty.Message): return expr.Call( ID(expression.prefix.type_.identifier) * ID("Structural_Valid_Message"), - [expr.Variable(context_id(expression.prefix.identifier))], + [expr.Variable(context_id(expression.prefix.identifier, is_global))], ) if isinstance(expression.prefix.type_, rty.Sequence): return expr.Call( ID(expression.prefix.type_.identifier) * ID("Valid"), - [expr.Variable(context_id(expression.prefix.identifier))], + [expr.Variable(context_id(expression.prefix.identifier, is_global))], ) assert False @@ -2738,7 +3035,9 @@ def func(expression: expr.Expr) -> expr.Expr: else ID("Structural_Valid") ), [ - expr.Variable(context_id(expression.prefix.prefix.identifier)), + expr.Variable( + context_id(expression.prefix.prefix.identifier, is_global) + ), expr.Variable(type_name * f"F_{expression.prefix.selector}"), ], ) @@ -2753,7 +3052,9 @@ def func(expression: expr.Expr) -> expr.Expr: return expr.Call( type_name * ID("Present"), [ - expr.Variable(context_id(expression.prefix.prefix.identifier)), + expr.Variable( + context_id(expression.prefix.prefix.identifier, is_global) + ), expr.Variable(type_name * f"F_{expression.prefix.selector}"), ], ) @@ -2808,10 +3109,10 @@ def func(expression: expr.Expr) -> expr.Expr: literal = None if isinstance(expression.left, expr.Selected): - selected = expression.left.substituted(self._substitution()) + selected = expression.left.substituted(self._substitution(is_global)) literal = expression.right elif isinstance(expression.right, expr.Selected): - selected = expression.right.substituted(self._substitution()) + selected = expression.right.substituted(self._substitution(is_global)) literal = expression.left if selected and literal: @@ -2841,7 +3142,7 @@ def func(expression: expr.Expr) -> expr.Expr: if isinstance(expression.prefix.type_, (rty.Message, rty.Sequence)): type_ = ID(expression.prefix.type_.identifier) - context = context_id(expression.prefix.identifier) + context = context_id(expression.prefix.identifier, is_global) return expr.Call(type_ * "Size", [expr.Variable(context)]) _unexpected_expression(expression.prefix, "in Size attribute") @@ -2850,7 +3151,7 @@ def func(expression: expr.Expr) -> expr.Expr: assert isinstance(expression.prefix.prefix, expr.Variable) assert isinstance(expression.prefix.prefix.type_, rty.Message) type_ = ID(expression.prefix.prefix.type_.identifier) - context = context_id(expression.prefix.prefix.identifier) + context = context_id(expression.prefix.prefix.identifier, is_global) return expr.Call( type_ * "Field_Size", [ @@ -2865,7 +3166,7 @@ def func(expression: expr.Expr) -> expr.Expr: assert isinstance(expression.prefix, expr.Variable) assert isinstance(expression.prefix.type_, rty.Message) type_ = ID(expression.prefix.type_.identifier) - context = context_id(expression.prefix.identifier) + context = context_id(expression.prefix.identifier, is_global) return expr.Greater( expr.Call(type_ * "Byte_Size", [expr.Variable(context)]), expr.Number(0) ) @@ -2875,7 +3176,7 @@ def func(expression: expr.Expr) -> expr.Expr: assert expression.type_ == rty.OPAQUE assert isinstance(expression.prefix.type_, rty.Message) message_type = ID(expression.prefix.type_.identifier) - message_context = context_id(expression.prefix.identifier) + message_context = context_id(expression.prefix.identifier, is_global) return expr.Call( message_type * "Message_Data", [expr.Variable(message_context)] ) @@ -2885,6 +3186,15 @@ def func(expression: expr.Expr) -> expr.Expr: if isinstance(expression, expr.Head): _unsupported_expression(expression, "in expression") + if isinstance(expression, expr.Variable): + return expr.Variable( + variable_id(expression.identifier, is_global), + expression.negative, + expression.immutable, + expression.type_, + expression.location, + ) + return expression return func @@ -2963,6 +3273,7 @@ def _if_valid_fields( expression: expr.Expr, statements: Sequence[Statement], exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: """Ensure that all referenced fields in the expression are valid.""" @@ -2973,7 +3284,7 @@ def _if_valid_fields( return [ self._if( expr.AndThen(*[expr.Valid(e) for e in selected]) - .substituted(self._substitution()) + .substituted(self._substitution(is_global)) .ada_expr(), statements, f"reference to invalid message field in {expressions}", @@ -3075,6 +3386,7 @@ def _set_message_fields( target_context: ID, message_aggregate: expr.MessageAggregate, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> Sequence[Statement]: # pylint: disable = too-many-statements, too-many-branches, too-many-locals @@ -3097,13 +3409,13 @@ def _set_message_fields( v.type_, (rty.Message, rty.Sequence) ): type_ = ID(v.type_.identifier) - context = context_id(v.identifier) + context = context_id(v.identifier, is_global) size = Call(type_ * "Size", [Variable(context)]) elif isinstance(v, expr.Selected): assert isinstance(v.prefix, expr.Variable) assert isinstance(v.prefix.type_, rty.Message) message_type = ID(v.prefix.type_.identifier) - message_context = context_id(v.prefix.identifier) + message_context = context_id(v.prefix.identifier, is_global) statements = self._ensure( statements, Call( @@ -3124,9 +3436,9 @@ def _set_message_fields( ], ) elif isinstance(v, expr.Opaque): - size = expr.Size(v.prefix).substituted(self._substitution()).ada_expr() + size = expr.Size(v.prefix).substituted(self._substitution(is_global)).ada_expr() else: - size = Size(v.substituted(self._substitution()).ada_expr()) + size = Size(v.substituted(self._substitution(is_global)).ada_expr()) statements = self._ensure( statements, Call( @@ -3151,7 +3463,9 @@ def _set_message_fields( CallStatement(target_type * f"Set_{f}_Empty", [Variable(target_context)]) ) else: - value = self._convert_type(v, field_type).substituted(self._substitution()) + value = self._convert_type(v, field_type).substituted( + self._substitution(is_global) + ) statements.append( CallStatement( target_type * f"Set_{f}", @@ -3162,7 +3476,7 @@ def _set_message_fields( ) ) elif isinstance(v, expr.Variable) and isinstance(v.type_, rty.Sequence): - sequence_context = context_id(v.identifier) + sequence_context = context_id(v.identifier, is_global) statements.extend( [ CallStatement( @@ -3179,7 +3493,7 @@ def _set_message_fields( and isinstance(v.prefix.type_, rty.Message) ): message_type = ID(v.prefix.type_.identifier) - message_context = context_id(v.prefix.identifier) + message_context = context_id(v.prefix.identifier, is_global) target_field_type = message_aggregate.type_.types[f] statements = self._ensure( statements, @@ -3218,59 +3532,13 @@ def _set_message_fields( self._session_context.used_types_body.append(const.TYPES_LENGTH) statements.extend( [ - self._set_opaque_field( + self._set_opaque_field_to_message_field( target_type, target_context, ID(f), - get_preconditions=AndThen( - Call( - ID(message_type * "Has_Buffer"), - [Variable(message_context)], - ), - Call( - ID(message_type * "Structural_Valid"), - [ - Variable(message_context), - Variable(message_type * f"F_{v.selector}"), - ], - ), - GreaterEqual( - Variable("Length"), - Call( - const.TYPES_TO_LENGTH, - [ - Call( - message_type * "Field_Size", - [ - Variable(message_context), - Variable(message_type * f"F_{v.selector}"), - ], - ) - ], - ), - ), - ), - get_statements=[ - CallStatement( - message_type * f"Get_{v.selector}", - [ - Variable(message_context), - Variable("Data"), - ], - ), - ], - length=Call( - const.TYPES_TO_LENGTH, - [ - Call( - message_type * "Field_Size", - [ - Variable(message_context), - Variable(message_type * f"F_{v.selector}"), - ], - ) - ], - ), + message_type, + message_context, + ID(v.selector), ), ] ) @@ -3278,49 +3546,15 @@ def _set_message_fields( assert v.type_ == rty.OPAQUE assert isinstance(v.prefix.type_, rty.Message) message_type = ID(v.prefix.type_.identifier) - message_context = context_id(v.prefix.identifier) + message_context = context_id(v.prefix.identifier, is_global) statements.extend( [ - self._set_opaque_field( + self._set_opaque_field_to_message( target_type, target_context, ID(f), - get_preconditions=AndThen( - Call( - ID(message_type * "Has_Buffer"), - [Variable(message_context)], - ), - Call( - ID(message_type * "Structural_Valid_Message"), - [ - Variable(message_context), - ], - ), - GreaterEqual( - Variable("Length"), - Call( - message_type * "Byte_Size", - [ - Variable(message_context), - ], - ), - ), - ), - get_statements=[ - CallStatement( - message_type * "Message_Data", - [ - Variable(message_context), - Variable("Data"), - ], - ), - ], - length=Call( - message_type * "Byte_Size", - [ - Variable(message_context), - ], - ), + message_type, + message_context, ), ] ) @@ -3329,16 +3563,21 @@ def _set_message_fields( return result @staticmethod - def _set_opaque_field( + def _set_opaque_field( # pylint: disable = too-many-arguments target_type: ID, target_context: ID, field: ID, get_preconditions: Expr, get_statements: Sequence[Statement], length: Expr, + pre_declarations: Sequence[Declaration] = None, + post_statements: Sequence[Statement] = None, ) -> Declare: + pre_declarations = pre_declarations if pre_declarations else [] + post_statements = post_statements if post_statements else [] return Declare( [ + *pre_declarations, ExpressionFunctionDeclaration( FunctionSpecification( "RFLX_Process_Data_Pre", @@ -3370,58 +3609,212 @@ def _set_opaque_field( length, ], ), + *post_statements, + ], + ) + + def _set_opaque_field_to_message_field( # pylint: disable = too-many-arguments + self, + target_type: ID, + target_context: ID, + field: ID, + message_type: ID, + message_context: ID, + message_field: ID, + ) -> Declare: + # Prevent aliasing in generic setter function by moving context into temporary variable + temporary_message_context = f"RFLX_{message_context.flat}_Tmp" + return self._set_opaque_field( + target_type, + target_context, + field, + pre_declarations=[ + Pragma( + "Warnings", + [ + Variable("Off"), + String("is not modified, could be declared constant"), + ], + ), + ObjectDeclaration( + [temporary_message_context], + message_type * "Context", + Variable(message_context), + ), + Pragma( + "Warnings", + [ + Variable("On"), + String("is not modified, could be declared constant"), + ], + ), + ], + get_preconditions=AndThen( + Call( + ID(message_type * "Has_Buffer"), + [Variable(temporary_message_context)], + ), + Call( + ID(message_type * "Structural_Valid"), + [ + Variable(temporary_message_context), + Variable(message_type * f"F_{message_field}"), + ], + ), + GreaterEqual( + Variable("Length"), + Call( + const.TYPES_TO_LENGTH, + [ + Call( + message_type * "Field_Size", + [ + Variable(temporary_message_context), + Variable(message_type * f"F_{message_field}"), + ], + ) + ], + ), + ), + ), + get_statements=[ + CallStatement( + message_type * f"Get_{message_field}", + [ + Variable(temporary_message_context), + Variable("Data"), + ], + ), + ], + length=Call( + const.TYPES_TO_LENGTH, + [ + Call( + message_type * "Field_Size", + [ + Variable(temporary_message_context), + Variable(message_type * f"F_{message_field}"), + ], + ) + ], + ), + post_statements=[Assignment(message_context, Variable(temporary_message_context))], + ) + + def _set_opaque_field_to_message( + self, + target_type: ID, + target_context: ID, + field: ID, + message_type: ID, + message_context: ID, + ) -> Declare: + return self._set_opaque_field( + target_type, + target_context, + field, + get_preconditions=AndThen( + Call( + ID(message_type * "Has_Buffer"), + [Variable(message_context)], + ), + Call( + ID(message_type * "Structural_Valid_Message"), + [ + Variable(message_context), + ], + ), + GreaterEqual( + Variable("Length"), + Call( + message_type * "Byte_Size", + [ + Variable(message_context), + ], + ), + ), + ), + get_statements=[ + CallStatement( + message_type * "Message_Data", + [ + Variable(message_context), + Variable("Data"), + ], + ), ], + length=Call( + message_type * "Byte_Size", + [ + Variable(message_context), + ], + ), ) - def _declare_context_buffer(self, identifier: ID, type_: ID) -> List[Declaration]: + def _declare_context_buffer( + self, + identifier: ID, + type_: ID, + is_global: Callable[[ID], bool], + ) -> List[Declaration]: return [ - self._declare_context(identifier, type_), + self._declare_context(identifier, type_, is_global), self._declare_buffer(identifier), ] - def _declare_context(self, identifier: ID, type_: ID) -> Declaration: + def _declare_context( + self, + identifier: ID, + type_: ID, + is_global: Callable[[ID], bool], + ) -> Declaration: self._session_context.referenced_types_body.append(type_) - return ObjectDeclaration([context_id(identifier)], type_ * "Context") + return ObjectDeclaration([context_id(identifier, is_global)], type_ * "Context") @staticmethod def _declare_buffer(identifier: ID) -> Declaration: return ObjectDeclaration([buffer_id(identifier)], const.TYPES_BYTES_PTR) - def _declare_sequence_copy( + def _declare_sequence_copy( # pylint: disable = too-many-arguments self, sequence_identifier: ID, sequence_type: ID, statements: Sequence[Statement], exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], alloc_id: Optional[Location], ) -> IfStatement: # ISSUE: Componolit/RecordFlux#577 + sequence_context = context_id(sequence_identifier, is_global) with exception_handler.local() as local_exception_handler: return self._if_valid_sequence( sequence_type, - context_id(sequence_identifier), + sequence_context, [ Declare( - self._declare_context_buffer(copy_id(sequence_identifier), sequence_type), + self._declare_context_buffer( + copy_id(sequence_identifier), sequence_type, is_global + ), [ *self._allocate_buffer(copy_id(sequence_identifier), alloc_id), self._copy_to_buffer( sequence_type, - context_id(sequence_identifier), + sequence_context, ID(f"{copy_id(buffer_id(sequence_identifier))}"), local_exception_handler, ), self._initialize_context( copy_id(sequence_identifier), sequence_type, + is_global, last=Call( sequence_type * "Sequence_Last", - [Variable(context_id(sequence_identifier))], + [Variable(sequence_context)], ), ), *statements, *self._free_context_buffer( - copy_id(sequence_identifier), sequence_type, alloc_id + copy_id(sequence_identifier), sequence_type, is_global, alloc_id ), ], ) @@ -3438,32 +3831,34 @@ def _declare_message_field_sequence_copy( # pylint: disable = too-many-argument sequence_type: ID, statements: Sequence[Statement], exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], alloc_id: Optional[Location], ) -> Declare: # ISSUE: Componolit/RecordFlux#577 with exception_handler.local() as local_exception_handler: return Declare( - self._declare_context_buffer(sequence_identifier, sequence_type), + self._declare_context_buffer(sequence_identifier, sequence_type, is_global), [ *self._allocate_buffer(sequence_identifier, alloc_id), self._copy_to_buffer( message_type, - context_id(message_identifier), + context_id(message_identifier, is_global), ID(f"{buffer_id(sequence_identifier)}"), local_exception_handler, ), self._if_structural_valid_message_field( message_type, - context_id(message_identifier), + context_id(message_identifier, is_global), message_field, [ self._initialize_context( sequence_identifier, sequence_type, + is_global, first=Call( message_type * "Field_First", [ - Variable(context_id(message_identifier)), + Variable(context_id(message_identifier, is_global)), Variable( message_type * model.Field(message_field).affixed_name ), @@ -3472,7 +3867,7 @@ def _declare_message_field_sequence_copy( # pylint: disable = too-many-argument last=Call( message_type * "Field_Last", [ - Variable(context_id(message_identifier)), + Variable(context_id(message_identifier, is_global)), Variable( message_type * model.Field(message_field).affixed_name ), @@ -3480,7 +3875,7 @@ def _declare_message_field_sequence_copy( # pylint: disable = too-many-argument ), ), *statements, - *self._take_buffer(sequence_identifier, sequence_type), + *self._take_buffer(sequence_identifier, sequence_type, is_global), ], local_exception_handler, ), @@ -3499,6 +3894,7 @@ def _comprehension( # pylint: disable = too-many-arguments selector: expr.Expr, condition: expr.Expr, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> While: assert not isinstance(selector, expr.MessageAggregate) @@ -3510,7 +3906,7 @@ def _comprehension( # pylint: disable = too-many-arguments return While( Call( sequence_type * "Has_Element", - [Variable(context_id(sequence_identifier))], + [Variable(context_id(sequence_identifier, is_global))], ), [ PragmaStatement( @@ -3518,7 +3914,7 @@ def _comprehension( # pylint: disable = too-many-arguments [ Call( sequence_type * "Has_Buffer", - [Variable(context_id(sequence_identifier))], + [Variable(context_id(sequence_identifier, is_global))], ) ], ), @@ -3527,7 +3923,7 @@ def _comprehension( # pylint: disable = too-many-arguments [ Call( target_type_id * "Has_Buffer", - [Variable(context_id(target_identifier))], + [Variable(context_id(target_identifier, is_global))], ) ], ), @@ -3536,8 +3932,10 @@ def _comprehension( # pylint: disable = too-many-arguments "Loop_Invariant", [ Equal( - Selected(Variable(context_id(x)), "Buffer_First"), - LoopEntry(Selected(Variable(context_id(x)), "Buffer_First")), + Selected(Variable(context_id(x, is_global)), "Buffer_First"), + LoopEntry( + Selected(Variable(context_id(x, is_global)), "Buffer_First") + ), ), ], ) @@ -3548,8 +3946,10 @@ def _comprehension( # pylint: disable = too-many-arguments "Loop_Invariant", [ Equal( - Selected(Variable(context_id(x)), "Buffer_Last"), - LoopEntry(Selected(Variable(context_id(x)), "Buffer_Last")), + Selected(Variable(context_id(x, is_global)), "Buffer_Last"), + LoopEntry( + Selected(Variable(context_id(x, is_global)), "Buffer_Last") + ), ), ], ) @@ -3560,23 +3960,23 @@ def _comprehension( # pylint: disable = too-many-arguments [ Call( target_type_id * "Valid", - [Variable(context_id(target_identifier))], + [Variable(context_id(target_identifier, is_global))], ) ], ), Declare( - [self._declare_context(iterator_identifier, iterator_type)], + [self._declare_context(iterator_identifier, iterator_type, is_global)], [ CallStatement( sequence_type * "Switch", [ - Variable(context_id(sequence_identifier)), - Variable(context_id(iterator_identifier)), + Variable(context_id(sequence_identifier, is_global)), + Variable(context_id(iterator_identifier, is_global)), ], ), CallStatement( iterator_type * "Verify_Message", - [Variable(context_id(iterator_identifier))], + [Variable(context_id(iterator_identifier, is_global))], ), *self._if_valid_fields( condition, @@ -3585,23 +3985,25 @@ def _comprehension( # pylint: disable = too-many-arguments [ ( condition.substituted( - self._substitution() + self._substitution(is_global) ).ada_expr(), self._comprehension_append_element( target_identifier, target_type, selector, local_exception_handler, + is_global, ), ) ] ) ], exception_handler, + is_global, ), *self._update_context( - context_id(sequence_identifier), - context_id(iterator_identifier), + context_id(sequence_identifier, is_global), + context_id(iterator_identifier, is_global), sequence_type, ), ], @@ -3616,6 +4018,7 @@ def _comprehension_append_element( target_type: rty.Sequence, selector: expr.Expr, exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], ) -> List[Statement]: target_type_id = ID(target_type.identifier) required_space: Expr @@ -3653,7 +4056,7 @@ def _comprehension_append_element( CallStatement( target_type_id * "Append_Element", [ - Variable(context_id(target_identifier)), + Variable(context_id(target_identifier, is_global)), Variable(element_id), ], ) @@ -3680,8 +4083,8 @@ def _comprehension_append_element( append_element = CallStatement( target_type_id * "Append_Element", [ - Variable(context_id(target_identifier)), - selector.substituted(self._substitution()).ada_expr(), + Variable(context_id(target_identifier, is_global)), + selector.substituted(self._substitution(is_global)).ada_expr(), ], ) @@ -3692,36 +4095,41 @@ def _comprehension_append_element( self._if_sufficient_space_in_sequence( required_space, target_type_id, - context_id(target_identifier), + context_id(target_identifier, is_global), [append_element], exception_handler, ), ] def _free_context_buffer( - self, identifier: ID, type_: ID, alloc_id: Optional[Location] + self, + identifier: ID, + type_: ID, + is_global: Callable[[ID], bool], + alloc_id: Optional[Location], ) -> Sequence[Statement]: return [ - *self._take_buffer(identifier, type_), + *self._take_buffer(identifier, type_, is_global), *self._free_buffer(identifier, alloc_id), ] def _free_buffer(self, identifier: ID, alloc_id: Optional[Location]) -> Sequence[Statement]: - return self._allocator.free_buffer(buffer_id(identifier), alloc_id) + slot_id = Variable("Ctx.P.Slots" * self._allocator.get_slot_ptr(alloc_id)) + return [ + Assignment( + slot_id, + Variable(buffer_id(identifier)), + ), + ] @staticmethod - def _take_buffer(identifier: ID, type_: ID, buf: ID = None) -> Sequence[Statement]: - context = context_id(identifier) + def _take_buffer( + identifier: ID, type_: ID, is_global: Callable[[ID], bool], buf: ID = None + ) -> Sequence[Statement]: + context = context_id(identifier, is_global) buf = buf or buffer_id(identifier) return [ # WORKAROUND: Componolit/Workarounds#32 - PragmaStatement( - "Warnings", - [ - Variable("Off"), - String(f'unused assignment to "{context}"'), - ], - ), PragmaStatement( "Warnings", [ @@ -3743,13 +4151,6 @@ def _take_buffer(identifier: ID, type_: ID, buf: ID = None) -> Sequence[Statemen String(f'"{context}" is set by "Take_Buffer" but not used after the call'), ], ), - PragmaStatement( - "Warnings", - [ - Variable("On"), - String(f'unused assignment to "{context}"'), - ], - ), ] @staticmethod @@ -3758,13 +4159,6 @@ def _update_context( ) -> Sequence[Statement]: return [ # WORKAROUND: Componolit/Workarounds#32 - PragmaStatement( - "Warnings", - [ - Variable("Off"), - String(f'unused assignment to "{element_context}"'), - ], - ), PragmaStatement( "Warnings", [ @@ -3786,20 +4180,13 @@ def _update_context( String(f'"{element_context}" is set by "Update" but not used after the call'), ], ), - PragmaStatement( - "Warnings", - [ - Variable("On"), - String(f'unused assignment to "{element_context}"'), - ], - ), ] def _allocate_buffer( self, identifier: rid.ID, alloc_id: Optional[Location] ) -> Sequence[Statement]: self._session_context.used_types_body.append(const.TYPES_INDEX) - slot_id = self._allocator.get_slot_ptr(alloc_id) + slot_id = Variable("Ctx.P.Slots" * self._allocator.get_slot_ptr(alloc_id)) return [ Assignment(buffer_id(identifier), slot_id), PragmaStatement("Warnings", [Variable("Off"), String("unused assignment")]), @@ -3808,9 +4195,10 @@ def _allocate_buffer( ] @staticmethod - def _initialize_context( + def _initialize_context( # pylint: disable = too-many-arguments identifier: rid.ID, type_: ID, + is_global: Callable[[ID], bool], first: Expr = None, last: Expr = None, parameters: Mapping[ID, Expr] = None, @@ -3819,7 +4207,7 @@ def _initialize_context( return CallStatement( type_ * "Initialize", [ - Variable(context_id(identifier)), + Variable(context_id(identifier, is_global)), Variable(buffer_id(identifier)), *( [ @@ -3903,11 +4291,25 @@ def _debug_output(self, string: str) -> List[CallStatement]: def copy_id(identifier: ID) -> ID: - return "RFLX_Copy_" + identifier + return ID("RFLX_Copy_" + identifier.flat) + + +def variable_id(identifier: rid.ID, is_global: Callable[[ID], bool]) -> ID: + identifier = ID(identifier) + + if is_global and is_global(identifier): + return "Ctx.P" * identifier + + return identifier + + +def context_id(identifier: rid.ID, is_global: Callable[[ID], bool]) -> ID: + identifier = ID(identifier + "_Ctx") + if is_global and is_global(identifier): + return "Ctx.P" * identifier -def context_id(identifier: rid.ID) -> ID: - return ID(identifier + "_Ctx") + return identifier def buffer_id(identifier: rid.ID) -> ID: diff --git a/tests/README.md b/tests/README.md index d04151e306..d8294dffae 100644 --- a/tests/README.md +++ b/tests/README.md @@ -22,11 +22,12 @@ Subdirectories containing a `test.rflx` file are considered as feature tests. Th The executability and provability tests require the definition of a session called `Session` with one readable and writable channel. The actions can be configured in an optional `config.yml` file: -- `functions`: All fully-qualified names for the session functions are listed. The functions are defined inside the `src` directory. - `input`: Each list element is interpreted as an input message for the session channel. A message is represented by a space-separated list of bytes (decimal numerals in the range 0 to 255). - `output`: Each read or written message and each entry of a state (except the final state) is written to `stdout`. The expected output is defined in `output`. - `prove`: If the `prove` key exists, the generated SPARK code for `Session` and each unit listed in `prove` will be proved. +Session functions can be defined by putting a custom implementation of the `Session` package inside the `src` directory. + ### Property Tests (`tests/property`) Property-based testing based on [Hypothesis](https://hypothesis.readthedocs.io/). diff --git a/tests/integration/feature_test.py b/tests/integration/feature_test.py index 7b503e6aef..722aaf7522 100644 --- a/tests/integration/feature_test.py +++ b/tests/integration/feature_test.py @@ -8,7 +8,6 @@ import pytest from ruamel.yaml.main import YAML -from rflx import ada from rflx.generator import Generator from rflx.identifier import ID from rflx.integration import Integration @@ -29,7 +28,6 @@ @dataclass(frozen=True) class Config: - functions: Sequence[str] = dataclass_field(default_factory=list) inp: dict[str, Sequence[tuple[int, ...]]] = dataclass_field(default_factory=dict) out: Sequence[str] = dataclass_field(default_factory=list) sequence: str = dataclass_field(default="") @@ -43,7 +41,6 @@ def get_config(feature: str) -> Config: yaml = YAML(typ="safe") cfg = yaml.load(config_file) return Config( - cfg["functions"] if "functions" in cfg and cfg["functions"] else [], { str(c): [tuple(int(e) for e in str(m).split()) for m in i] for c, i in cfg["input"].items() @@ -65,13 +62,10 @@ def create_model(feature: str) -> Tuple[Model, Integration]: def create_complement(config: Config, feature: str, tmp_path: Path) -> None: - context = [ada.WithClause(f.split(".")[0]) for f in config.functions] complement = session_main( config.inp, config.out, - context=context, session_package="RFLX.Test.Session", - session_parameters=config.functions, ) assert MAIN in complement @@ -145,6 +139,6 @@ def test_provability(feature: str, tmp_path: Path) -> None: if model.sessions: assert len(model.sessions) == 1 assert model.sessions[0].identifier == ID("Test::Session") - units = ["main", "lib"] + units = ["main", "lib", "rflx-test-session"] create_complement(config, feature, tmp_path) assert_provable_code(model, integration, tmp_path, main=MAIN, units=[*units, *config.prove]) diff --git a/tests/integration/messages_with_implict_size/generated/rflx-test-session.adb b/tests/integration/messages_with_implict_size/generated/rflx-test-session.adb index 7246884699..a22d0b66cc 100644 --- a/tests/integration/messages_with_implict_size/generated/rflx-test-session.adb +++ b/tests/integration/messages_with_implict_size/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,189 +8,167 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (M_R_Ctx); - P_Next_State := S_Process; + Universal.Message.Verify_Message (Ctx.P.M_R_Ctx); + Ctx.P.Next_State := S_Process; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin if - Universal.Message.Size (M_R_Ctx) <= 32768 - and then Universal.Message.Size (M_R_Ctx) mod RFLX_Types.Byte'Size = 0 + Universal.Message.Size (Ctx.P.M_R_Ctx) <= 32768 + and then Universal.Message.Size (Ctx.P.M_R_Ctx) mod RFLX_Types.Byte'Size = 0 then - if RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_First) + 1 >= Universal.Message.Field_Size (M_R_Ctx, Universal.Message.F_Data) + 8 then - Universal.Message.Reset (M_S_Ctx, RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_First) + (Universal.Message.Field_Size (M_R_Ctx, Universal.Message.F_Data) + 8) - 1); - Universal.Message.Set_Message_Type (M_S_Ctx, Universal.MT_Unconstrained_Data); - if Universal.Message.Valid_Next (M_R_Ctx, Universal.Message.F_Data) then - if Universal.Message.Valid_Length (M_S_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (Universal.Message.Field_Size (M_R_Ctx, Universal.Message.F_Data))) then - if Universal.Message.Structural_Valid (M_R_Ctx, Universal.Message.F_Data) then + if RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_First) + 1 >= Universal.Message.Field_Size (Ctx.P.M_R_Ctx, Universal.Message.F_Data) + 8 then + Universal.Message.Reset (Ctx.P.M_S_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_First) + (Universal.Message.Field_Size (Ctx.P.M_R_Ctx, Universal.Message.F_Data) + 8) - 1); + Universal.Message.Set_Message_Type (Ctx.P.M_S_Ctx, Universal.MT_Unconstrained_Data); + if Universal.Message.Valid_Next (Ctx.P.M_R_Ctx, Universal.Message.F_Data) then + if Universal.Message.Valid_Length (Ctx.P.M_S_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (Universal.Message.Field_Size (Ctx.P.M_R_Ctx, Universal.Message.F_Data))) then + if Universal.Message.Structural_Valid (Ctx.P.M_R_Ctx, Universal.Message.F_Data) then declare + pragma Warnings (Off, "is not modified, could be declared constant"); + RFLX_Ctx_P_M_R_Ctx_Tmp : Universal.Message.Context := Ctx.P.M_R_Ctx; + pragma Warnings (On, "is not modified, could be declared constant"); function RFLX_Process_Data_Pre (Length : RFLX_Types.Length) return Boolean is - (Universal.Message.Has_Buffer (M_R_Ctx) - and then Universal.Message.Structural_Valid (M_R_Ctx, Universal.Message.F_Data) - and then Length >= RFLX_Types.To_Length (Universal.Message.Field_Size (M_R_Ctx, Universal.Message.F_Data))); + (Universal.Message.Has_Buffer (RFLX_Ctx_P_M_R_Ctx_Tmp) + and then Universal.Message.Structural_Valid (RFLX_Ctx_P_M_R_Ctx_Tmp, Universal.Message.F_Data) + and then Length >= RFLX_Types.To_Length (Universal.Message.Field_Size (RFLX_Ctx_P_M_R_Ctx_Tmp, Universal.Message.F_Data))); procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes) with Pre => RFLX_Process_Data_Pre (Data'Length) is begin - Universal.Message.Get_Data (M_R_Ctx, Data); + Universal.Message.Get_Data (RFLX_Ctx_P_M_R_Ctx_Tmp, Data); end RFLX_Process_Data; procedure RFLX_Universal_Message_Set_Data is new Universal.Message.Generic_Set_Data (RFLX_Process_Data, RFLX_Process_Data_Pre); begin - RFLX_Universal_Message_Set_Data (M_S_Ctx, RFLX_Types.To_Length (Universal.Message.Field_Size (M_R_Ctx, Universal.Message.F_Data))); + RFLX_Universal_Message_Set_Data (Ctx.P.M_S_Ctx, RFLX_Types.To_Length (Universal.Message.Field_Size (RFLX_Ctx_P_M_R_Ctx_Tmp, Universal.Message.F_Data))); + Ctx.P.M_R_Ctx := RFLX_Ctx_P_M_R_Ctx_Tmp; end; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is M_R_Buffer : RFLX_Types.Bytes_Ptr; M_S_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - M_R_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + M_R_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (M_R_Ctx, M_R_Buffer); - M_S_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Universal.Message.Initialize (Ctx.P.M_R_Ctx, M_R_Buffer); + M_S_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (M_S_Ctx, M_S_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.M_S_Ctx, M_S_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is M_R_Buffer : RFLX_Types.Bytes_Ptr; M_S_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""M_R_Ctx"""); - pragma Warnings (Off, """M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (M_R_Ctx, M_R_Buffer); - pragma Warnings (On, """M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_R_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := M_R_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""M_S_Ctx"""); - pragma Warnings (Off, """M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (M_S_Ctx, M_S_Buffer); - pragma Warnings (On, """M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_S_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := M_S_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.M_R_Ctx, M_R_Buffer); + pragma Warnings (On, """Ctx.P.M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := M_R_Buffer; + pragma Warnings (Off, """Ctx.P.M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.M_S_Ctx, M_S_Buffer); + pragma Warnings (On, """Ctx.P.M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := M_S_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (M_R_Ctx, M_R_Ctx.First, M_R_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.M_R_Ctx, Ctx.P.M_R_Ctx.First, Ctx.P.M_R_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (M_S_Ctx) - and Universal.Message.Byte_Size (M_S_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (M_S_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -207,40 +186,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (M_S_Ctx); + Universal_Message_Read (Ctx.P.M_S_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -253,9 +219,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (M_R_Ctx, Offset); + Universal_Message_Write (Ctx.P.M_R_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/messages_with_implict_size/generated/rflx-test-session.ads b/tests/integration/messages_with_implict_size/generated/rflx-test-session.ads index b426c24055..a9efbabda6 100644 --- a/tests/integration/messages_with_implict_size/generated/rflx-test-session.ads +++ b/tests/integration/messages_with_implict_size/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,108 +18,152 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - M_R_Ctx : Universal.Message.Context; - - M_S_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (M_R_Ctx) - and not Universal.Message.Has_Buffer (M_S_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (M_R_Ctx) - and then M_R_Ctx.Buffer_First = RFLX_Types.Index'First - and then M_R_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Universal.Message.Has_Buffer (M_S_Ctx) - and then M_S_Ctx.Buffer_First = RFLX_Types.Index'First - and then M_S_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + M_R_Ctx : Universal.Message.Context; + M_S_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.M_R_Ctx) + and not Universal.Message.Has_Buffer (Ctx.P.M_S_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.M_R_Ctx) + and then Ctx.P.M_R_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.M_R_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Universal.Message.Has_Buffer (Ctx.P.M_S_Ctx) + and then Ctx.P.M_S_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.M_S_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.M_S_Ctx) + and Universal.Message.Byte_Size (Ctx.P.M_S_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.M_S_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.adb b/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.adb index 9024bb3698..85d68b5b9b 100644 --- a/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.adb +++ b/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.ads b/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.ads index 7ab793148d..3355bcb4b1 100644 --- a/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.ads +++ b/tests/integration/messages_with_implict_size/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,20 +22,30 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/parameterized_messages/generated/rflx-test-session.adb b/tests/integration/parameterized_messages/generated/rflx-test-session.adb index bf1056c440..9f25e3a444 100644 --- a/tests/integration/parameterized_messages/generated/rflx-test-session.adb +++ b/tests/integration/parameterized_messages/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test; @@ -9,225 +10,203 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Test.Message.Reset (M_R_Ctx, Length => 2, Extended => False); - P_Next_State := S_Receive; + Test.Message.Reset (Ctx.P.M_R_Ctx, Length => 2, Extended => False); + Ctx.P.Next_State := S_Receive; end Start; - procedure Receive (P_Next_State : out State) with + procedure Receive (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Test.Message.Verify_Message (M_R_Ctx); - if Test.Message.Structural_Valid_Message (M_R_Ctx) then - P_Next_State := S_Process; + Test.Message.Verify_Message (Ctx.P.M_R_Ctx); + if Test.Message.Structural_Valid_Message (Ctx.P.M_R_Ctx) then + Ctx.P.Next_State := S_Process; else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; end if; end Receive; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin if - Test.Message.Size (M_R_Ctx) <= 32768 - and then Test.Message.Size (M_R_Ctx) mod RFLX_Types.Byte'Size = 0 + Test.Message.Size (Ctx.P.M_R_Ctx) <= 32768 + and then Test.Message.Size (Ctx.P.M_R_Ctx) mod RFLX_Types.Byte'Size = 0 then - if RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_First) + 1 >= RFLX_Types.Bit_Length (M_R_Ctx.Length) * 8 + 16 then - Test.Message.Reset (M_S_Ctx, RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (M_S_Ctx.Buffer_First) + (RFLX_Types.Bit_Length (M_R_Ctx.Length) * 8 + 16) - 1, Length => M_R_Ctx.Length, Extended => True); - if Test.Message.Valid_Next (M_R_Ctx, Test.Message.F_Data) then - if Test.Message.Valid_Length (M_S_Ctx, Test.Message.F_Data, RFLX_Types.To_Length (Test.Message.Field_Size (M_R_Ctx, Test.Message.F_Data))) then - if Test.Message.Structural_Valid (M_R_Ctx, Test.Message.F_Data) then + if RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_First) + 1 >= RFLX_Types.Bit_Length (Ctx.P.M_R_Ctx.Length) * 8 + 16 then + Test.Message.Reset (Ctx.P.M_S_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.M_S_Ctx.Buffer_First) + (RFLX_Types.Bit_Length (Ctx.P.M_R_Ctx.Length) * 8 + 16) - 1, Length => Ctx.P.M_R_Ctx.Length, Extended => True); + if Test.Message.Valid_Next (Ctx.P.M_R_Ctx, Test.Message.F_Data) then + if Test.Message.Valid_Length (Ctx.P.M_S_Ctx, Test.Message.F_Data, RFLX_Types.To_Length (Test.Message.Field_Size (Ctx.P.M_R_Ctx, Test.Message.F_Data))) then + if Test.Message.Structural_Valid (Ctx.P.M_R_Ctx, Test.Message.F_Data) then declare + pragma Warnings (Off, "is not modified, could be declared constant"); + RFLX_Ctx_P_M_R_Ctx_Tmp : Test.Message.Context := Ctx.P.M_R_Ctx; + pragma Warnings (On, "is not modified, could be declared constant"); function RFLX_Process_Data_Pre (Length : RFLX_Types.Length) return Boolean is - (Test.Message.Has_Buffer (M_R_Ctx) - and then Test.Message.Structural_Valid (M_R_Ctx, Test.Message.F_Data) - and then Length >= RFLX_Types.To_Length (Test.Message.Field_Size (M_R_Ctx, Test.Message.F_Data))); + (Test.Message.Has_Buffer (RFLX_Ctx_P_M_R_Ctx_Tmp) + and then Test.Message.Structural_Valid (RFLX_Ctx_P_M_R_Ctx_Tmp, Test.Message.F_Data) + and then Length >= RFLX_Types.To_Length (Test.Message.Field_Size (RFLX_Ctx_P_M_R_Ctx_Tmp, Test.Message.F_Data))); procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes) with Pre => RFLX_Process_Data_Pre (Data'Length) is begin - Test.Message.Get_Data (M_R_Ctx, Data); + Test.Message.Get_Data (RFLX_Ctx_P_M_R_Ctx_Tmp, Data); end RFLX_Process_Data; procedure RFLX_Test_Message_Set_Data is new Test.Message.Generic_Set_Data (RFLX_Process_Data, RFLX_Process_Data_Pre); begin - RFLX_Test_Message_Set_Data (M_S_Ctx, RFLX_Types.To_Length (Test.Message.Field_Size (M_R_Ctx, Test.Message.F_Data))); + RFLX_Test_Message_Set_Data (Ctx.P.M_S_Ctx, RFLX_Types.To_Length (Test.Message.Field_Size (RFLX_Ctx_P_M_R_Ctx_Tmp, Test.Message.F_Data))); + Ctx.P.M_R_Ctx := RFLX_Ctx_P_M_R_Ctx_Tmp; end; - if Test.Message.Valid_Length (M_S_Ctx, Test.Message.F_Extension, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then - Test.Message.Set_Extension (M_S_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + if Test.Message.Valid_Length (Ctx.P.M_S_Ctx, Test.Message.F_Extension, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then + Test.Message.Set_Extension (Ctx.P.M_S_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; return; end if; else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; return; end if; else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; return; end if; else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; return; end if; else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; return; end if; else - P_Next_State := S_Error; + Ctx.P.Next_State := S_Error; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Error (P_Next_State : out State) with + procedure Error (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Error; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is M_R_Buffer : RFLX_Types.Bytes_Ptr; M_S_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - M_R_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + M_R_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Test.Message.Initialize (M_R_Ctx, M_R_Buffer, Length => Test.Length'First, Extended => Boolean'First); - M_S_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Test.Message.Initialize (Ctx.P.M_R_Ctx, M_R_Buffer, Length => Test.Length'First, Extended => Boolean'First); + M_S_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Test.Message.Initialize (M_S_Ctx, M_S_Buffer, Length => Test.Length'First, Extended => Boolean'First); - P_Next_State := S_Start; + Test.Message.Initialize (Ctx.P.M_S_Ctx, M_S_Buffer, Length => Test.Length'First, Extended => Boolean'First); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is M_R_Buffer : RFLX_Types.Bytes_Ptr; M_S_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""M_R_Ctx"""); - pragma Warnings (Off, """M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Test.Message.Take_Buffer (M_R_Ctx, M_R_Buffer); - pragma Warnings (On, """M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_R_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := M_R_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""M_S_Ctx"""); - pragma Warnings (Off, """M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Test.Message.Take_Buffer (M_S_Ctx, M_S_Buffer); - pragma Warnings (On, """M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_S_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := M_S_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Test.Message.Take_Buffer (Ctx.P.M_R_Ctx, M_R_Buffer); + pragma Warnings (On, """Ctx.P.M_R_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := M_R_Buffer; + pragma Warnings (Off, """Ctx.P.M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Test.Message.Take_Buffer (Ctx.P.M_S_Ctx, M_S_Buffer); + pragma Warnings (On, """Ctx.P.M_S_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := M_S_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => null; when S_Receive => - Test.Message.Reset (M_R_Ctx, M_R_Ctx.First, M_R_Ctx.First - 1, M_R_Ctx.Length, M_R_Ctx.Extended); + Test.Message.Reset (Ctx.P.M_R_Ctx, Ctx.P.M_R_Ctx.First, Ctx.P.M_R_Ctx.First - 1, Ctx.P.M_R_Ctx.Length, Ctx.P.M_R_Ctx.Extended); when S_Process | S_Reply | S_Error | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Receive => - Receive (P_Next_State); + Receive (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Error => - Error (P_Next_State); + Error (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Receive | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Receive | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_C => - (case P_Next_State is - when S_Reply => - Test.Message.Structural_Valid_Message (M_S_Ctx) - and Test.Message.Byte_Size (M_S_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_C => - (case P_Next_State is - when S_Reply => - Test.Message.Byte_Size (M_S_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -245,40 +224,27 @@ is Buffer := (others => 0); case Chan is when C_C => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Test_Message_Read (M_S_Ctx); + Test_Message_Read (Ctx.P.M_S_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_C => - (case P_Next_State is - when S_Receive => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_C => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -291,9 +257,9 @@ is begin case Chan is when C_C => - case P_Next_State is + case Ctx.P.Next_State is when S_Receive => - Test_Message_Write (M_R_Ctx, Offset); + Test_Message_Write (Ctx.P.M_R_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/parameterized_messages/generated/rflx-test-session.ads b/tests/integration/parameterized_messages/generated/rflx-test-session.ads index 608f57f902..2a163d929d 100644 --- a/tests/integration/parameterized_messages/generated/rflx-test-session.ads +++ b/tests/integration/parameterized_messages/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Test; with RFLX.Test.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,108 +18,152 @@ is type State is (S_Start, S_Receive, S_Process, S_Reply, S_Error, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - M_R_Ctx : Test.Message.Context; - - M_S_Ctx : Test.Message.Context; - - function Uninitialized return Boolean is - (not Test.Message.Has_Buffer (M_R_Ctx) - and not Test.Message.Has_Buffer (M_S_Ctx)); - - function Initialized return Boolean is - (Test.Message.Has_Buffer (M_R_Ctx) - and then M_R_Ctx.Buffer_First = RFLX_Types.Index'First - and then M_R_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Message.Has_Buffer (M_S_Ctx) - and then M_S_Ctx.Buffer_First = RFLX_Types.Index'First - and then M_S_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + M_R_Ctx : Test.Message.Context; + M_S_Ctx : Test.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Test.Message.Has_Buffer (Ctx.P.M_R_Ctx) + and not Test.Message.Has_Buffer (Ctx.P.M_S_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Test.Message.Has_Buffer (Ctx.P.M_R_Ctx) + and then Ctx.P.M_R_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.M_R_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Message.Has_Buffer (Ctx.P.M_S_Ctx) + and then Ctx.P.M_S_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.M_S_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_C => + (case Ctx.P.Next_State is + when S_Reply => + Test.Message.Structural_Valid_Message (Ctx.P.M_S_Ctx) + and Test.Message.Byte_Size (Ctx.P.M_S_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_C => + (case Ctx.P.Next_State is + when S_Reply => + Test.Message.Byte_Size (Ctx.P.M_S_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_C => + (case Ctx.P.Next_State is + when S_Receive => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_C => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.adb b/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.adb index 9024bb3698..85d68b5b9b 100644 --- a/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.adb +++ b/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.ads b/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.ads index 7ab793148d..3355bcb4b1 100644 --- a/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.ads +++ b/tests/integration/parameterized_messages/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,20 +22,30 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_append_unconstrained/generated/rflx-test-session.adb b/tests/integration/session_append_unconstrained/generated/rflx-test-session.adb index 8904b2dcb2..70f9f22486 100644 --- a/tests/integration/session_append_unconstrained/generated/rflx-test-session.adb +++ b/tests/integration/session_append_unconstrained/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal.Options; @@ -9,34 +10,30 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is Options_Ctx : Universal.Options.Context; RFLX_Exception : Boolean := False; Options_Buffer : RFLX_Types.Bytes_Ptr; begin - Options_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Options_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); Universal.Options.Initialize (Options_Ctx, Options_Buffer); if not Universal.Options.Has_Element (Options_Ctx) or Universal.Options.Available_Space (Options_Ctx) < 32 then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; declare @@ -50,37 +47,27 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Options_Ctx"""); pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); Universal.Options.Update (Options_Ctx, RFLX_Element_Options_Ctx); pragma Warnings (On, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Options_Ctx"""); end; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; if not Universal.Options.Has_Element (Options_Ctx) or Universal.Options.Available_Space (Options_Ctx) < 40 then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; declare @@ -94,37 +81,27 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Options_Ctx"""); pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); Universal.Options.Update (Options_Ctx, RFLX_Element_Options_Ctx); pragma Warnings (On, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Options_Ctx"""); end; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; if not Universal.Options.Has_Element (Options_Ctx) or Universal.Options.Available_Space (Options_Ctx) < 8 then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; declare @@ -132,151 +109,111 @@ is begin Universal.Options.Switch (Options_Ctx, RFLX_Element_Options_Ctx); Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Null); - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Options_Ctx"""); pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); Universal.Options.Update (Options_Ctx, RFLX_Element_Options_Ctx); pragma Warnings (On, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Options_Ctx"""); end; if Universal.Options.Size (Options_Ctx) <= 32768 and then Universal.Options.Size (Options_Ctx) mod RFLX_Types.Byte'Size = 0 then - if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= Universal.Options.Size (Options_Ctx) + 8 then - Universal.Message.Reset (Message_Ctx, RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + (Universal.Options.Size (Options_Ctx) + 8) - 1); - Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Unconstrained_Options); - if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Options, RFLX_Types.To_Length (Universal.Options.Size (Options_Ctx))) then - Universal.Message.Set_Options (Message_Ctx, Options_Ctx); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 1 >= Universal.Options.Size (Options_Ctx) + 8 then + Universal.Message.Reset (Ctx.P.Message_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + (Universal.Options.Size (Options_Ctx) + 8) - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Unconstrained_Options); + if Universal.Message.Valid_Length (Ctx.P.Message_Ctx, Universal.Message.F_Options, RFLX_Types.To_Length (Universal.Options.Size (Options_Ctx))) then + Universal.Message.Set_Options (Ctx.P.Message_Ctx, Options_Ctx); else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; return; end if; - P_Next_State := S_Reply; - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); + Ctx.P.Next_State := S_Reply; pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Options_Buffer; end Start; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -294,9 +231,9 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; diff --git a/tests/integration/session_append_unconstrained/generated/rflx-test-session.ads b/tests/integration/session_append_unconstrained/generated/rflx-test-session.ads index 30c2baae1f..b083ccd2a9 100644 --- a/tests/integration/session_append_unconstrained/generated/rflx-test-session.ads +++ b/tests/integration/session_append_unconstrained/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,86 +18,117 @@ is type State is (S_Start, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); end RFLX.Test.Session; diff --git a/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.adb b/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.adb index 9024bb3698..85d68b5b9b 100644 --- a/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.ads b/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.ads index bd9245ecf0..f252db0266 100644 --- a/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_append_unconstrained/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,20 +22,30 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 /= null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 /= null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_binding/generated/rflx-test-session.adb b/tests/integration/session_binding/generated/rflx-test-session.adb index 1525e12a07..51ce420235 100644 --- a/tests/integration/session_binding/generated/rflx-test-session.adb +++ b/tests/integration/session_binding/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -10,30 +11,30 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); if - (Universal.Message.Structural_Valid_Message (Message_Ctx) - and then Universal.Message.Get_Message_Type (Message_Ctx) = Universal.MT_Data) - and then Universal.Message.Get_Length (Message_Ctx) = 1 + (Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and then Universal.Message.Get_Message_Type (Ctx.P.Message_Ctx) = Universal.MT_Data) + and then Universal.Message.Get_Length (Ctx.P.Message_Ctx) = 1 then - P_Next_State := S_Process; + Ctx.P.Next_State := S_Process; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is RFLX_Exception : Boolean := False; begin @@ -50,12 +51,12 @@ is Size => 1 * RFLX_Types.Byte'Size; begin - if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= Opaque'Size + 24 then - Universal.Message.Reset (Message_Ctx, RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + (Opaque'Size + 24) - 1); - Universal.Message.Set_Message_Type (Message_Ctx, MT); - Universal.Message.Set_Length (Message_Ctx, Length); - if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (Opaque'Size)) then - Universal.Message.Set_Data (Message_Ctx, Opaque); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 1 >= Opaque'Size + 24 then + Universal.Message.Reset (Ctx.P.Message_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + (Opaque'Size + 24) - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, MT); + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Length); + if Universal.Message.Valid_Length (Ctx.P.Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (Opaque'Size)) then + Universal.Message.Set_Data (Ctx.P.Message_Ctx, Opaque); else RFLX_Exception := True; end if; @@ -66,113 +67,91 @@ is end; end; if RFLX_Exception then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -190,40 +169,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -236,9 +202,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_binding/generated/rflx-test-session.ads b/tests/integration/session_binding/generated/rflx-test-session.ads index 54ff073742..6cf5e99e1f 100644 --- a/tests/integration/session_binding/generated/rflx-test-session.ads +++ b/tests/integration/session_binding/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,147 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_binding/generated/rflx-test-session_allocator.adb b/tests/integration/session_binding/generated/rflx-test-session_allocator.adb index a55f641bf8..e1ad070138 100644 --- a/tests/integration/session_binding/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_binding/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_binding/generated/rflx-test-session_allocator.ads b/tests/integration/session_binding/generated/rflx-test-session_allocator.ads index 17e830e759..2d0256b13a 100644 --- a/tests/integration/session_binding/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_binding/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_channel_multiplexing/generated/rflx-test-session.adb b/tests/integration/session_channel_multiplexing/generated/rflx-test-session.adb index d656983418..cbdfb059e0 100644 --- a/tests/integration/session_channel_multiplexing/generated/rflx-test-session.adb +++ b/tests/integration/session_channel_multiplexing/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,160 +8,125 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_1_Ctx); - Universal.Message.Verify_Message (Message_2_Ctx); - if Universal.Message.Byte_Size (Message_1_Ctx) > 0 then - P_Next_State := S_Reply_1; - elsif Universal.Message.Byte_Size (Message_2_Ctx) > 0 then - P_Next_State := S_Reply_2; + Universal.Message.Verify_Message (Ctx.P.Message_1_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_2_Ctx); + if Universal.Message.Byte_Size (Ctx.P.Message_1_Ctx) > 0 then + Ctx.P.Next_State := S_Reply_1; + elsif Universal.Message.Byte_Size (Ctx.P.Message_2_Ctx) > 0 then + Ctx.P.Next_State := S_Reply_2; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Reply_1 (P_Next_State : out State) with + procedure Reply_1 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Start; + Ctx.P.Next_State := S_Start; end Reply_1; - procedure Reply_2 (P_Next_State : out State) with + procedure Reply_2 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Start; + Ctx.P.Next_State := S_Start; end Reply_2; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_1_Buffer : RFLX_Types.Bytes_Ptr; Message_2_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_1_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_1_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_1_Ctx, Message_1_Buffer); - Message_2_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Universal.Message.Initialize (Ctx.P.Message_1_Ctx, Message_1_Buffer); + Message_2_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_2_Ctx, Message_2_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_2_Ctx, Message_2_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_1_Buffer : RFLX_Types.Bytes_Ptr; Message_2_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_1_Ctx"""); - pragma Warnings (Off, """Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_1_Ctx, Message_1_Buffer); - pragma Warnings (On, """Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_1_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_1_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_2_Ctx"""); - pragma Warnings (Off, """Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_2_Ctx, Message_2_Buffer); - pragma Warnings (On, """Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_2_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Message_2_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_1_Ctx, Message_1_Buffer); + pragma Warnings (On, """Ctx.P.Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_1_Buffer; + pragma Warnings (Off, """Ctx.P.Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_2_Ctx, Message_2_Buffer); + pragma Warnings (On, """Ctx.P.Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := Message_2_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_1_Ctx, Message_1_Ctx.First, Message_1_Ctx.First - 1); - Universal.Message.Reset (Message_2_Ctx, Message_2_Ctx.First, Message_2_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_1_Ctx, Ctx.P.Message_1_Ctx.First, Ctx.P.Message_1_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_2_Ctx, Ctx.P.Message_2_Ctx.First, Ctx.P.Message_2_Ctx.First - 1); when S_Reply_1 | S_Reply_2 | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Reply_1 => - Reply_1 (P_Next_State); + Reply_1 (Ctx); when S_Reply_2 => - Reply_2 (P_Next_State); + Reply_2 (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply_1 | S_Reply_2); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply_1 | S_Reply_2); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_I_1 | C_I_2 => - False, - when C_O => - (case P_Next_State is - when S_Reply_1 => - Universal.Message.Structural_Valid_Message (Message_1_Ctx) - and Universal.Message.Byte_Size (Message_1_Ctx) > 0, - when S_Reply_2 => - Universal.Message.Structural_Valid_Message (Message_2_Ctx) - and Universal.Message.Byte_Size (Message_2_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_I_1 | C_I_2 => - raise Program_Error, - when C_O => - (case P_Next_State is - when S_Reply_1 => - Universal.Message.Byte_Size (Message_1_Ctx), - when S_Reply_2 => - Universal.Message.Byte_Size (Message_2_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -180,46 +146,29 @@ is when C_I_1 | C_I_2 => raise Program_Error; when C_O => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply_1 => - Universal_Message_Read (Message_1_Ctx); + Universal_Message_Read (Ctx.P.Message_1_Ctx); when S_Reply_2 => - Universal_Message_Read (Message_2_Ctx); + Universal_Message_Read (Ctx.P.Message_2_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_I_1 | C_I_2 => - (case P_Next_State is - when S_Start => - True, - when others => - False), - when C_O => - False)); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_I_1 | C_I_2 => - 4096, - when C_O => - 0)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -232,16 +181,16 @@ is begin case Chan is when C_I_1 => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_1_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_1_Ctx, Offset); when others => raise Program_Error; end case; when C_I_2 => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_2_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_2_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_channel_multiplexing/generated/rflx-test-session.ads b/tests/integration/session_channel_multiplexing/generated/rflx-test-session.ads index c1f60c3ccf..4373606aa2 100644 --- a/tests/integration/session_channel_multiplexing/generated/rflx-test-session.ads +++ b/tests/integration/session_channel_multiplexing/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,108 +18,165 @@ is type State is (S_Start, S_Reply_1, S_Reply_2, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_1_Ctx : Universal.Message.Context; - - Message_2_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_1_Ctx) - and not Universal.Message.Has_Buffer (Message_2_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_1_Ctx) - and then Message_1_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_1_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Universal.Message.Has_Buffer (Message_2_Ctx) - and then Message_2_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_1_Ctx : Universal.Message.Context; + Message_2_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_1_Ctx) + and not Universal.Message.Has_Buffer (Ctx.P.Message_2_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_1_Ctx) + and then Ctx.P.Message_1_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_1_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Universal.Message.Has_Buffer (Ctx.P.Message_2_Ctx) + and then Ctx.P.Message_2_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_I_1 | C_I_2 => + False, + when C_O => + (case Ctx.P.Next_State is + when S_Reply_1 => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_1_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_1_Ctx) > 0, + when S_Reply_2 => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_2_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_2_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_I_1 | C_I_2 => + raise Program_Error, + when C_O => + (case Ctx.P.Next_State is + when S_Reply_1 => + Universal.Message.Byte_Size (Ctx.P.Message_1_Ctx), + when S_Reply_2 => + Universal.Message.Byte_Size (Ctx.P.Message_2_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_I_1 | C_I_2 => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False), + when C_O => + False)); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_I_1 | C_I_2 => + 4096, + when C_O => + 0)); end RFLX.Test.Session; diff --git a/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.adb b/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.adb index 9024bb3698..85d68b5b9b 100644 --- a/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.ads b/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.ads index 7ab793148d..3355bcb4b1 100644 --- a/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_channel_multiplexing/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,20 +22,30 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_channels/generated/rflx-test-session.adb b/tests/integration/session_channels/generated/rflx-test-session.adb index ebb7d95fca..a37de66e9d 100644 --- a/tests/integration/session_channels/generated/rflx-test-session.adb +++ b/tests/integration/session_channels/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,124 +8,98 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); - if Universal.Message.Byte_Size (Message_Ctx) > 0 then - P_Next_State := S_Reply; + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); + if Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0 then + Ctx.P.Next_State := S_Reply; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Start; + Ctx.P.Next_State := S_Start; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_I => - False, - when C_O => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_I => - raise Program_Error, - when C_O => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -144,44 +119,27 @@ is when C_I => raise Program_Error; when C_O => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_I => - (case P_Next_State is - when S_Start => - True, - when others => - False), - when C_O => - False)); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_I => - 4096, - when C_O => - 0)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -194,9 +152,9 @@ is begin case Chan is when C_I => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_channels/generated/rflx-test-session.ads b/tests/integration/session_channels/generated/rflx-test-session.ads index b914dba167..e376c8fc9f 100644 --- a/tests/integration/session_channels/generated/rflx-test-session.ads +++ b/tests/integration/session_channels/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,155 @@ is type State is (S_Start, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_I => + False, + when C_O => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_I => + raise Program_Error, + when C_O => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_I => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False), + when C_O => + False)); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_I => + 4096, + when C_O => + 0)); end RFLX.Test.Session; diff --git a/tests/integration/session_channels/generated/rflx-test-session_allocator.adb b/tests/integration/session_channels/generated/rflx-test-session_allocator.adb index a55f641bf8..e1ad070138 100644 --- a/tests/integration/session_channels/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_channels/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_channels/generated/rflx-test-session_allocator.ads b/tests/integration/session_channels/generated/rflx-test-session_allocator.ads index 17e830e759..2d0256b13a 100644 --- a/tests/integration/session_channels/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_channels/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.adb b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.adb index 5ad8715623..2887697583 100644 --- a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.adb +++ b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -14,55 +15,55 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); if - Universal.Message.Structural_Valid_Message (Message_Ctx) - and then Universal.Message.Get_Message_Type (Message_Ctx) = Universal.MT_Options + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and then Universal.Message.Get_Message_Type (Ctx.P.Message_Ctx) = Universal.MT_Options then - P_Next_State := S_Process; + Ctx.P.Next_State := S_Process; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is Option_Types_Ctx : Universal.Option_Types.Context; RFLX_Exception : Boolean := False; Option_Types_Buffer : RFLX_Types.Bytes_Ptr; begin - Option_Types_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Option_Types_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); Universal.Option_Types.Initialize (Option_Types_Ctx, Option_Types_Buffer); - if Universal.Message.Structural_Valid_Message (Message_Ctx) then + if Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) then declare RFLX_Message_Options_Ctx : Universal.Options.Context; RFLX_Message_Options_Buffer : RFLX_Types.Bytes_Ptr; begin - RFLX_Message_Options_Buffer := Test.Session_Allocator.Slot_Ptr_3; + RFLX_Message_Options_Buffer := Ctx.P.Slots.Slot_Ptr_3; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := null; + Ctx.P.Slots.Slot_Ptr_3 := null; pragma Warnings (On, "unused assignment"); - if Universal.Message.Byte_Size (Message_Ctx) <= RFLX_Message_Options_Buffer'Length then - Universal.Message.Copy (Message_Ctx, RFLX_Message_Options_Buffer.all (RFLX_Message_Options_Buffer'First .. RFLX_Message_Options_Buffer'First + RFLX_Types.Index (Universal.Message.Byte_Size (Message_Ctx) + 1) - 2)); + if Universal.Message.Byte_Size (Ctx.P.Message_Ctx) <= RFLX_Message_Options_Buffer'Length then + Universal.Message.Copy (Ctx.P.Message_Ctx, RFLX_Message_Options_Buffer.all (RFLX_Message_Options_Buffer'First .. RFLX_Message_Options_Buffer'First + RFLX_Types.Index (Universal.Message.Byte_Size (Ctx.P.Message_Ctx) + 1) - 2)); else RFLX_Exception := True; end if; - if Universal.Message.Structural_Valid (Message_Ctx, Universal.Message.F_Options) then - Universal.Options.Initialize (RFLX_Message_Options_Ctx, RFLX_Message_Options_Buffer, Universal.Message.Field_First (Message_Ctx, Universal.Message.F_Options), Universal.Message.Field_Last (Message_Ctx, Universal.Message.F_Options)); + if Universal.Message.Structural_Valid (Ctx.P.Message_Ctx, Universal.Message.F_Options) then + Universal.Options.Initialize (RFLX_Message_Options_Ctx, RFLX_Message_Options_Buffer, Universal.Message.Field_First (Ctx.P.Message_Ctx, Universal.Message.F_Options), Universal.Message.Field_Last (Ctx.P.Message_Ctx, Universal.Message.F_Options)); while Universal.Options.Has_Element (RFLX_Message_Options_Ctx) loop pragma Loop_Invariant (Universal.Options.Has_Buffer (RFLX_Message_Options_Ctx)); pragma Loop_Invariant (Universal.Option_Types.Has_Buffer (Option_Types_Ctx)); @@ -93,220 +94,164 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""E_Ctx"""); pragma Warnings (Off, """E_Ctx"" is set by ""Update"" but not used after the call"); Universal.Options.Update (RFLX_Message_Options_Ctx, E_Ctx); pragma Warnings (On, """E_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""E_Ctx"""); end; exit when RFLX_Exception; end loop; - pragma Warnings (Off, "unused assignment to ""RFLX_Message_Options_Ctx"""); pragma Warnings (Off, """RFLX_Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (RFLX_Message_Options_Ctx, RFLX_Message_Options_Buffer); pragma Warnings (On, """RFLX_Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Message_Options_Ctx"""); else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := RFLX_Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_3 := RFLX_Message_Options_Buffer; end; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; return; end if; if Universal.Option_Types.Size (Option_Types_Ctx) <= 32768 and then Universal.Option_Types.Size (Option_Types_Ctx) mod RFLX_Types.Byte'Size = 0 then - if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= Universal.Option_Types.Size (Option_Types_Ctx) + 24 then - Universal.Message.Reset (Message_Ctx, RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + (Universal.Option_Types.Size (Option_Types_Ctx) + 24) - 1); - Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Option_Types); - Universal.Message.Set_Length (Message_Ctx, Universal.Length (Universal.Option_Types.Size (Option_Types_Ctx) / 8)); - if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Option_Types, RFLX_Types.To_Length (Universal.Option_Types.Size (Option_Types_Ctx))) then - Universal.Message.Set_Option_Types (Message_Ctx, Option_Types_Ctx); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 1 >= Universal.Option_Types.Size (Option_Types_Ctx) + 24 then + Universal.Message.Reset (Ctx.P.Message_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + (Universal.Option_Types.Size (Option_Types_Ctx) + 24) - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Option_Types); + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Universal.Length (Universal.Option_Types.Size (Option_Types_Ctx) / 8)); + if Universal.Message.Valid_Length (Ctx.P.Message_Ctx, Universal.Message.F_Option_Types, RFLX_Types.To_Length (Universal.Option_Types.Size (Option_Types_Ctx))) then + Universal.Message.Set_Option_Types (Ctx.P.Message_Ctx, Option_Types_Ctx); else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; return; end if; - P_Next_State := S_Reply; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Reply; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := Option_Types_Buffer; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -324,40 +269,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -370,9 +302,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.ads b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.ads index 54ff073742..6cf5e99e1f 100644 --- a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.ads +++ b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,147 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.adb b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.adb index 823786674f..8d6547ec8d 100644 --- a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.adb @@ -5,20 +5,24 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_3 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; - Slot_Ptr_3 := Slot_3'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; + S.Slot_Ptr_3 := M.Slot_3'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + S.Slot_Ptr_3 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.ads b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.ads index 556679e5d1..3eae510d36 100644 --- a/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_comprehension_on_message_field/generated/rflx-test-session_allocator.ads @@ -10,7 +10,12 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_3 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,24 +23,34 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + Slot_Ptr_3 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null + and S.Slot_Ptr_3 /= null); - Slot_Ptr_3 : Slot_Ptr_Type_4096; + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null - and Slot_Ptr_3 /= null); + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); - procedure Initialize with + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 /= null - and Slot_Ptr_3 /= null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 /= null + and S.Slot_Ptr_3 /= null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.adb b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.adb index 09e7704b8a..618de338e1 100644 --- a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.adb +++ b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -12,25 +13,25 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is RFLX_Exception : Boolean := False; begin if - not Universal.Options.Has_Element (Options_Ctx) - or Universal.Options.Available_Space (Options_Ctx) < 32 + not Universal.Options.Has_Element (Ctx.P.Options_Ctx) + or Universal.Options.Available_Space (Ctx.P.Options_Ctx) < 32 then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; declare RFLX_Element_Options_Ctx : Universal.Option.Context; begin - Universal.Options.Switch (Options_Ctx, RFLX_Element_Options_Ctx); + Universal.Options.Switch (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); Universal.Option.Set_Length (RFLX_Element_Options_Ctx, 1); if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then @@ -38,45 +39,41 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Options_Ctx"""); pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - Universal.Options.Update (Options_Ctx, RFLX_Element_Options_Ctx); + Universal.Options.Update (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); pragma Warnings (On, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Options_Ctx"""); end; if RFLX_Exception then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if - not Universal.Options.Has_Element (Options_Ctx) - or Universal.Options.Available_Space (Options_Ctx) < 8 + not Universal.Options.Has_Element (Ctx.P.Options_Ctx) + or Universal.Options.Available_Space (Ctx.P.Options_Ctx) < 8 then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; declare RFLX_Element_Options_Ctx : Universal.Option.Context; begin - Universal.Options.Switch (Options_Ctx, RFLX_Element_Options_Ctx); + Universal.Options.Switch (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Null); - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Options_Ctx"""); pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - Universal.Options.Update (Options_Ctx, RFLX_Element_Options_Ctx); + Universal.Options.Update (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); pragma Warnings (On, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Options_Ctx"""); end; if - not Universal.Options.Has_Element (Options_Ctx) - or Universal.Options.Available_Space (Options_Ctx) < 40 + not Universal.Options.Has_Element (Ctx.P.Options_Ctx) + or Universal.Options.Available_Space (Ctx.P.Options_Ctx) < 40 then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; declare RFLX_Element_Options_Ctx : Universal.Option.Context; begin - Universal.Options.Switch (Options_Ctx, RFLX_Element_Options_Ctx); + Universal.Options.Switch (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); Universal.Option.Set_Length (RFLX_Element_Options_Ctx, 2); if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then @@ -84,24 +81,22 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Options_Ctx"""); pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - Universal.Options.Update (Options_Ctx, RFLX_Element_Options_Ctx); + Universal.Options.Update (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); pragma Warnings (On, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Options_Ctx"""); end; if RFLX_Exception then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Process; + Ctx.P.Next_State := S_Process; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is Option_Types_Ctx : Universal.Option_Types.Context; Message_Options_Ctx : Universal.Options.Context; @@ -109,31 +104,31 @@ is Option_Types_Buffer : RFLX_Types.Bytes_Ptr; Message_Options_Buffer : RFLX_Types.Bytes_Ptr; begin - Option_Types_Buffer := Test.Session_Allocator.Slot_Ptr_4; + Option_Types_Buffer := Ctx.P.Slots.Slot_Ptr_4; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := null; + Ctx.P.Slots.Slot_Ptr_4 := null; pragma Warnings (On, "unused assignment"); Universal.Option_Types.Initialize (Option_Types_Ctx, Option_Types_Buffer); - Message_Options_Buffer := Test.Session_Allocator.Slot_Ptr_6; + Message_Options_Buffer := Ctx.P.Slots.Slot_Ptr_6; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := null; + Ctx.P.Slots.Slot_Ptr_6 := null; pragma Warnings (On, "unused assignment"); Universal.Options.Initialize (Message_Options_Ctx, Message_Options_Buffer); - if Universal.Options.Valid (Options_Ctx) then + if Universal.Options.Valid (Ctx.P.Options_Ctx) then declare RFLX_Copy_Options_Ctx : Universal.Options.Context; RFLX_Copy_Options_Buffer : RFLX_Types.Bytes_Ptr; begin - RFLX_Copy_Options_Buffer := Test.Session_Allocator.Slot_Ptr_5; + RFLX_Copy_Options_Buffer := Ctx.P.Slots.Slot_Ptr_5; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_5 := null; + Ctx.P.Slots.Slot_Ptr_5 := null; pragma Warnings (On, "unused assignment"); - if Universal.Options.Byte_Size (Options_Ctx) <= RFLX_Copy_Options_Buffer'Length then - Universal.Options.Copy (Options_Ctx, RFLX_Copy_Options_Buffer.all (RFLX_Copy_Options_Buffer'First .. RFLX_Copy_Options_Buffer'First + RFLX_Types.Index (Universal.Options.Byte_Size (Options_Ctx) + 1) - 2)); + if Universal.Options.Byte_Size (Ctx.P.Options_Ctx) <= RFLX_Copy_Options_Buffer'Length then + Universal.Options.Copy (Ctx.P.Options_Ctx, RFLX_Copy_Options_Buffer.all (RFLX_Copy_Options_Buffer'First .. RFLX_Copy_Options_Buffer'First + RFLX_Types.Index (Universal.Options.Byte_Size (Ctx.P.Options_Ctx) + 1) - 2)); else RFLX_Exception := True; end if; - Universal.Options.Initialize (RFLX_Copy_Options_Ctx, RFLX_Copy_Options_Buffer, RFLX_Types.To_First_Bit_Index (RFLX_Copy_Options_Buffer'First), Universal.Options.Sequence_Last (Options_Ctx)); + Universal.Options.Initialize (RFLX_Copy_Options_Ctx, RFLX_Copy_Options_Buffer, RFLX_Types.To_First_Bit_Index (RFLX_Copy_Options_Buffer'First), Universal.Options.Sequence_Last (Ctx.P.Options_Ctx)); while Universal.Options.Has_Element (RFLX_Copy_Options_Ctx) loop pragma Loop_Invariant (Universal.Options.Has_Buffer (RFLX_Copy_Options_Ctx)); pragma Loop_Invariant (Universal.Option_Types.Has_Buffer (Option_Types_Ctx)); @@ -164,168 +159,114 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""E_Ctx"""); pragma Warnings (Off, """E_Ctx"" is set by ""Update"" but not used after the call"); Universal.Options.Update (RFLX_Copy_Options_Ctx, E_Ctx); pragma Warnings (On, """E_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""E_Ctx"""); end; exit when RFLX_Exception; end loop; - pragma Warnings (Off, "unused assignment to ""RFLX_Copy_Options_Ctx"""); pragma Warnings (Off, """RFLX_Copy_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (RFLX_Copy_Options_Ctx, RFLX_Copy_Options_Buffer); pragma Warnings (On, """RFLX_Copy_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Copy_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_5 := RFLX_Copy_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_5 := RFLX_Copy_Options_Buffer; end; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; if Universal.Option_Types.Size (Option_Types_Ctx) <= 64768 and then Universal.Option_Types.Size (Option_Types_Ctx) mod RFLX_Types.Byte'Size = 0 then - if RFLX_Types.To_First_Bit_Index (Message_1_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_1_Ctx.Buffer_First) + 1 >= Universal.Option_Types.Size (Option_Types_Ctx) + 24 then - Universal.Message.Reset (Message_1_Ctx, RFLX_Types.To_First_Bit_Index (Message_1_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_1_Ctx.Buffer_First) + (Universal.Option_Types.Size (Option_Types_Ctx) + 24) - 1); - Universal.Message.Set_Message_Type (Message_1_Ctx, Universal.MT_Option_Types); - Universal.Message.Set_Length (Message_1_Ctx, Universal.Length (Universal.Option_Types.Size (Option_Types_Ctx) / 8)); - if Universal.Message.Valid_Length (Message_1_Ctx, Universal.Message.F_Option_Types, RFLX_Types.To_Length (Universal.Option_Types.Size (Option_Types_Ctx))) then - Universal.Message.Set_Option_Types (Message_1_Ctx, Option_Types_Ctx); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_1_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_1_Ctx.Buffer_First) + 1 >= Universal.Option_Types.Size (Option_Types_Ctx) + 24 then + Universal.Message.Reset (Ctx.P.Message_1_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_1_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_1_Ctx.Buffer_First) + (Universal.Option_Types.Size (Option_Types_Ctx) + 24) - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_1_Ctx, Universal.MT_Option_Types); + Universal.Message.Set_Length (Ctx.P.Message_1_Ctx, Universal.Length (Universal.Option_Types.Size (Option_Types_Ctx) / 8)); + if Universal.Message.Valid_Length (Ctx.P.Message_1_Ctx, Universal.Message.F_Option_Types, RFLX_Types.To_Length (Universal.Option_Types.Size (Option_Types_Ctx))) then + Universal.Message.Set_Option_Types (Ctx.P.Message_1_Ctx, Option_Types_Ctx); else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; - if Universal.Options.Valid (Options_Ctx) then + if Universal.Options.Valid (Ctx.P.Options_Ctx) then declare RFLX_Copy_Options_Ctx : Universal.Options.Context; RFLX_Copy_Options_Buffer : RFLX_Types.Bytes_Ptr; begin - RFLX_Copy_Options_Buffer := Test.Session_Allocator.Slot_Ptr_7; + RFLX_Copy_Options_Buffer := Ctx.P.Slots.Slot_Ptr_7; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_7 := null; + Ctx.P.Slots.Slot_Ptr_7 := null; pragma Warnings (On, "unused assignment"); - if Universal.Options.Byte_Size (Options_Ctx) <= RFLX_Copy_Options_Buffer'Length then - Universal.Options.Copy (Options_Ctx, RFLX_Copy_Options_Buffer.all (RFLX_Copy_Options_Buffer'First .. RFLX_Copy_Options_Buffer'First + RFLX_Types.Index (Universal.Options.Byte_Size (Options_Ctx) + 1) - 2)); + if Universal.Options.Byte_Size (Ctx.P.Options_Ctx) <= RFLX_Copy_Options_Buffer'Length then + Universal.Options.Copy (Ctx.P.Options_Ctx, RFLX_Copy_Options_Buffer.all (RFLX_Copy_Options_Buffer'First .. RFLX_Copy_Options_Buffer'First + RFLX_Types.Index (Universal.Options.Byte_Size (Ctx.P.Options_Ctx) + 1) - 2)); else RFLX_Exception := True; end if; - Universal.Options.Initialize (RFLX_Copy_Options_Ctx, RFLX_Copy_Options_Buffer, RFLX_Types.To_First_Bit_Index (RFLX_Copy_Options_Buffer'First), Universal.Options.Sequence_Last (Options_Ctx)); + Universal.Options.Initialize (RFLX_Copy_Options_Ctx, RFLX_Copy_Options_Buffer, RFLX_Types.To_First_Bit_Index (RFLX_Copy_Options_Buffer'First), Universal.Options.Sequence_Last (Ctx.P.Options_Ctx)); while Universal.Options.Has_Element (RFLX_Copy_Options_Ctx) loop pragma Loop_Invariant (Universal.Options.Has_Buffer (RFLX_Copy_Options_Ctx)); pragma Loop_Invariant (Universal.Options.Has_Buffer (Message_Options_Ctx)); @@ -364,304 +305,207 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""E_Ctx"""); pragma Warnings (Off, """E_Ctx"" is set by ""Update"" but not used after the call"); Universal.Options.Update (RFLX_Copy_Options_Ctx, E_Ctx); pragma Warnings (On, """E_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""E_Ctx"""); end; exit when RFLX_Exception; end loop; - pragma Warnings (Off, "unused assignment to ""RFLX_Copy_Options_Ctx"""); pragma Warnings (Off, """RFLX_Copy_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (RFLX_Copy_Options_Ctx, RFLX_Copy_Options_Buffer); pragma Warnings (On, """RFLX_Copy_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Copy_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_7 := RFLX_Copy_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_7 := RFLX_Copy_Options_Buffer; end; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; if Universal.Options.Size (Message_Options_Ctx) <= 32768 and then Universal.Options.Size (Message_Options_Ctx) mod RFLX_Types.Byte'Size = 0 then - if RFLX_Types.To_First_Bit_Index (Message_2_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_2_Ctx.Buffer_First) + 1 >= Universal.Options.Size (Message_Options_Ctx) + 24 then - Universal.Message.Reset (Message_2_Ctx, RFLX_Types.To_First_Bit_Index (Message_2_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_2_Ctx.Buffer_First) + (Universal.Options.Size (Message_Options_Ctx) + 24) - 1); - Universal.Message.Set_Message_Type (Message_2_Ctx, Universal.MT_Options); - Universal.Message.Set_Length (Message_2_Ctx, Universal.Length (Universal.Options.Size (Message_Options_Ctx) / 8)); - if Universal.Message.Valid_Length (Message_2_Ctx, Universal.Message.F_Options, RFLX_Types.To_Length (Universal.Options.Size (Message_Options_Ctx))) then - Universal.Message.Set_Options (Message_2_Ctx, Message_Options_Ctx); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_2_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_2_Ctx.Buffer_First) + 1 >= Universal.Options.Size (Message_Options_Ctx) + 24 then + Universal.Message.Reset (Ctx.P.Message_2_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_2_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_2_Ctx.Buffer_First) + (Universal.Options.Size (Message_Options_Ctx) + 24) - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_2_Ctx, Universal.MT_Options); + Universal.Message.Set_Length (Ctx.P.Message_2_Ctx, Universal.Length (Universal.Options.Size (Message_Options_Ctx) / 8)); + if Universal.Message.Valid_Length (Ctx.P.Message_2_Ctx, Universal.Message.F_Options, RFLX_Types.To_Length (Universal.Options.Size (Message_Options_Ctx))) then + Universal.Message.Set_Options (Ctx.P.Message_2_Ctx, Message_Options_Ctx); else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; return; end if; - P_Next_State := S_Send_1; - pragma Warnings (Off, "unused assignment to ""Option_Types_Ctx"""); + Ctx.P.Next_State := S_Send_1; pragma Warnings (Off, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Option_Types.Take_Buffer (Option_Types_Ctx, Option_Types_Buffer); pragma Warnings (On, """Option_Types_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Option_Types_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Option_Types_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Options_Ctx"""); + Ctx.P.Slots.Slot_Ptr_4 := Option_Types_Buffer; pragma Warnings (Off, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Options.Take_Buffer (Message_Options_Ctx, Message_Options_Buffer); pragma Warnings (On, """Message_Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_6 := Message_Options_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_6 := Message_Options_Buffer; end Process; - procedure Send_1 (P_Next_State : out State) with + procedure Send_1 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Send_2; + Ctx.P.Next_State := S_Send_2; end Send_1; - procedure Send_2 (P_Next_State : out State) with + procedure Send_2 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Send_2; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Options_Buffer : RFLX_Types.Bytes_Ptr; Message_1_Buffer : RFLX_Types.Bytes_Ptr; Message_2_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Options_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Options_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Options.Initialize (Options_Ctx, Options_Buffer); - Message_1_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Universal.Options.Initialize (Ctx.P.Options_Ctx, Options_Buffer); + Message_1_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_1_Ctx, Message_1_Buffer); - Message_2_Buffer := Test.Session_Allocator.Slot_Ptr_3; + Universal.Message.Initialize (Ctx.P.Message_1_Ctx, Message_1_Buffer); + Message_2_Buffer := Ctx.P.Slots.Slot_Ptr_3; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := null; + Ctx.P.Slots.Slot_Ptr_3 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_2_Ctx, Message_2_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_2_Ctx, Message_2_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Options_Buffer : RFLX_Types.Bytes_Ptr; Message_1_Buffer : RFLX_Types.Bytes_Ptr; Message_2_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Options.Take_Buffer (Options_Ctx, Options_Buffer); - pragma Warnings (On, """Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Options_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Options_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_1_Ctx"""); - pragma Warnings (Off, """Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_1_Ctx, Message_1_Buffer); - pragma Warnings (On, """Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_1_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Message_1_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_2_Ctx"""); - pragma Warnings (Off, """Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_2_Ctx, Message_2_Buffer); - pragma Warnings (On, """Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_2_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := Message_2_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Options.Take_Buffer (Ctx.P.Options_Ctx, Options_Buffer); + pragma Warnings (On, """Ctx.P.Options_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Options_Buffer; + pragma Warnings (Off, """Ctx.P.Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_1_Ctx, Message_1_Buffer); + pragma Warnings (On, """Ctx.P.Message_1_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := Message_1_Buffer; + pragma Warnings (Off, """Ctx.P.Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_2_Ctx, Message_2_Buffer); + pragma Warnings (On, """Ctx.P.Message_2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_3 := Message_2_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Send_1 => - Send_1 (P_Next_State); + Send_1 (Ctx); when S_Send_2 => - Send_2 (P_Next_State); + Send_2 (Ctx); when S_Terminated => null; end case; end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Send_1 | S_Send_2); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Send_1 | S_Send_2); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Send_1 => - Universal.Message.Structural_Valid_Message (Message_1_Ctx) - and Universal.Message.Byte_Size (Message_1_Ctx) > 0, - when S_Send_2 => - Universal.Message.Structural_Valid_Message (Message_2_Ctx) - and Universal.Message.Byte_Size (Message_2_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Send_1 => - Universal.Message.Byte_Size (Message_1_Ctx), - when S_Send_2 => - Universal.Message.Byte_Size (Message_2_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -679,11 +523,11 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Send_1 => - Universal_Message_Read (Message_1_Ctx); + Universal_Message_Read (Ctx.P.Message_1_Ctx); when S_Send_2 => - Universal_Message_Read (Message_2_Ctx); + Universal_Message_Read (Ctx.P.Message_2_Ctx); when others => raise Program_Error; end case; diff --git a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.ads b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.ads index 37da80e873..e383313e0e 100644 --- a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.ads +++ b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -6,11 +7,8 @@ with RFLX.Universal; with RFLX.Universal.Options; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -21,98 +19,132 @@ is type State is (S_Start, S_Process, S_Send_1, S_Send_2, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Options_Ctx : Universal.Options.Context; - - Message_1_Ctx : Universal.Message.Context; - - Message_2_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Options.Has_Buffer (Options_Ctx) - and not Universal.Message.Has_Buffer (Message_1_Ctx) - and not Universal.Message.Has_Buffer (Message_2_Ctx)); - - function Initialized return Boolean is - (Universal.Options.Has_Buffer (Options_Ctx) - and then Options_Ctx.Buffer_First = RFLX_Types.Index'First - and then Options_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Universal.Message.Has_Buffer (Message_1_Ctx) - and then Message_1_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_1_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Universal.Message.Has_Buffer (Message_2_Ctx) - and then Message_2_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Options_Ctx : Universal.Options.Context; + Message_1_Ctx : Universal.Message.Context; + Message_2_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Options.Has_Buffer (Ctx.P.Options_Ctx) + and not Universal.Message.Has_Buffer (Ctx.P.Message_1_Ctx) + and not Universal.Message.Has_Buffer (Ctx.P.Message_2_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Options.Has_Buffer (Ctx.P.Options_Ctx) + and then Ctx.P.Options_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Options_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Universal.Message.Has_Buffer (Ctx.P.Message_1_Ctx) + and then Ctx.P.Message_1_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_1_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Universal.Message.Has_Buffer (Ctx.P.Message_2_Ctx) + and then Ctx.P.Message_2_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Send_1 => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_1_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_1_Ctx) > 0, + when S_Send_2 => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_2_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_2_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Send_1 => + Universal.Message.Byte_Size (Ctx.P.Message_1_Ctx), + when S_Send_2 => + Universal.Message.Byte_Size (Ctx.P.Message_2_Ctx), + when others => + raise Program_Error))); end RFLX.Test.Session; diff --git a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.adb b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.adb index a56bf5be4c..40e9184044 100644 --- a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.adb @@ -5,32 +5,32 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_3 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_4 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095 => RFLX_Types.Byte'First); - - Slot_5 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095 => RFLX_Types.Byte'First); - - Slot_6 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_7 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; - Slot_Ptr_3 := Slot_3'Unrestricted_Access; - Slot_Ptr_4 := Slot_4'Unrestricted_Access; - Slot_Ptr_5 := Slot_5'Unrestricted_Access; - Slot_Ptr_6 := Slot_6'Unrestricted_Access; - Slot_Ptr_7 := Slot_7'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; + S.Slot_Ptr_3 := M.Slot_3'Unrestricted_Access; + S.Slot_Ptr_4 := M.Slot_4'Unrestricted_Access; + S.Slot_Ptr_5 := M.Slot_5'Unrestricted_Access; + S.Slot_Ptr_6 := M.Slot_6'Unrestricted_Access; + S.Slot_Ptr_7 := M.Slot_7'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + S.Slot_Ptr_3 := null; + S.Slot_Ptr_4 := null; + S.Slot_Ptr_5 := null; + S.Slot_Ptr_6 := null; + S.Slot_Ptr_7 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.ads b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.ads index 6e78b9cb8e..c784239de4 100644 --- a/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_comprehension_on_sequence/generated/rflx-test-session_allocator.ads @@ -10,7 +10,16 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_3 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_4 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095) := (others => 0); + Slot_5 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095) := (others => 0); + Slot_6 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_7 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -24,40 +33,50 @@ is or else (Slot_Ptr_Type_8096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_8096'Last = RFLX_Types.Index'First + 8095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + Slot_Ptr_3 : Slot_Ptr_Type_4096; + Slot_Ptr_4 : Slot_Ptr_Type_8096; + Slot_Ptr_5 : Slot_Ptr_Type_8096; + Slot_Ptr_6 : Slot_Ptr_Type_4096; + Slot_Ptr_7 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null + and S.Slot_Ptr_3 /= null + and S.Slot_Ptr_4 /= null + and S.Slot_Ptr_5 /= null + and S.Slot_Ptr_6 /= null + and S.Slot_Ptr_7 /= null); - Slot_Ptr_3 : Slot_Ptr_Type_4096; + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null + and S.Slot_Ptr_4 = null + and S.Slot_Ptr_5 = null + and S.Slot_Ptr_6 = null + and S.Slot_Ptr_7 = null); - Slot_Ptr_4 : Slot_Ptr_Type_8096; - - Slot_Ptr_5 : Slot_Ptr_Type_8096; - - Slot_Ptr_6 : Slot_Ptr_Type_4096; - - Slot_Ptr_7 : Slot_Ptr_Type_4096; - - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null - and Slot_Ptr_3 /= null - and Slot_Ptr_4 /= null - and Slot_Ptr_5 /= null - and Slot_Ptr_6 /= null - and Slot_Ptr_7 /= null); + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); - procedure Initialize with + procedure Finalize (S : in out Slots) with Post => - Initialized; - - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null - and Slot_Ptr_3 = null - and Slot_Ptr_4 /= null - and Slot_Ptr_5 /= null - and Slot_Ptr_6 /= null - and Slot_Ptr_7 /= null); + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null + and S.Slot_Ptr_4 /= null + and S.Slot_Ptr_5 /= null + and S.Slot_Ptr_6 /= null + and S.Slot_Ptr_7 /= null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_conversion/generated/rflx-test-session.adb b/tests/integration/session_conversion/generated/rflx-test-session.adb index 9bfd109293..7b0c274fdd 100644 --- a/tests/integration/session_conversion/generated/rflx-test-session.adb +++ b/tests/integration/session_conversion/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -10,157 +11,131 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); if - Universal.Message.Structural_Valid_Message (Message_Ctx) - and then Universal.Message.Get_Message_Type (Message_Ctx) = Universal.MT_Data + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and then Universal.Message.Get_Message_Type (Ctx.P.Message_Ctx) = Universal.MT_Data then - P_Next_State := S_Process; + Ctx.P.Next_State := S_Process; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - if Universal.Contains.Option_In_Message_Data (Message_Ctx) then - Universal.Contains.Copy_Data (Message_Ctx, Inner_Message_Ctx); - Universal.Option.Verify_Message (Inner_Message_Ctx); + if Universal.Contains.Option_In_Message_Data (Ctx.P.Message_Ctx) then + Universal.Contains.Copy_Data (Ctx.P.Message_Ctx, Ctx.P.Inner_Message_Ctx); + Universal.Option.Verify_Message (Ctx.P.Inner_Message_Ctx); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; Inner_Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - Inner_Message_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Inner_Message_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Universal.Option.Initialize (Inner_Message_Ctx, Inner_Message_Buffer); - P_Next_State := S_Start; + Universal.Option.Initialize (Ctx.P.Inner_Message_Ctx, Inner_Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; Inner_Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Inner_Message_Ctx"""); - pragma Warnings (Off, """Inner_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Option.Take_Buffer (Inner_Message_Ctx, Inner_Message_Buffer); - pragma Warnings (On, """Inner_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Inner_Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Inner_Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + pragma Warnings (Off, """Ctx.P.Inner_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Option.Take_Buffer (Ctx.P.Inner_Message_Ctx, Inner_Message_Buffer); + pragma Warnings (On, """Ctx.P.Inner_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := Inner_Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Option.Structural_Valid_Message (Inner_Message_Ctx) - and Universal.Option.Byte_Size (Inner_Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Option.Byte_Size (Inner_Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -178,40 +153,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Option_Read (Inner_Message_Ctx); + Universal_Option_Read (Ctx.P.Inner_Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -224,9 +186,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_conversion/generated/rflx-test-session.ads b/tests/integration/session_conversion/generated/rflx-test-session.ads index 5fef45425f..9d726f699f 100644 --- a/tests/integration/session_conversion/generated/rflx-test-session.ads +++ b/tests/integration/session_conversion/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -6,11 +7,8 @@ with RFLX.Universal; with RFLX.Universal.Message; with RFLX.Universal.Option; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -21,108 +19,152 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - Inner_Message_Ctx : Universal.Option.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx) - and not Universal.Option.Has_Buffer (Inner_Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Universal.Option.Has_Buffer (Inner_Message_Ctx) - and then Inner_Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Inner_Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Inner_Message_Ctx : Universal.Option.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and not Universal.Option.Has_Buffer (Ctx.P.Inner_Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Universal.Option.Has_Buffer (Ctx.P.Inner_Message_Ctx) + and then Ctx.P.Inner_Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Inner_Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Option.Structural_Valid_Message (Ctx.P.Inner_Message_Ctx) + and Universal.Option.Byte_Size (Ctx.P.Inner_Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Option.Byte_Size (Ctx.P.Inner_Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_conversion/generated/rflx-test-session_allocator.adb b/tests/integration/session_conversion/generated/rflx-test-session_allocator.adb index 9024bb3698..85d68b5b9b 100644 --- a/tests/integration/session_conversion/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_conversion/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_conversion/generated/rflx-test-session_allocator.ads b/tests/integration/session_conversion/generated/rflx-test-session_allocator.ads index 7ab793148d..3355bcb4b1 100644 --- a/tests/integration/session_conversion/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_conversion/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,20 +22,30 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_endianness/generated/rflx-test-session.adb b/tests/integration/session_endianness/generated/rflx-test-session.adb index 49caf190ed..e303e0d8dc 100644 --- a/tests/integration/session_endianness/generated/rflx-test-session.adb +++ b/tests/integration/session_endianness/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,267 +8,224 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Messages.Msg.Verify_Message (In_Msg_Ctx); - if Messages.Msg.Byte_Size (In_Msg_Ctx) > 0 then - P_Next_State := S_Copy; + Messages.Msg.Verify_Message (Ctx.P.In_Msg_Ctx); + if Messages.Msg.Byte_Size (Ctx.P.In_Msg_Ctx) > 0 then + Ctx.P.Next_State := S_Copy; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Copy (P_Next_State : out State) with + procedure Copy (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - if RFLX_Types.To_First_Bit_Index (Out_Msg_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Out_Msg_Ctx.Buffer_First) + 1 >= 64 then - Messages.Msg_LE.Reset (Out_Msg_Ctx, RFLX_Types.To_First_Bit_Index (Out_Msg_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Out_Msg_Ctx.Buffer_First) + 64 - 1); - if Messages.Msg.Valid (In_Msg_Ctx, Messages.Msg.F_A) then - Messages.Msg_LE.Set_C (Out_Msg_Ctx, Messages.Msg.Get_A (In_Msg_Ctx)); - if Messages.Msg.Valid (In_Msg_Ctx, Messages.Msg.F_B) then - Messages.Msg_LE.Set_D (Out_Msg_Ctx, Messages.Msg.Get_B (In_Msg_Ctx)); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg_Ctx.Buffer_First) + 1 >= 64 then + Messages.Msg_LE.Reset (Ctx.P.Out_Msg_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg_Ctx.Buffer_First) + 64 - 1); + if Messages.Msg.Valid (Ctx.P.In_Msg_Ctx, Messages.Msg.F_A) then + Messages.Msg_LE.Set_C (Ctx.P.Out_Msg_Ctx, Messages.Msg.Get_A (Ctx.P.In_Msg_Ctx)); + if Messages.Msg.Valid (Ctx.P.In_Msg_Ctx, Messages.Msg.F_B) then + Messages.Msg_LE.Set_D (Ctx.P.Out_Msg_Ctx, Messages.Msg.Get_B (Ctx.P.In_Msg_Ctx)); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Copy; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Read2; + Ctx.P.Next_State := S_Read2; end Reply; - procedure Read2 (P_Next_State : out State) with + procedure Read2 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Messages.Msg_LE.Verify_Message (In_Msg2_Ctx); - if Messages.Msg_LE.Byte_Size (In_Msg2_Ctx) > 0 then - P_Next_State := S_Copy2; + Messages.Msg_LE.Verify_Message (Ctx.P.In_Msg2_Ctx); + if Messages.Msg_LE.Byte_Size (Ctx.P.In_Msg2_Ctx) > 0 then + Ctx.P.Next_State := S_Copy2; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Read2; - procedure Copy2 (P_Next_State : out State) with + procedure Copy2 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - if RFLX_Types.To_First_Bit_Index (Out_Msg2_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Out_Msg2_Ctx.Buffer_First) + 1 >= 64 then - Messages.Msg.Reset (Out_Msg2_Ctx, RFLX_Types.To_First_Bit_Index (Out_Msg2_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Out_Msg2_Ctx.Buffer_First) + 64 - 1); - if Messages.Msg_LE.Valid (In_Msg2_Ctx, Messages.Msg_LE.F_C) then - Messages.Msg.Set_A (Out_Msg2_Ctx, Messages.Msg_LE.Get_C (In_Msg2_Ctx)); - if Messages.Msg_LE.Valid (In_Msg2_Ctx, Messages.Msg_LE.F_D) then - Messages.Msg.Set_B (Out_Msg2_Ctx, Messages.Msg_LE.Get_D (In_Msg2_Ctx)); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg2_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg2_Ctx.Buffer_First) + 1 >= 64 then + Messages.Msg.Reset (Ctx.P.Out_Msg2_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg2_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Out_Msg2_Ctx.Buffer_First) + 64 - 1); + if Messages.Msg_LE.Valid (Ctx.P.In_Msg2_Ctx, Messages.Msg_LE.F_C) then + Messages.Msg.Set_A (Ctx.P.Out_Msg2_Ctx, Messages.Msg_LE.Get_C (Ctx.P.In_Msg2_Ctx)); + if Messages.Msg_LE.Valid (Ctx.P.In_Msg2_Ctx, Messages.Msg_LE.F_D) then + Messages.Msg.Set_B (Ctx.P.Out_Msg2_Ctx, Messages.Msg_LE.Get_D (Ctx.P.In_Msg2_Ctx)); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply2; + Ctx.P.Next_State := S_Reply2; end Copy2; - procedure Reply2 (P_Next_State : out State) with + procedure Reply2 (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Start; + Ctx.P.Next_State := S_Start; end Reply2; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is In_Msg_Buffer : RFLX_Types.Bytes_Ptr; In_Msg2_Buffer : RFLX_Types.Bytes_Ptr; Out_Msg_Buffer : RFLX_Types.Bytes_Ptr; Out_Msg2_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - In_Msg_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + In_Msg_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Messages.Msg.Initialize (In_Msg_Ctx, In_Msg_Buffer); - In_Msg2_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Messages.Msg.Initialize (Ctx.P.In_Msg_Ctx, In_Msg_Buffer); + In_Msg2_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Messages.Msg_LE.Initialize (In_Msg2_Ctx, In_Msg2_Buffer); - Out_Msg_Buffer := Test.Session_Allocator.Slot_Ptr_3; + Messages.Msg_LE.Initialize (Ctx.P.In_Msg2_Ctx, In_Msg2_Buffer); + Out_Msg_Buffer := Ctx.P.Slots.Slot_Ptr_3; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := null; + Ctx.P.Slots.Slot_Ptr_3 := null; pragma Warnings (On, "unused assignment"); - Messages.Msg_LE.Initialize (Out_Msg_Ctx, Out_Msg_Buffer); - Out_Msg2_Buffer := Test.Session_Allocator.Slot_Ptr_4; + Messages.Msg_LE.Initialize (Ctx.P.Out_Msg_Ctx, Out_Msg_Buffer); + Out_Msg2_Buffer := Ctx.P.Slots.Slot_Ptr_4; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := null; + Ctx.P.Slots.Slot_Ptr_4 := null; pragma Warnings (On, "unused assignment"); - Messages.Msg.Initialize (Out_Msg2_Ctx, Out_Msg2_Buffer); - P_Next_State := S_Start; + Messages.Msg.Initialize (Ctx.P.Out_Msg2_Ctx, Out_Msg2_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is In_Msg_Buffer : RFLX_Types.Bytes_Ptr; In_Msg2_Buffer : RFLX_Types.Bytes_Ptr; Out_Msg_Buffer : RFLX_Types.Bytes_Ptr; Out_Msg2_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""In_Msg_Ctx"""); - pragma Warnings (Off, """In_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Messages.Msg.Take_Buffer (In_Msg_Ctx, In_Msg_Buffer); - pragma Warnings (On, """In_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""In_Msg_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := In_Msg_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""In_Msg2_Ctx"""); - pragma Warnings (Off, """In_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Messages.Msg_LE.Take_Buffer (In_Msg2_Ctx, In_Msg2_Buffer); - pragma Warnings (On, """In_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""In_Msg2_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := In_Msg2_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Out_Msg_Ctx"""); - pragma Warnings (Off, """Out_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Messages.Msg_LE.Take_Buffer (Out_Msg_Ctx, Out_Msg_Buffer); - pragma Warnings (On, """Out_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Out_Msg_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := Out_Msg_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Out_Msg2_Ctx"""); - pragma Warnings (Off, """Out_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Messages.Msg.Take_Buffer (Out_Msg2_Ctx, Out_Msg2_Buffer); - pragma Warnings (On, """Out_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Out_Msg2_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := Out_Msg2_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.In_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Messages.Msg.Take_Buffer (Ctx.P.In_Msg_Ctx, In_Msg_Buffer); + pragma Warnings (On, """Ctx.P.In_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := In_Msg_Buffer; + pragma Warnings (Off, """Ctx.P.In_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Messages.Msg_LE.Take_Buffer (Ctx.P.In_Msg2_Ctx, In_Msg2_Buffer); + pragma Warnings (On, """Ctx.P.In_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := In_Msg2_Buffer; + pragma Warnings (Off, """Ctx.P.Out_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Messages.Msg_LE.Take_Buffer (Ctx.P.Out_Msg_Ctx, Out_Msg_Buffer); + pragma Warnings (On, """Ctx.P.Out_Msg_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_3 := Out_Msg_Buffer; + pragma Warnings (Off, """Ctx.P.Out_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Messages.Msg.Take_Buffer (Ctx.P.Out_Msg2_Ctx, Out_Msg2_Buffer); + pragma Warnings (On, """Ctx.P.Out_Msg2_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_4 := Out_Msg2_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Messages.Msg.Reset (In_Msg_Ctx, In_Msg_Ctx.First, In_Msg_Ctx.First - 1); + Messages.Msg.Reset (Ctx.P.In_Msg_Ctx, Ctx.P.In_Msg_Ctx.First, Ctx.P.In_Msg_Ctx.First - 1); when S_Copy | S_Reply => null; when S_Read2 => - Messages.Msg_LE.Reset (In_Msg2_Ctx, In_Msg2_Ctx.First, In_Msg2_Ctx.First - 1); + Messages.Msg_LE.Reset (Ctx.P.In_Msg2_Ctx, Ctx.P.In_Msg2_Ctx.First, Ctx.P.In_Msg2_Ctx.First - 1); when S_Copy2 | S_Reply2 | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Copy => - Copy (P_Next_State); + Copy (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Read2 => - Read2 (P_Next_State); + Read2 (Ctx); when S_Copy2 => - Copy2 (P_Next_State); + Copy2 (Ctx); when S_Reply2 => - Reply2 (P_Next_State); + Reply2 (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply | S_Read2 | S_Reply2); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply | S_Read2 | S_Reply2); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_I => - False, - when C_O => - (case P_Next_State is - when S_Reply => - Messages.Msg_LE.Structural_Valid_Message (Out_Msg_Ctx) - and Messages.Msg_LE.Byte_Size (Out_Msg_Ctx) > 0, - when S_Reply2 => - Messages.Msg.Structural_Valid_Message (Out_Msg2_Ctx) - and Messages.Msg.Byte_Size (Out_Msg2_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_I => - raise Program_Error, - when C_O => - (case P_Next_State is - when S_Reply => - Messages.Msg_LE.Byte_Size (Out_Msg_Ctx), - when S_Reply2 => - Messages.Msg.Byte_Size (Out_Msg2_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -288,46 +246,29 @@ is when C_I => raise Program_Error; when C_O => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Messages_Msg_LE_Read (Out_Msg_Ctx); + Messages_Msg_LE_Read (Ctx.P.Out_Msg_Ctx); when S_Reply2 => - Messages_Msg_Read (Out_Msg2_Ctx); + Messages_Msg_Read (Ctx.P.Out_Msg2_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_I => - (case P_Next_State is - when S_Start | S_Read2 => - True, - when others => - False), - when C_O => - False)); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_I => - 4096, - when C_O => - 0)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -341,11 +282,11 @@ is begin case Chan is when C_I => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Messages_Msg_Write (In_Msg_Ctx, Offset); + Messages_Msg_Write (Ctx.P.In_Msg_Ctx, Offset); when S_Read2 => - Messages_Msg_LE_Write (In_Msg2_Ctx, Offset); + Messages_Msg_LE_Write (Ctx.P.In_Msg2_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_endianness/generated/rflx-test-session.ads b/tests/integration/session_endianness/generated/rflx-test-session.ads index 784fc5fe8c..9d42e42a6a 100644 --- a/tests/integration/session_endianness/generated/rflx-test-session.ads +++ b/tests/integration/session_endianness/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -6,11 +7,8 @@ with RFLX.Messages; with RFLX.Messages.Msg; with RFLX.Messages.Msg_LE; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -21,120 +19,175 @@ is type State is (S_Start, S_Copy, S_Reply, S_Read2, S_Copy2, S_Reply2, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - In_Msg_Ctx : Messages.Msg.Context; - - In_Msg2_Ctx : Messages.Msg_LE.Context; - - Out_Msg_Ctx : Messages.Msg_LE.Context; - - Out_Msg2_Ctx : Messages.Msg.Context; - - function Uninitialized return Boolean is - (not Messages.Msg.Has_Buffer (In_Msg_Ctx) - and not Messages.Msg_LE.Has_Buffer (In_Msg2_Ctx) - and not Messages.Msg_LE.Has_Buffer (Out_Msg_Ctx) - and not Messages.Msg.Has_Buffer (Out_Msg2_Ctx)); - - function Initialized return Boolean is - (Messages.Msg.Has_Buffer (In_Msg_Ctx) - and then In_Msg_Ctx.Buffer_First = RFLX_Types.Index'First - and then In_Msg_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Messages.Msg_LE.Has_Buffer (In_Msg2_Ctx) - and then In_Msg2_Ctx.Buffer_First = RFLX_Types.Index'First - and then In_Msg2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Messages.Msg_LE.Has_Buffer (Out_Msg_Ctx) - and then Out_Msg_Ctx.Buffer_First = RFLX_Types.Index'First - and then Out_Msg_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Messages.Msg.Has_Buffer (Out_Msg2_Ctx) - and then Out_Msg2_Ctx.Buffer_First = RFLX_Types.Index'First - and then Out_Msg2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + In_Msg_Ctx : Messages.Msg.Context; + In_Msg2_Ctx : Messages.Msg_LE.Context; + Out_Msg_Ctx : Messages.Msg_LE.Context; + Out_Msg2_Ctx : Messages.Msg.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Messages.Msg.Has_Buffer (Ctx.P.In_Msg_Ctx) + and not Messages.Msg_LE.Has_Buffer (Ctx.P.In_Msg2_Ctx) + and not Messages.Msg_LE.Has_Buffer (Ctx.P.Out_Msg_Ctx) + and not Messages.Msg.Has_Buffer (Ctx.P.Out_Msg2_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Messages.Msg.Has_Buffer (Ctx.P.In_Msg_Ctx) + and then Ctx.P.In_Msg_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.In_Msg_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Messages.Msg_LE.Has_Buffer (Ctx.P.In_Msg2_Ctx) + and then Ctx.P.In_Msg2_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.In_Msg2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Messages.Msg_LE.Has_Buffer (Ctx.P.Out_Msg_Ctx) + and then Ctx.P.Out_Msg_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Out_Msg_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Messages.Msg.Has_Buffer (Ctx.P.Out_Msg2_Ctx) + and then Ctx.P.Out_Msg2_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Out_Msg2_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_I => + False, + when C_O => + (case Ctx.P.Next_State is + when S_Reply => + Messages.Msg_LE.Structural_Valid_Message (Ctx.P.Out_Msg_Ctx) + and Messages.Msg_LE.Byte_Size (Ctx.P.Out_Msg_Ctx) > 0, + when S_Reply2 => + Messages.Msg.Structural_Valid_Message (Ctx.P.Out_Msg2_Ctx) + and Messages.Msg.Byte_Size (Ctx.P.Out_Msg2_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_I => + raise Program_Error, + when C_O => + (case Ctx.P.Next_State is + when S_Reply => + Messages.Msg_LE.Byte_Size (Ctx.P.Out_Msg_Ctx), + when S_Reply2 => + Messages.Msg.Byte_Size (Ctx.P.Out_Msg2_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_I => + (case Ctx.P.Next_State is + when S_Start | S_Read2 => + True, + when others => + False), + when C_O => + False)); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_I => + 4096, + when C_O => + 0)); end RFLX.Test.Session; diff --git a/tests/integration/session_endianness/generated/rflx-test-session_allocator.adb b/tests/integration/session_endianness/generated/rflx-test-session_allocator.adb index b9f4e546d4..870778ca5c 100644 --- a/tests/integration/session_endianness/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_endianness/generated/rflx-test-session_allocator.adb @@ -5,23 +5,26 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_3 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_4 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; - Slot_Ptr_3 := Slot_3'Unrestricted_Access; - Slot_Ptr_4 := Slot_4'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; + S.Slot_Ptr_3 := M.Slot_3'Unrestricted_Access; + S.Slot_Ptr_4 := M.Slot_4'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + S.Slot_Ptr_3 := null; + S.Slot_Ptr_4 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_endianness/generated/rflx-test-session_allocator.ads b/tests/integration/session_endianness/generated/rflx-test-session_allocator.ads index 976b0c6172..218ff2164b 100644 --- a/tests/integration/session_endianness/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_endianness/generated/rflx-test-session_allocator.ads @@ -10,7 +10,13 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_3 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_4 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,28 +24,38 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; - - Slot_Ptr_2 : Slot_Ptr_Type_4096; - - Slot_Ptr_3 : Slot_Ptr_Type_4096; - - Slot_Ptr_4 : Slot_Ptr_Type_4096; - - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null - and Slot_Ptr_3 /= null - and Slot_Ptr_4 /= null); + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + Slot_Ptr_3 : Slot_Ptr_Type_4096; + Slot_Ptr_4 : Slot_Ptr_Type_4096; + end record; + + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null + and S.Slot_Ptr_3 /= null + and S.Slot_Ptr_4 /= null); + + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null + and S.Slot_Ptr_4 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); - procedure Initialize with + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null - and Slot_Ptr_3 = null - and Slot_Ptr_4 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null + and S.Slot_Ptr_4 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_functions/config.yml b/tests/integration/session_functions/config.yml index 65060c38ed..428d5a137e 100644 --- a/tests/integration/session_functions/config.yml +++ b/tests/integration/session_functions/config.yml @@ -1,7 +1,3 @@ -functions: - - Func.Get_Message_Type - - Func.Create_Message - - Func.Valid_Message input: Channel: - 1 0 3 0 1 2 diff --git a/tests/integration/session_functions/generated/rflx-test-session.adb b/tests/integration/session_functions/generated/rflx-test-session.adb index d0d1f5ce85..1ffbe24fde 100644 --- a/tests/integration/session_functions/generated/rflx-test-session.adb +++ b/tests/integration/session_functions/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -12,173 +13,147 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); if - (Universal.Message.Structural_Valid_Message (Message_Ctx) - and then Universal.Message.Get_Message_Type (Message_Ctx) = Universal.MT_Data) - and then Universal.Message.Get_Length (Message_Ctx) = 3 + (Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and then Universal.Message.Get_Message_Type (Ctx.P.Message_Ctx) = Universal.MT_Data) + and then Universal.Message.Get_Length (Ctx.P.Message_Ctx) = 3 then - P_Next_State := S_Process; + Ctx.P.Next_State := S_Process; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is Valid : Test.Result; Message_Type : Universal.Option_Type; begin - Get_Message_Type (Message_Type); - Valid_Message (Valid, Message_Type, True); - if Universal.Message.Structural_Valid (Message_Ctx, Universal.Message.F_Data) then + Get_Message_Type (Ctx, Message_Type); + Valid_Message (Ctx, Message_Type, True, Valid); + if Universal.Message.Structural_Valid (Ctx.P.Message_Ctx, Universal.Message.F_Data) then declare Fixed_Size_Message : Fixed_Size.Simple_Message.Structure; RFLX_Create_Message_Arg_1_Message : RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); - RFLX_Create_Message_Arg_1_Message_Length : constant RFLX_Types.Length := RFLX_Types.To_Length (Universal.Message.Field_Size (Message_Ctx, Universal.Message.F_Data)) + 1; + RFLX_Create_Message_Arg_1_Message_Length : constant RFLX_Types.Length := RFLX_Types.To_Length (Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Data)) + 1; begin - Universal.Message.Get_Data (Message_Ctx, RFLX_Create_Message_Arg_1_Message (RFLX_Types.Index'First .. RFLX_Types.Index'First + RFLX_Types.Index (RFLX_Create_Message_Arg_1_Message_Length) - 2)); - Create_Message (Fixed_Size_Message, Message_Type, RFLX_Create_Message_Arg_1_Message (RFLX_Types.Index'First .. RFLX_Types.Index'First + RFLX_Types.Index (RFLX_Create_Message_Arg_1_Message_Length) - 2)); - Fixed_Size.Simple_Message.To_Context (Fixed_Size_Message, Fixed_Size_Message_Ctx); + Universal.Message.Get_Data (Ctx.P.Message_Ctx, RFLX_Create_Message_Arg_1_Message (RFLX_Types.Index'First .. RFLX_Types.Index'First + RFLX_Types.Index (RFLX_Create_Message_Arg_1_Message_Length) - 2)); + Create_Message (Ctx, Message_Type, RFLX_Create_Message_Arg_1_Message (RFLX_Types.Index'First .. RFLX_Types.Index'First + RFLX_Types.Index (RFLX_Create_Message_Arg_1_Message_Length) - 2), Fixed_Size_Message); + Fixed_Size.Simple_Message.To_Context (Fixed_Size_Message, Ctx.P.Fixed_Size_Message_Ctx); end; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if Valid = M_Valid then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Reply; else - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Terminated; end if; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; Fixed_Size_Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - Fixed_Size_Message_Buffer := Test.Session_Allocator.Slot_Ptr_2; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Fixed_Size_Message_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - Fixed_Size.Simple_Message.Initialize (Fixed_Size_Message_Ctx, Fixed_Size_Message_Buffer); - P_Next_State := S_Start; + Fixed_Size.Simple_Message.Initialize (Ctx.P.Fixed_Size_Message_Ctx, Fixed_Size_Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; Fixed_Size_Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Fixed_Size_Message_Ctx"""); - pragma Warnings (Off, """Fixed_Size_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Fixed_Size.Simple_Message.Take_Buffer (Fixed_Size_Message_Ctx, Fixed_Size_Message_Buffer); - pragma Warnings (On, """Fixed_Size_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Fixed_Size_Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Fixed_Size_Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + pragma Warnings (Off, """Ctx.P.Fixed_Size_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Fixed_Size.Simple_Message.Take_Buffer (Ctx.P.Fixed_Size_Message_Ctx, Fixed_Size_Message_Buffer); + pragma Warnings (On, """Ctx.P.Fixed_Size_Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := Fixed_Size_Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Fixed_Size.Simple_Message.Structural_Valid_Message (Fixed_Size_Message_Ctx) - and Fixed_Size.Simple_Message.Byte_Size (Fixed_Size_Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Fixed_Size.Simple_Message.Byte_Size (Fixed_Size_Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -196,40 +171,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Fixed_Size_Simple_Message_Read (Fixed_Size_Message_Ctx); + Fixed_Size_Simple_Message_Read (Ctx.P.Fixed_Size_Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -242,9 +204,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_functions/generated/rflx-test-session.ads b/tests/integration/session_functions/generated/rflx-test-session.ads index eb0204e9c8..8036262f2d 100644 --- a/tests/integration/session_functions/generated/rflx-test-session.ads +++ b/tests/integration/session_functions/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -8,14 +9,8 @@ with RFLX.Fixed_Size; with RFLX.Fixed_Size.Simple_Message; with RFLX.Test; -generic - with procedure Get_Message_Type (Get_Message_Type : out RFLX.Universal.Option_Type); - with procedure Create_Message (Create_Message : out RFLX.Fixed_Size.Simple_Message.Structure; Message_Type : RFLX.Universal.Option_Type; Data : RFLX_Types.Bytes); - with procedure Valid_Message (Valid_Message : out RFLX.Test.Result; Message_Type : RFLX.Universal.Option_Type; Strict : Boolean); package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -26,108 +21,171 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + procedure Get_Message_Type (Ctx : in out Context; RFLX_Result : out RFLX.Universal.Option_Type) is abstract with + Pre'Class => + Initialized (Ctx) + and not RFLX_Result'Constrained, + Post'Class => + Initialized (Ctx); - procedure Initialize with + procedure Create_Message (Ctx : in out Context; Message_Type : RFLX.Universal.Option_Type; Data : RFLX_Types.Bytes; RFLX_Result : out RFLX.Fixed_Size.Simple_Message.Structure) is abstract with + Pre'Class => + Initialized (Ctx), + Post'Class => + Initialized (Ctx); + + procedure Valid_Message (Ctx : in out Context; Message_Type : RFLX.Universal.Option_Type; Strict : Boolean; RFLX_Result : out RFLX.Test.Result) is abstract with + Pre'Class => + Initialized (Ctx), + Post'Class => + Initialized (Ctx); + + function Uninitialized (Ctx : Context'Class) return Boolean; + + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - Fixed_Size_Message_Ctx : Fixed_Size.Simple_Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx) - and not Fixed_Size.Simple_Message.Has_Buffer (Fixed_Size_Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Fixed_Size.Simple_Message.Has_Buffer (Fixed_Size_Message_Ctx) - and then Fixed_Size_Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Fixed_Size_Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Fixed_Size_Message_Ctx : Fixed_Size.Simple_Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and not Fixed_Size.Simple_Message.Has_Buffer (Ctx.P.Fixed_Size_Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Fixed_Size.Simple_Message.Has_Buffer (Ctx.P.Fixed_Size_Message_Ctx) + and then Ctx.P.Fixed_Size_Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Fixed_Size_Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Fixed_Size.Simple_Message.Structural_Valid_Message (Ctx.P.Fixed_Size_Message_Ctx) + and Fixed_Size.Simple_Message.Byte_Size (Ctx.P.Fixed_Size_Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Fixed_Size.Simple_Message.Byte_Size (Ctx.P.Fixed_Size_Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_functions/generated/rflx-test-session_allocator.adb b/tests/integration/session_functions/generated/rflx-test-session_allocator.adb index 9024bb3698..85d68b5b9b 100644 --- a/tests/integration/session_functions/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_functions/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_functions/generated/rflx-test-session_allocator.ads b/tests/integration/session_functions/generated/rflx-test-session_allocator.ads index 7ab793148d..3355bcb4b1 100644 --- a/tests/integration/session_functions/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_functions/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,20 +22,30 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_functions/src/func.adb b/tests/integration/session_functions/src/func.adb deleted file mode 100644 index 942952b8c4..0000000000 --- a/tests/integration/session_functions/src/func.adb +++ /dev/null @@ -1,36 +0,0 @@ -package body Func with - SPARK_Mode -is - - procedure Get_Message_Type (Result : out RFLX.Universal.Option_Type) is - begin - Result := (Known => True, Enum => RFLX.Universal.OT_Data); - end Get_Message_Type; - - procedure Create_Message - (Result : out RFLX.Fixed_Size.Simple_Message.Structure; - Message_Type : RFLX.Universal.Option_Type; - Data : RFLX.RFLX_Types.Bytes) - is - begin - Result.Message_Type := Message_Type; - if Result.Data'Length = Data'Length then - Result.Data := Data; - else - Result.Data := (others => 0); - end if; - end Create_Message; - - procedure Valid_Message - (Valid_Message : out RFLX.Test.Result; - Message_Type : RFLX.Universal.Option_Type; - Strict : Boolean) - is - use type RFLX.Universal.Option_Type; - begin - Valid_Message := (if Strict and then Message_Type = (Known => True, Enum => RFLX.Universal.OT_Data) - then RFLX.Test.M_Invalid - else RFLX.Test.M_Valid); - end Valid_Message; - -end Func; diff --git a/tests/integration/session_functions/src/func.ads b/tests/integration/session_functions/src/func.ads deleted file mode 100644 index c010a0dc72..0000000000 --- a/tests/integration/session_functions/src/func.ads +++ /dev/null @@ -1,20 +0,0 @@ -pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); - -with RFLX.RFLX_Types; -with RFLX.Test; -with RFLX.Universal; -with RFLX.Fixed_Size.Simple_Message; - -package Func with - SPARK_Mode -is - - procedure Get_Message_Type (Result : out RFLX.Universal.Option_Type) with - Pre => - not Result'Constrained; - - procedure Create_Message (Result : out RFLX.Fixed_Size.Simple_Message.Structure; Message_Type : RFLX.Universal.Option_Type; Data : RFLX.RFLX_Types.Bytes); - - procedure Valid_Message (Valid_Message : out RFLX.Test.Result; Message_Type : RFLX.Universal.Option_Type; Strict : Boolean); - -end Func; diff --git a/tests/integration/session_functions/src/session.adb b/tests/integration/session_functions/src/session.adb new file mode 100644 index 0000000000..a45a1d524a --- /dev/null +++ b/tests/integration/session_functions/src/session.adb @@ -0,0 +1,44 @@ +package body Session with + SPARK_Mode +is + + overriding + procedure Get_Message_Type + (Ctx : in out Context; + Result : out RFLX.Universal.Option_Type) + is + begin + Result := (Known => True, Enum => RFLX.Universal.OT_Data); + end Get_Message_Type; + + overriding + procedure Create_Message + (Ctx : in out Context; + Message_Type : RFLX.Universal.Option_Type; + Data : RFLX.RFLX_Types.Bytes; + Result : out RFLX.Fixed_Size.Simple_Message.Structure) + is + begin + Result.Message_Type := Message_Type; + if Result.Data'Length = Data'Length then + Result.Data := Data; + else + Result.Data := (others => 0); + end if; + end Create_Message; + + overriding + procedure Valid_Message + (Ctx : in out Context; + Message_Type : RFLX.Universal.Option_Type; + Strict : Boolean; + Result : out RFLX.Test.Result) + is + use type RFLX.Universal.Option_Type; + begin + Result := (if Strict and then Message_Type = (Known => True, Enum => RFLX.Universal.OT_Data) + then RFLX.Test.M_Valid + else RFLX.Test.M_Invalid); + end Valid_Message; + +end Session; diff --git a/tests/integration/session_functions/src/session.ads b/tests/integration/session_functions/src/session.ads new file mode 100644 index 0000000000..727825b011 --- /dev/null +++ b/tests/integration/session_functions/src/session.ads @@ -0,0 +1,40 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +with RFLX.RFLX_Types; +with RFLX.Universal; +with RFLX.Fixed_Size.Simple_Message; +with RFLX.Test.Session; + +package Session with + SPARK_Mode, + Elaborate_Body +is + + type Context is new RFLX.Test.Session.Context with null record; + + pragma Warnings (Off, """Ctx"" is not modified, could be IN"); + pragma Warnings (Off, "unused variable ""Ctx"""); + + overriding + procedure Get_Message_Type + (Ctx : in out Context; + Result : out RFLX.Universal.Option_Type); + + overriding + procedure Create_Message + (Ctx : in out Context; + Message_Type : RFLX.Universal.Option_Type; + Data : RFLX.RFLX_Types.Bytes; + Result : out RFLX.Fixed_Size.Simple_Message.Structure); + + overriding + procedure Valid_Message + (Ctx : in out Context; + Message_Type : RFLX.Universal.Option_Type; + Strict : Boolean; + Result : out RFLX.Test.Result); + + pragma Warnings (On, "unused variable ""Ctx"""); + pragma Warnings (On, """Ctx"" is not modified, could be IN"); + +end Session; diff --git a/tests/integration/session_functions/test.rflx b/tests/integration/session_functions/test.rflx index 647832874e..bcbed139bb 100644 --- a/tests/integration/session_functions/test.rflx +++ b/tests/integration/session_functions/test.rflx @@ -45,9 +45,9 @@ package Test is Valid := Valid_Message (Message_Type, True); -- §S-S-A-A-CL, §S-E-CL-L Fixed_Size_Message := Create_Message (Message_Type, Message.Data); -- §S-S-A-A-CL, §S-E-CL-V, §S-E-CL-S transition - goto Terminated + goto Reply if Valid = M_Valid -- §S-S-T-BE - goto Reply -- §S-S-T-N + goto Terminated -- §S-S-T-N exception goto Terminated -- §S-S-E end Process; diff --git a/tests/integration/session_integration/generated/rflx-test-session.adb b/tests/integration/session_integration/generated/rflx-test-session.adb index da3aae39ea..763cb8ad05 100644 --- a/tests/integration/session_integration/generated/rflx-test-session.adb +++ b/tests/integration/session_integration/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -10,71 +11,71 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); if - (Universal.Message.Structural_Valid_Message (Message_Ctx) = True - and then Universal.Message.Get_Message_Type (Message_Ctx) = Universal.MT_Data) - and then Universal.Message.Get_Length (Message_Ctx) = 1 + (Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) = True + and then Universal.Message.Get_Message_Type (Ctx.P.Message_Ctx) = Universal.MT_Data) + and then Universal.Message.Get_Length (Ctx.P.Message_Ctx) = 1 then - P_Next_State := S_Prepare_Message; + Ctx.P.Next_State := S_Prepare_Message; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Prepare_Message (P_Next_State : out State) with + procedure Prepare_Message (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= 32 then - Universal.Message.Reset (Message_Ctx, RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 32 - 1); - Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Data); - Universal.Message.Set_Length (Message_Ctx, 1); - if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then - Universal.Message.Set_Data (Message_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 1 >= 32 then + Universal.Message.Reset (Ctx.P.Message_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 32 - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Data); + Universal.Message.Set_Length (Ctx.P.Message_Ctx, 1); + if Universal.Message.Valid_Length (Ctx.P.Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then + Universal.Message.Set_Data (Ctx.P.Message_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Prepare_Message; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Next; + Ctx.P.Next_State := S_Next; end Reply; - procedure Next (P_Next_State : out State) with + procedure Next (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is M_Ctx : Universal.Message.Context; M_Buffer : RFLX_Types.Bytes_Ptr; begin - M_Buffer := Test.Session_Allocator.Slot_Ptr_2; + M_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); Universal.Message.Initialize (M_Ctx, M_Buffer); if RFLX_Types.To_First_Bit_Index (M_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (M_Ctx.Buffer_First) + 1 >= 32 then @@ -84,133 +85,99 @@ is if Universal.Message.Valid_Length (M_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then Universal.Message.Set_Data (M_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""M_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Message.Take_Buffer (M_Ctx, M_Buffer); pragma Warnings (On, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := M_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := M_Buffer; return; end if; else - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""M_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Message.Take_Buffer (M_Ctx, M_Buffer); pragma Warnings (On, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := M_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := M_Buffer; return; end if; - P_Next_State := S_Terminated; - pragma Warnings (Off, "unused assignment to ""M_Ctx"""); + Ctx.P.Next_State := S_Terminated; pragma Warnings (Off, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); Universal.Message.Take_Buffer (M_Ctx, M_Buffer); pragma Warnings (On, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := M_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_2 := M_Buffer; end Next; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Prepare_Message | S_Reply | S_Next | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Prepare_Message => - Prepare_Message (P_Next_State); + Prepare_Message (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Next => - Next (P_Next_State); + Next (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -228,40 +195,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -274,9 +228,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_integration/generated/rflx-test-session.ads b/tests/integration/session_integration/generated/rflx-test-session.ads index d8b5103fcc..3f5cadbcc1 100644 --- a/tests/integration/session_integration/generated/rflx-test-session.ads +++ b/tests/integration/session_integration/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,147 @@ is type State is (S_Start, S_Prepare_Message, S_Reply, S_Next, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 1023 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 1023 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_integration/generated/rflx-test-session_allocator.adb b/tests/integration/session_integration/generated/rflx-test-session_allocator.adb index a0341c4c3d..85d68b5b9b 100644 --- a/tests/integration/session_integration/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_integration/generated/rflx-test-session_allocator.adb @@ -5,17 +5,22 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 1023 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8191 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_integration/generated/rflx-test-session_allocator.ads b/tests/integration/session_integration/generated/rflx-test-session_allocator.ads index 901ad308b7..1c0915f03f 100644 --- a/tests/integration/session_integration/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_integration/generated/rflx-test-session_allocator.ads @@ -10,7 +10,11 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 1023) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8191) := (others => 0); + end record; subtype Slot_Ptr_Type_1024 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -24,20 +28,30 @@ is or else (Slot_Ptr_Type_8192'First = RFLX_Types.Index'First and then Slot_Ptr_Type_8192'Last = RFLX_Types.Index'First + 8191); - Slot_Ptr_1 : Slot_Ptr_Type_1024; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_1024; + Slot_Ptr_2 : Slot_Ptr_Type_8192; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_8192; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null); - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null); + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null); - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with Post => - Initialized; + Initialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 /= null); + procedure Finalize (S : in out Slots) with + Post => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 /= null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_integration_multiple/generated/rflx-b-session.adb b/tests/integration/session_integration_multiple/generated/rflx-b-session.adb index e4261d9574..024ed12b11 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-b-session.adb +++ b/tests/integration/session_integration_multiple/generated/rflx-b-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,109 +8,93 @@ package body RFLX.B.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (M_Ctx); - P_Next_State := S_Terminated; + Universal.Message.Verify_Message (Ctx.P.M_Ctx); + Ctx.P.Next_State := S_Terminated; end Start; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is M_Buffer : RFLX_Types.Bytes_Ptr; begin - B.Session_Allocator.Initialize; - M_Buffer := B.Session_Allocator.Slot_Ptr_1; + B.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + M_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - B.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (M_Ctx, M_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.M_Ctx, M_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is M_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (M_Ctx, M_Buffer); - pragma Warnings (On, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, "unused assignment"); - B.Session_Allocator.Slot_Ptr_1 := M_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.M_Ctx, M_Buffer); + pragma Warnings (On, """Ctx.P.M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := M_Buffer; + B.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (M_Ctx, M_Ctx.First, M_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.M_Ctx, Ctx.P.M_Ctx.First, Ctx.P.M_Ctx.First - 1); when S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -122,9 +107,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (M_Ctx, Offset); + Universal_Message_Write (Ctx.P.M_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_integration_multiple/generated/rflx-b-session.ads b/tests/integration/session_integration_multiple/generated/rflx-b-session.ads index 27f6853114..38634d60bc 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-b-session.ads +++ b/tests/integration/session_integration_multiple/generated/rflx-b-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.B.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.B.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,83 +18,109 @@ is type State is (S_Start, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - M_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (M_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (M_Ctx) - and then M_Ctx.Buffer_First = RFLX_Types.Index'First - and then M_Ctx.Buffer_Last = RFLX_Types.Index'First + 2047 - and then B.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + M_Ctx : Universal.Message.Context; + Slots : B.Session_Allocator.Slots; + Memory : B.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.M_Ctx) + and B.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.M_Ctx) + and then Ctx.P.M_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.M_Ctx.Buffer_Last = RFLX_Types.Index'First + 2047 + and then B.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.B.Session; diff --git a/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.adb b/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.adb index 99921569b1..bf909cfc74 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.adb +++ b/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.B.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 2047 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.B.Session_Allocator; diff --git a/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.ads b/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.ads index 9ffe040493..e5f5f0ad72 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.ads +++ b/tests/integration/session_integration_multiple/generated/rflx-b-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.B.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 2047) := (others => 0); + end record; subtype Slot_Ptr_Type_2048 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_2048'First = RFLX_Types.Index'First and then Slot_Ptr_Type_2048'Last = RFLX_Types.Index'First + 2047); - Slot_Ptr_1 : Slot_Ptr_Type_2048; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_2048; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.B.Session_Allocator; diff --git a/tests/integration/session_integration_multiple/generated/rflx-test-session.adb b/tests/integration/session_integration_multiple/generated/rflx-test-session.adb index b9a3450e56..414051dab0 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-test-session.adb +++ b/tests/integration/session_integration_multiple/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,109 +8,93 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (M_Ctx); - P_Next_State := S_Terminated; + Universal.Message.Verify_Message (Ctx.P.M_Ctx); + Ctx.P.Next_State := S_Terminated; end Start; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is M_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - M_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + M_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (M_Ctx, M_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.M_Ctx, M_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is M_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (M_Ctx, M_Buffer); - pragma Warnings (On, """M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""M_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := M_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.M_Ctx, M_Buffer); + pragma Warnings (On, """Ctx.P.M_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := M_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (M_Ctx, M_Ctx.First, M_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.M_Ctx, Ctx.P.M_Ctx.First, Ctx.P.M_Ctx.First - 1); when S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -122,9 +107,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (M_Ctx, Offset); + Universal_Message_Write (Ctx.P.M_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_integration_multiple/generated/rflx-test-session.ads b/tests/integration/session_integration_multiple/generated/rflx-test-session.ads index 4c6c412f42..8021fe45b4 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-test-session.ads +++ b/tests/integration/session_integration_multiple/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,83 +18,109 @@ is type State is (S_Start, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - M_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (M_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (M_Ctx) - and then M_Ctx.Buffer_First = RFLX_Types.Index'First - and then M_Ctx.Buffer_Last = RFLX_Types.Index'First + 1023 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + M_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.M_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.M_Ctx) + and then Ctx.P.M_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.M_Ctx.Buffer_Last = RFLX_Types.Index'First + 1023 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.adb b/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.adb index 89d53db69c..e1ad070138 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 1023 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.ads b/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.ads index 2b3696d17c..07728fb76f 100644 --- a/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_integration_multiple/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 1023) := (others => 0); + end record; subtype Slot_Ptr_Type_1024 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_1024'First = RFLX_Types.Index'First and then Slot_Ptr_Type_1024'Last = RFLX_Types.Index'First + 1023); - Slot_Ptr_1 : Slot_Ptr_Type_1024; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_1024; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_minimal/generated/rflx-test-session.adb b/tests/integration/session_minimal/generated/rflx-test-session.adb index 5edee68753..fae04c6842 100644 --- a/tests/integration/session_minimal/generated/rflx-test-session.adb +++ b/tests/integration/session_minimal/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,120 +8,98 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); - if Universal.Message.Structural_Valid_Message (Message_Ctx) then - P_Next_State := S_Reply; + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); + if Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) then + Ctx.P.Next_State := S_Reply; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -138,40 +117,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -184,9 +150,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_minimal/generated/rflx-test-session.ads b/tests/integration/session_minimal/generated/rflx-test-session.ads index d6d3da6396..7dadd990d6 100644 --- a/tests/integration/session_minimal/generated/rflx-test-session.ads +++ b/tests/integration/session_minimal/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,147 @@ is type State is (S_Start, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_minimal/generated/rflx-test-session_allocator.adb b/tests/integration/session_minimal/generated/rflx-test-session_allocator.adb index a55f641bf8..e1ad070138 100644 --- a/tests/integration/session_minimal/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_minimal/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_minimal/generated/rflx-test-session_allocator.ads b/tests/integration/session_minimal/generated/rflx-test-session_allocator.ads index 17e830e759..2d0256b13a 100644 --- a/tests/integration/session_minimal/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_minimal/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_reuse_of_message/generated/rflx-test-session.adb b/tests/integration/session_reuse_of_message/generated/rflx-test-session.adb index 5c37561e1f..1adb5ec745 100644 --- a/tests/integration/session_reuse_of_message/generated/rflx-test-session.adb +++ b/tests/integration/session_reuse_of_message/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.RFLX_Types; @@ -7,120 +8,98 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); - if Universal.Message.Byte_Size (Message_Ctx) > 0 then - P_Next_State := S_Reply; + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); + if Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0 then + Ctx.P.Next_State := S_Reply; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Start; + Ctx.P.Next_State := S_Start; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -138,40 +117,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -184,9 +150,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_reuse_of_message/generated/rflx-test-session.ads b/tests/integration/session_reuse_of_message/generated/rflx-test-session.ads index d6d3da6396..7dadd990d6 100644 --- a/tests/integration/session_reuse_of_message/generated/rflx-test-session.ads +++ b/tests/integration/session_reuse_of_message/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,147 @@ is type State is (S_Start, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.adb b/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.adb index a55f641bf8..e1ad070138 100644 --- a/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.ads b/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.ads index 17e830e759..2d0256b13a 100644 --- a/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_reuse_of_message/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_sequence_append_head/generated/rflx-test-session.adb b/tests/integration/session_sequence_append_head/generated/rflx-test-session.adb index c23654b475..3e1156c6f7 100644 --- a/tests/integration/session_sequence_append_head/generated/rflx-test-session.adb +++ b/tests/integration/session_sequence_append_head/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.TLV; @@ -9,27 +10,27 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is Message_Tag : TLV.Tag; Tag : TLV.Tag; RFLX_Exception : Boolean := False; begin if - not TLV.Messages.Has_Element (Messages_Ctx) - or TLV.Messages.Available_Space (Messages_Ctx) < 32 + not TLV.Messages.Has_Element (Ctx.P.Messages_Ctx) + or TLV.Messages.Available_Space (Ctx.P.Messages_Ctx) < 32 then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; declare RFLX_Element_Messages_Ctx : TLV.Message.Context; begin - TLV.Messages.Switch (Messages_Ctx, RFLX_Element_Messages_Ctx); + TLV.Messages.Switch (Ctx.P.Messages_Ctx, RFLX_Element_Messages_Ctx); TLV.Message.Set_Tag (RFLX_Element_Messages_Ctx, TLV.Msg_Data); TLV.Message.Set_Length (RFLX_Element_Messages_Ctx, 1); if TLV.Message.Valid_Length (RFLX_Element_Messages_Ctx, TLV.Message.F_Value, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then @@ -37,39 +38,37 @@ is else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Element_Messages_Ctx"""); pragma Warnings (Off, """RFLX_Element_Messages_Ctx"" is set by ""Update"" but not used after the call"); - TLV.Messages.Update (Messages_Ctx, RFLX_Element_Messages_Ctx); + TLV.Messages.Update (Ctx.P.Messages_Ctx, RFLX_Element_Messages_Ctx); pragma Warnings (On, """RFLX_Element_Messages_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Element_Messages_Ctx"""); end; if RFLX_Exception then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if - not TLV.Tags.Has_Element (Tags_Ctx) - or TLV.Tags.Available_Space (Tags_Ctx) < TLV.Tag'Size + not TLV.Tags.Has_Element (Ctx.P.Tags_Ctx) + or TLV.Tags.Available_Space (Ctx.P.Tags_Ctx) < TLV.Tag'Size then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - TLV.Tags.Append_Element (Tags_Ctx, TLV.Msg_Error); - if TLV.Messages.Valid (Messages_Ctx) then + TLV.Tags.Append_Element (Ctx.P.Tags_Ctx, TLV.Msg_Error); + if TLV.Messages.Valid (Ctx.P.Messages_Ctx) then declare RFLX_Copy_Messages_Ctx : TLV.Messages.Context; RFLX_Copy_Messages_Buffer : RFLX_Types.Bytes_Ptr; begin - RFLX_Copy_Messages_Buffer := Test.Session_Allocator.Slot_Ptr_4; + RFLX_Copy_Messages_Buffer := Ctx.P.Slots.Slot_Ptr_4; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := null; + Ctx.P.Slots.Slot_Ptr_4 := null; pragma Warnings (On, "unused assignment"); - if TLV.Messages.Byte_Size (Messages_Ctx) <= RFLX_Copy_Messages_Buffer'Length then - TLV.Messages.Copy (Messages_Ctx, RFLX_Copy_Messages_Buffer.all (RFLX_Copy_Messages_Buffer'First .. RFLX_Copy_Messages_Buffer'First + RFLX_Types.Index (TLV.Messages.Byte_Size (Messages_Ctx) + 1) - 2)); + if TLV.Messages.Byte_Size (Ctx.P.Messages_Ctx) <= RFLX_Copy_Messages_Buffer'Length then + TLV.Messages.Copy (Ctx.P.Messages_Ctx, RFLX_Copy_Messages_Buffer.all (RFLX_Copy_Messages_Buffer'First .. RFLX_Copy_Messages_Buffer'First + RFLX_Types.Index (TLV.Messages.Byte_Size (Ctx.P.Messages_Ctx) + 1) - 2)); else RFLX_Exception := True; end if; - TLV.Messages.Initialize (RFLX_Copy_Messages_Ctx, RFLX_Copy_Messages_Buffer, RFLX_Types.To_First_Bit_Index (RFLX_Copy_Messages_Buffer'First), TLV.Messages.Sequence_Last (Messages_Ctx)); + TLV.Messages.Initialize (RFLX_Copy_Messages_Ctx, RFLX_Copy_Messages_Buffer, RFLX_Types.To_First_Bit_Index (RFLX_Copy_Messages_Buffer'First), TLV.Messages.Sequence_Last (Ctx.P.Messages_Ctx)); if TLV.Messages.Has_Element (RFLX_Copy_Messages_Ctx) then declare RFLX_Head_Ctx : TLV.Message.Context; @@ -78,190 +77,152 @@ is TLV.Messages.Switch (RFLX_Copy_Messages_Ctx, RFLX_Head_Ctx); TLV.Message.Verify_Message (RFLX_Head_Ctx); if TLV.Message.Structural_Valid_Message (RFLX_Head_Ctx) then - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - TLV.Message.Take_Buffer (Message_Ctx, RFLX_Target_Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + TLV.Message.Take_Buffer (Ctx.P.Message_Ctx, RFLX_Target_Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); if TLV.Message.Byte_Size (RFLX_Head_Ctx) <= RFLX_Target_Message_Buffer'Length then TLV.Message.Copy (RFLX_Head_Ctx, RFLX_Target_Message_Buffer.all (RFLX_Target_Message_Buffer'First .. RFLX_Target_Message_Buffer'First + RFLX_Types.Index (TLV.Message.Byte_Size (RFLX_Head_Ctx) + 1) - 2)); else RFLX_Exception := True; end if; - TLV.Message.Initialize (Message_Ctx, RFLX_Target_Message_Buffer, TLV.Message.Size (RFLX_Head_Ctx)); - TLV.Message.Verify_Message (Message_Ctx); + TLV.Message.Initialize (Ctx.P.Message_Ctx, RFLX_Target_Message_Buffer, TLV.Message.Size (RFLX_Head_Ctx)); + TLV.Message.Verify_Message (Ctx.P.Message_Ctx); else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Head_Ctx"""); pragma Warnings (Off, """RFLX_Head_Ctx"" is set by ""Update"" but not used after the call"); TLV.Messages.Update (RFLX_Copy_Messages_Ctx, RFLX_Head_Ctx); pragma Warnings (On, """RFLX_Head_Ctx"" is set by ""Update"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Head_Ctx"""); end; else RFLX_Exception := True; end if; - pragma Warnings (Off, "unused assignment to ""RFLX_Copy_Messages_Ctx"""); pragma Warnings (Off, """RFLX_Copy_Messages_Ctx"" is set by ""Take_Buffer"" but not used after the call"); TLV.Messages.Take_Buffer (RFLX_Copy_Messages_Ctx, RFLX_Copy_Messages_Buffer); pragma Warnings (On, """RFLX_Copy_Messages_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""RFLX_Copy_Messages_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_4 := RFLX_Copy_Messages_Buffer; - pragma Warnings (On, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_4 := RFLX_Copy_Messages_Buffer; end; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if RFLX_Exception then - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - if TLV.Message.Valid (Message_Ctx, TLV.Message.F_Tag) then - Message_Tag := TLV.Message.Get_Tag (Message_Ctx); + if TLV.Message.Valid (Ctx.P.Message_Ctx, TLV.Message.F_Tag) then + Message_Tag := TLV.Message.Get_Tag (Ctx.P.Message_Ctx); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if - TLV.Tags.Valid (Tags_Ctx) - and then TLV.Tags.Has_Element (Tags_Ctx) - and then TLV.Tags.Size (Tags_Ctx) >= TLV.Tag'Size + TLV.Tags.Valid (Ctx.P.Tags_Ctx) + and then TLV.Tags.Has_Element (Ctx.P.Tags_Ctx) + and then TLV.Tags.Size (Ctx.P.Tags_Ctx) >= TLV.Tag'Size then - Tag := TLV.Tags.Head (Tags_Ctx); + Tag := TLV.Tags.Head (Ctx.P.Tags_Ctx); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; if Message_Tag = TLV.Msg_Data and then Tag = TLV.Msg_Error then - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Messages_Buffer : RFLX_Types.Bytes_Ptr; Tags_Buffer : RFLX_Types.Bytes_Ptr; Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Messages_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Messages_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - TLV.Messages.Initialize (Messages_Ctx, Messages_Buffer); - Tags_Buffer := Test.Session_Allocator.Slot_Ptr_2; + TLV.Messages.Initialize (Ctx.P.Messages_Ctx, Messages_Buffer); + Tags_Buffer := Ctx.P.Slots.Slot_Ptr_2; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := null; + Ctx.P.Slots.Slot_Ptr_2 := null; pragma Warnings (On, "unused assignment"); - TLV.Tags.Initialize (Tags_Ctx, Tags_Buffer); - Message_Buffer := Test.Session_Allocator.Slot_Ptr_3; + TLV.Tags.Initialize (Ctx.P.Tags_Ctx, Tags_Buffer); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_3; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := null; + Ctx.P.Slots.Slot_Ptr_3 := null; pragma Warnings (On, "unused assignment"); - TLV.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + TLV.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Messages_Buffer : RFLX_Types.Bytes_Ptr; Tags_Buffer : RFLX_Types.Bytes_Ptr; Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Messages_Ctx"""); - pragma Warnings (Off, """Messages_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - TLV.Messages.Take_Buffer (Messages_Ctx, Messages_Buffer); - pragma Warnings (On, """Messages_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Messages_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Messages_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Tags_Ctx"""); - pragma Warnings (Off, """Tags_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - TLV.Tags.Take_Buffer (Tags_Ctx, Tags_Buffer); - pragma Warnings (On, """Tags_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Tags_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_2 := Tags_Buffer; - pragma Warnings (On, "unused assignment"); - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - TLV.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_3 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Messages_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + TLV.Messages.Take_Buffer (Ctx.P.Messages_Ctx, Messages_Buffer); + pragma Warnings (On, """Ctx.P.Messages_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Messages_Buffer; + pragma Warnings (Off, """Ctx.P.Tags_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + TLV.Tags.Take_Buffer (Ctx.P.Tags_Ctx, Tags_Buffer); + pragma Warnings (On, """Ctx.P.Tags_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_2 := Tags_Buffer; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + TLV.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_3 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - TLV.Message.Structural_Valid_Message (Message_Ctx) - and TLV.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - TLV.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -279,9 +240,9 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - TLV_Message_Read (Message_Ctx); + TLV_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; diff --git a/tests/integration/session_sequence_append_head/generated/rflx-test-session.ads b/tests/integration/session_sequence_append_head/generated/rflx-test-session.ads index 2e67b068a3..0802534a00 100644 --- a/tests/integration/session_sequence_append_head/generated/rflx-test-session.ads +++ b/tests/integration/session_sequence_append_head/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -7,11 +8,8 @@ with RFLX.TLV.Messages; with RFLX.TLV.Tags; with RFLX.TLV.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -22,98 +20,127 @@ is type State is (S_Start, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Messages_Ctx : TLV.Messages.Context; - - Tags_Ctx : TLV.Tags.Context; - - Message_Ctx : TLV.Message.Context; - - function Uninitialized return Boolean is - (not TLV.Messages.Has_Buffer (Messages_Ctx) - and not TLV.Tags.Has_Buffer (Tags_Ctx) - and not TLV.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (TLV.Messages.Has_Buffer (Messages_Ctx) - and then Messages_Ctx.Buffer_First = RFLX_Types.Index'First - and then Messages_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then TLV.Tags.Has_Buffer (Tags_Ctx) - and then Tags_Ctx.Buffer_First = RFLX_Types.Index'First - and then Tags_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then TLV.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 8095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Messages_Ctx : TLV.Messages.Context; + Tags_Ctx : TLV.Tags.Context; + Message_Ctx : TLV.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not TLV.Messages.Has_Buffer (Ctx.P.Messages_Ctx) + and not TLV.Tags.Has_Buffer (Ctx.P.Tags_Ctx) + and not TLV.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (TLV.Messages.Has_Buffer (Ctx.P.Messages_Ctx) + and then Ctx.P.Messages_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Messages_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then TLV.Tags.Has_Buffer (Ctx.P.Tags_Ctx) + and then Ctx.P.Tags_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Tags_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then TLV.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 8095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + TLV.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and TLV.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + TLV.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); end RFLX.Test.Session; diff --git a/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.adb b/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.adb index 5a42f86a1e..ff7c73e88c 100644 --- a/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.adb @@ -5,26 +5,28 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_2 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - Slot_3 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095 => RFLX_Types.Byte'First); - - Slot_4 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095 => RFLX_Types.Byte'First); - - Slot_5 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; - Slot_Ptr_2 := Slot_2'Unrestricted_Access; - Slot_Ptr_3 := Slot_3'Unrestricted_Access; - Slot_Ptr_4 := Slot_4'Unrestricted_Access; - Slot_Ptr_5 := Slot_5'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; + S.Slot_Ptr_2 := M.Slot_2'Unrestricted_Access; + S.Slot_Ptr_3 := M.Slot_3'Unrestricted_Access; + S.Slot_Ptr_4 := M.Slot_4'Unrestricted_Access; + S.Slot_Ptr_5 := M.Slot_5'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + S.Slot_Ptr_2 := null; + S.Slot_Ptr_3 := null; + S.Slot_Ptr_4 := null; + S.Slot_Ptr_5 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.ads b/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.ads index 8afae63e34..e4484e6c19 100644 --- a/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_sequence_append_head/generated/rflx-test-session_allocator.ads @@ -10,7 +10,14 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_2 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + Slot_3 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095) := (others => 0); + Slot_4 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 8095) := (others => 0); + Slot_5 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -24,32 +31,42 @@ is or else (Slot_Ptr_Type_8096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_8096'Last = RFLX_Types.Index'First + 8095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + Slot_Ptr_2 : Slot_Ptr_Type_4096; + Slot_Ptr_3 : Slot_Ptr_Type_8096; + Slot_Ptr_4 : Slot_Ptr_Type_8096; + Slot_Ptr_5 : Slot_Ptr_Type_4096; + end record; - Slot_Ptr_2 : Slot_Ptr_Type_4096; + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null + and S.Slot_Ptr_2 /= null + and S.Slot_Ptr_3 /= null + and S.Slot_Ptr_4 /= null + and S.Slot_Ptr_5 /= null); - Slot_Ptr_3 : Slot_Ptr_Type_8096; + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null + and S.Slot_Ptr_4 = null + and S.Slot_Ptr_5 = null); - Slot_Ptr_4 : Slot_Ptr_Type_8096; - - Slot_Ptr_5 : Slot_Ptr_Type_4096; - - function Initialized return Boolean is - (Slot_Ptr_1 /= null - and Slot_Ptr_2 /= null - and Slot_Ptr_3 /= null - and Slot_Ptr_4 /= null - and Slot_Ptr_5 /= null); + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); - procedure Initialize with + procedure Finalize (S : in out Slots) with Post => - Initialized; - - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null - and Slot_Ptr_2 = null - and Slot_Ptr_3 = null - and Slot_Ptr_4 /= null - and Slot_Ptr_5 /= null); + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null + and S.Slot_Ptr_2 = null + and S.Slot_Ptr_3 = null + and S.Slot_Ptr_4 /= null + and S.Slot_Ptr_5 /= null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_simple/generated/rflx-test-session.adb b/tests/integration/session_simple/generated/rflx-test-session.adb index a028011e25..3ba077f30c 100644 --- a/tests/integration/session_simple/generated/rflx-test-session.adb +++ b/tests/integration/session_simple/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -10,150 +11,128 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); if - (Universal.Message.Structural_Valid_Message (Message_Ctx) = True - and then Universal.Message.Get_Message_Type (Message_Ctx) = Universal.MT_Data) - and then Universal.Message.Get_Length (Message_Ctx) = 1 + (Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) = True + and then Universal.Message.Get_Message_Type (Ctx.P.Message_Ctx) = Universal.MT_Data) + and then Universal.Message.Get_Length (Ctx.P.Message_Ctx) = 1 then - P_Next_State := S_Process; + Ctx.P.Next_State := S_Process; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= 32 then - Universal.Message.Reset (Message_Ctx, RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 32 - 1); - Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Data); - Universal.Message.Set_Length (Message_Ctx, 1); - if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then - Universal.Message.Set_Data (Message_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 1 >= 32 then + Universal.Message.Reset (Ctx.P.Message_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 32 - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Data); + Universal.Message.Set_Length (Ctx.P.Message_Ctx, 1); + if Universal.Message.Valid_Length (Ctx.P.Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then + Universal.Message.Set_Data (Ctx.P.Message_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - P_Next_State := S_Reply; + Ctx.P.Next_State := S_Reply; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -171,40 +150,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -217,9 +183,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_simple/generated/rflx-test-session.ads b/tests/integration/session_simple/generated/rflx-test-session.ads index 54ff073742..6cf5e99e1f 100644 --- a/tests/integration/session_simple/generated/rflx-test-session.ads +++ b/tests/integration/session_simple/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,102 +18,147 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_simple/generated/rflx-test-session_allocator.adb b/tests/integration/session_simple/generated/rflx-test-session_allocator.adb index a55f641bf8..e1ad070138 100644 --- a/tests/integration/session_simple/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_simple/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_simple/generated/rflx-test-session_allocator.ads b/tests/integration/session_simple/generated/rflx-test-session_allocator.ads index 17e830e759..2d0256b13a 100644 --- a/tests/integration/session_simple/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_simple/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_variable_initialization/generated/rflx-test-session.adb b/tests/integration/session_variable_initialization/generated/rflx-test-session.adb index b03063bf79..a472ad8769 100644 --- a/tests/integration/session_variable_initialization/generated/rflx-test-session.adb +++ b/tests/integration/session_variable_initialization/generated/rflx-test-session.adb @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Universal; @@ -9,149 +10,128 @@ package body RFLX.Test.Session with SPARK_Mode is - procedure Start (P_Next_State : out State) with + procedure Start (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - Universal.Message.Verify_Message (Message_Ctx); - P_Next_State := S_Process; + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); + Ctx.P.Next_State := S_Process; end Start; - procedure Process (P_Next_State : out State) with + procedure Process (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is Local : Universal.Value := 2; begin - if Universal.Message.Valid (Message_Ctx, Universal.Message.F_Value) then - Local := Local + Universal.Message.Get_Value (Message_Ctx); + if Universal.Message.Valid (Ctx.P.Message_Ctx, Universal.Message.F_Value) then + Local := Local + Universal.Message.Get_Value (Ctx.P.Message_Ctx); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - Global := Local + 20; - if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= 32 then - Universal.Message.Reset (Message_Ctx, RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 32 - 1); - Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Value); - Universal.Message.Set_Length (Message_Ctx, Universal.Length (Universal.Value'Size / 8)); - Universal.Message.Set_Value (Message_Ctx, Global); + Ctx.P.Global := Local + 20; + if RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 1 >= 32 then + Universal.Message.Reset (Ctx.P.Message_Ctx, RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (Ctx.P.Message_Ctx.Buffer_First) + 32 - 1); + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Value); + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Universal.Length (Universal.Value'Size / 8)); + Universal.Message.Set_Value (Ctx.P.Message_Ctx, Ctx.P.Global); else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; return; end if; - if Local < Global then - P_Next_State := S_Reply; + if Local < Ctx.P.Global then + Ctx.P.Next_State := S_Reply; else - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end if; end Process; - procedure Reply (P_Next_State : out State) with + procedure Reply (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - P_Next_State := S_Terminated; + Ctx.P.Next_State := S_Terminated; end Reply; - procedure Initialize is + procedure Initialize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - Test.Session_Allocator.Initialize; - Message_Buffer := Test.Session_Allocator.Slot_Ptr_1; + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Ctx.P.Global := 11; + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := null; + Ctx.P.Slots.Slot_Ptr_1 := null; pragma Warnings (On, "unused assignment"); - Universal.Message.Initialize (Message_Ctx, Message_Buffer); - P_Next_State := S_Start; + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; end Initialize; - procedure Finalize is + procedure Finalize (Ctx : in out Context'Class) is Message_Buffer : RFLX_Types.Bytes_Ptr; begin - pragma Warnings (Off, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - Universal.Message.Take_Buffer (Message_Ctx, Message_Buffer); - pragma Warnings (On, """Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); - pragma Warnings (On, "unused assignment to ""Message_Ctx"""); - pragma Warnings (Off, "unused assignment"); - Test.Session_Allocator.Slot_Ptr_1 := Message_Buffer; - pragma Warnings (On, "unused assignment"); - P_Next_State := S_Terminated; + pragma Warnings (Off, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Universal.Message.Take_Buffer (Ctx.P.Message_Ctx, Message_Buffer); + pragma Warnings (On, """Ctx.P.Message_Ctx"" is set by ""Take_Buffer"" but not used after the call"); + Ctx.P.Slots.Slot_Ptr_1 := Message_Buffer; + Test.Session_Allocator.Finalize (Ctx.P.Slots); + Ctx.P.Next_State := S_Terminated; end Finalize; - procedure Reset_Messages_Before_Write with + procedure Reset_Messages_Before_Write (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized + Initialized (Ctx) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal.Message.Reset (Message_Ctx, Message_Ctx.First, Message_Ctx.First - 1); + Universal.Message.Reset (Ctx.P.Message_Ctx, Ctx.P.Message_Ctx.First, Ctx.P.Message_Ctx.First - 1); when S_Process | S_Reply | S_Terminated => null; end case; end Reset_Messages_Before_Write; - procedure Tick is + procedure Tick (Ctx : in out Context'Class) is begin - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Start (P_Next_State); + Start (Ctx); when S_Process => - Process (P_Next_State); + Process (Ctx); when S_Reply => - Reply (P_Next_State); + Reply (Ctx); when S_Terminated => null; end case; - Reset_Messages_Before_Write; + Reset_Messages_Before_Write (Ctx); end Tick; - function In_IO_State return Boolean is - (P_Next_State in S_Start | S_Reply); + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); - procedure Run is + procedure Run (Ctx : in out Context'Class) is begin - Tick; + Tick (Ctx); while - Active - and not In_IO_State + Active (Ctx) + and not In_IO_State (Ctx) loop - pragma Loop_Invariant (Initialized); - Tick; + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); end loop; end Run; - function Has_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Structural_Valid_Message (Message_Ctx) - and Universal.Message.Byte_Size (Message_Ctx) > 0, - when others => - False))); - - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Reply => - Universal.Message.Byte_Size (Message_Ctx), - when others => - raise Program_Error))); - - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is function Read_Pre (Message_Buffer : RFLX_Types.Bytes) return Boolean is (Buffer'Length > 0 and then Offset < Message_Buffer'Length); @@ -169,40 +149,27 @@ is Buffer := (others => 0); case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Reply => - Universal_Message_Read (Message_Ctx); + Universal_Message_Read (Ctx.P.Message_Ctx); when others => raise Program_Error; end case; end case; end Read; - function Needs_Data (Chan : Channel) return Boolean is - ((case Chan is - when C_Channel => - (case P_Next_State is - when S_Start => - True, - when others => - False))); - - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length is - ((case Chan is - when C_Channel => - 4096)); - - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) is + Write_Buffer_Length : constant RFLX_Types.Length := Write_Buffer_Size (Ctx, Chan); function Write_Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is (Buffer'Length > 0 - and then Context_Buffer_Length = Write_Buffer_Size (Chan) + and then Context_Buffer_Length = Write_Buffer_Length and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan)); + and then Buffer'Length + Offset <= Write_Buffer_Length); procedure Write (Message_Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) with Pre => Write_Pre (Context_Buffer_Length, Offset) and then Offset <= RFLX_Types.Length'Last - Message_Buffer'Length - and then Message_Buffer'Length + Offset = Write_Buffer_Size (Chan), + and then Message_Buffer'Length + Offset = Write_Buffer_Length, Post => Length <= Message_Buffer'Length is @@ -215,9 +182,9 @@ is begin case Chan is when C_Channel => - case P_Next_State is + case Ctx.P.Next_State is when S_Start => - Universal_Message_Write (Message_Ctx, Offset); + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); when others => raise Program_Error; end case; diff --git a/tests/integration/session_variable_initialization/generated/rflx-test-session.ads b/tests/integration/session_variable_initialization/generated/rflx-test-session.ads index f1b4b7daa5..6fcf036125 100644 --- a/tests/integration/session_variable_initialization/generated/rflx-test-session.ads +++ b/tests/integration/session_variable_initialization/generated/rflx-test-session.ads @@ -1,3 +1,4 @@ +pragma Restrictions (No_Streams); pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); pragma Warnings (Off, "redundant conversion"); with RFLX.Test.Session_Allocator; @@ -5,11 +6,8 @@ with RFLX.RFLX_Types; with RFLX.Universal; with RFLX.Universal.Message; -generic package RFLX.Test.Session with - SPARK_Mode, - Initial_Condition => - Uninitialized + SPARK_Mode is use type RFLX.RFLX_Types.Index; @@ -20,104 +18,148 @@ is type State is (S_Start, S_Process, S_Reply, S_Terminated); - function Uninitialized return Boolean; + type Private_Context is private; - function Initialized return Boolean; + type Context is abstract tagged + record + P : Private_Context; + end record; - function Active return Boolean; + function Uninitialized (Ctx : Context'Class) return Boolean; - procedure Initialize with + function Initialized (Ctx : Context'Class) return Boolean; + + function Active (Ctx : Context'Class) return Boolean; + + procedure Initialize (Ctx : in out Context'Class) with Pre => - Uninitialized, + Uninitialized (Ctx), Post => - Initialized - and Active; + Initialized (Ctx) + and Active (Ctx); - procedure Finalize with + procedure Finalize (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Uninitialized - and not Active; + Uninitialized (Ctx) + and not Active (Ctx); pragma Warnings (Off, "subprogram ""Tick"" has no effect"); - procedure Tick with + procedure Tick (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Tick"" has no effect"); pragma Warnings (Off, "subprogram ""Run"" has no effect"); - procedure Run with + procedure Run (Ctx : in out Context'Class) with Pre => - Initialized, + Initialized (Ctx), Post => - Initialized; + Initialized (Ctx); pragma Warnings (On, "subprogram ""Run"" has no effect"); - function Next_State return State; + function Next_State (Ctx : Context'Class) return State; - function Has_Data (Chan : Channel) return Boolean with + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Read_Buffer_Size (Chan : Channel) return RFLX_Types.Length with + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with Pre => - Initialized - and then Has_Data (Chan); + Initialized (Ctx) + and then Has_Data (Ctx, Chan); - procedure Read (Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Has_Data (Chan) + Initialized (Ctx) + and then Has_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Read_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Read_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); - function Needs_Data (Chan : Channel) return Boolean with + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with Pre => - Initialized; + Initialized (Ctx); - function Write_Buffer_Size (Chan : Channel) return RFLX_Types.Length; + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length; - procedure Write (Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with Pre => - Initialized - and then Needs_Data (Chan) + Initialized (Ctx) + and then Needs_Data (Ctx, Chan) and then Buffer'Length > 0 and then Offset <= RFLX_Types.Length'Last - Buffer'Length - and then Buffer'Length + Offset <= Write_Buffer_Size (Chan), + and then Buffer'Length + Offset <= Write_Buffer_Size (Ctx, Chan), Post => - Initialized; + Initialized (Ctx); private - P_Next_State : State := S_Start; - - Global : Universal.Value := 11; - - Message_Ctx : Universal.Message.Context; - - function Uninitialized return Boolean is - (not Universal.Message.Has_Buffer (Message_Ctx)); - - function Initialized return Boolean is - (Universal.Message.Has_Buffer (Message_Ctx) - and then Message_Ctx.Buffer_First = RFLX_Types.Index'First - and then Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 - and then Test.Session_Allocator.Global_Allocated); - - function Active return Boolean is - (P_Next_State /= S_Terminated); - - function Next_State return State is - (P_Next_State); + type Private_Context is + record + Next_State : State := S_Start; + Global : Universal.Value := 11; + Message_Ctx : Universal.Message.Context; + Slots : Test.Session_Allocator.Slots; + Memory : Test.Session_Allocator.Memory; + end record; + + function Uninitialized (Ctx : Context'Class) return Boolean is + (not Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and Test.Session_Allocator.Uninitialized (Ctx.P.Slots)); + + function Initialized (Ctx : Context'Class) return Boolean is + (Universal.Message.Has_Buffer (Ctx.P.Message_Ctx) + and then Ctx.P.Message_Ctx.Buffer_First = RFLX_Types.Index'First + and then Ctx.P.Message_Ctx.Buffer_Last = RFLX_Types.Index'First + 4095 + and then Test.Session_Allocator.Global_Allocated (Ctx.P.Slots)); + + function Active (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State /= S_Terminated); + + function Next_State (Ctx : Context'Class) return State is + (Ctx.P.Next_State); + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Structural_Valid_Message (Ctx.P.Message_Ctx) + and Universal.Message.Byte_Size (Ctx.P.Message_Ctx) > 0, + when others => + False))); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Reply => + Universal.Message.Byte_Size (Ctx.P.Message_Ctx), + when others => + raise Program_Error))); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + True, + when others => + False))); + + function Write_Buffer_Size (Unused_Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + 4096)); end RFLX.Test.Session; diff --git a/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.adb b/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.adb index a55f641bf8..e1ad070138 100644 --- a/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.adb +++ b/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.adb @@ -5,14 +5,20 @@ package body RFLX.Test.Session_Allocator with SPARK_Mode is - Slot_1 : aliased RFLX_Types.Bytes := (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095 => RFLX_Types.Byte'First); - - procedure Initialize with + procedure Initialize (S : out Slots; M : Memory) with SPARK_Mode => Off is begin - Slot_Ptr_1 := Slot_1'Unrestricted_Access; + S.Slot_Ptr_1 := M.Slot_1'Unrestricted_Access; end Initialize; + procedure Finalize (S : in out Slots) with + SPARK_Mode => + Off + is + begin + S.Slot_Ptr_1 := null; + end Finalize; + end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.ads b/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.ads index 17e830e759..2d0256b13a 100644 --- a/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.ads +++ b/tests/integration/session_variable_initialization/generated/rflx-test-session_allocator.ads @@ -10,7 +10,10 @@ package RFLX.Test.Session_Allocator with (GNATprove, Terminating) is - pragma Elaborate_Body; + type Memory is + record + Slot_1 : aliased RFLX_Types.Bytes (RFLX_Types.Index'First .. RFLX_Types.Index'First + 4095) := (others => 0); + end record; subtype Slot_Ptr_Type_4096 is RFLX_Types.Bytes_Ptr with Dynamic_Predicate => @@ -18,16 +21,26 @@ is or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); - Slot_Ptr_1 : Slot_Ptr_Type_4096; + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; - function Initialized return Boolean is - (Slot_Ptr_1 /= null); + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); - procedure Initialize with + function Uninitialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + + procedure Initialize (S : out Slots; M : Memory) with + Post => + Initialized (S); + + procedure Finalize (S : in out Slots) with Post => - Initialized; + Uninitialized (S); - function Global_Allocated return Boolean is - (Slot_Ptr_1 = null); + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); end RFLX.Test.Session_Allocator; diff --git a/tests/unit/ada_test.py b/tests/unit/ada_test.py index a9bf98a4b2..5664177673 100644 --- a/tests/unit/ada_test.py +++ b/tests/unit/ada_test.py @@ -439,8 +439,32 @@ def test_conversion_str() -> None: assert str(ada.Not(ada.Conversion("A", ada.Variable("B")))) == "not A (B)" -def test_import() -> None: - assert str(ada.Import()) == "Import" +@pytest.mark.parametrize( + "aspect, expected", + [ + (ada.Precondition(ada.Variable("X")), "Pre =>\n X"), + (ada.Postcondition(ada.Variable("X")), "Post =>\n X"), + (ada.ClassPrecondition(ada.Variable("X")), "Pre'Class =>\n X"), + (ada.ClassPostcondition(ada.Variable("X")), "Post'Class =>\n X"), + ( + ada.ContractCases((ada.Variable("X"), ada.Variable("Y"))), + "Contract_Cases =>\n (X =>\n Y)", + ), + (ada.Depends({"X": ["Y", "Z"]}), "Depends =>\n (X => (Y, Z))"), + (ada.DynamicPredicate(ada.Variable("X")), "Dynamic_Predicate =>\n X"), + (ada.SizeAspect(ada.Variable("X")), "Size =>\n X"), + (ada.InitialCondition(ada.Variable("X")), "Initial_Condition =>\n X"), + (ada.DefaultInitialCondition(ada.Variable("X")), "Default_Initial_Condition =>\n X"), + (ada.SparkMode(), "SPARK_Mode"), + (ada.SparkMode(off=True), "SPARK_Mode =>\n Off"), + (ada.Ghost(), "Ghost"), + (ada.Import(), "Import"), + (ada.Annotate("X"), "Annotate =>\n (X)"), + (ada.ElaborateBody(), "Elaborate_Body"), + ], +) +def test_aspects(aspect: ada.Aspect, expected: str) -> None: + assert str(aspect) == expected def test_formal_package_declaration() -> None: @@ -449,6 +473,16 @@ def test_formal_package_declaration() -> None: ) +def test_generic_package_instantiation() -> None: + assert ( + str(ada.GenericPackageInstantiation("A", "B", ["C", "D"])) == "package A is new B (C, D);" + ) + + +def test_generic_package_instantiation_hash() -> None: + assert hash(ada.GenericPackageInstantiation("A", "B", ["C", "D"])) is not None + + def test_package_renaming_declaration() -> None: assert str(ada.PackageRenamingDeclaration("A", "B")) == "package A renames B;" @@ -466,6 +500,10 @@ def test_range_subtype() -> None: def test_derived_type() -> None: assert str(ada.DerivedType("A", "B")) == "type A is new B;" + assert ( + str(ada.DerivedType("A", "B", [ada.Component("C", "D")])) + == "type A is new B with\n record\n C : D;\n end record;" + ) def test_private_type() -> None: @@ -484,6 +522,14 @@ def test_unconstrained_array_type() -> None: assert str(ada.UnconstrainedArrayType("A", "B", "C")) == "type A is array (B range <>) of C;" +def test_record_type() -> None: + assert str(ada.RecordType("A", [])) == "type A is null record;" + assert ( + str(ada.RecordType("A", [ada.Component("B", "C")])) + == "type A is\n record\n B : C;\n end record;" + ) + + def test_access_type() -> None: assert str(ada.AccessType("A", "B")) == "type A is access B;" diff --git a/tests/unit/generator_test.py b/tests/unit/generator_test.py index f068342a0d..5f775077d7 100644 --- a/tests/unit/generator_test.py +++ b/tests/unit/generator_test.py @@ -308,28 +308,26 @@ def test_full_base_type_name() -> None: @pytest.mark.parametrize( "parameter, expected", [ - ( - decl.ChannelDeclaration("Channel", readable=True, writable=False), # §S-P-C-R - [], - ), - ( - decl.ChannelDeclaration("Channel", readable=False, writable=True), # §S-P-C-W - [], - ), - ( - decl.ChannelDeclaration("Channel", readable=True, writable=True), # §S-P-C-RW - [], - ), ( decl.FunctionDeclaration("F", [], "T", type_=rty.BOOLEAN), [ - ada.FormalSubprogramDeclaration( + ada.SubprogramDeclaration( specification=ada.ProcedureSpecification( identifier="F", parameters=[ - ada.OutParameter(["F"], "Boolean"), + ada.InOutParameter(["Ctx"], "Context"), + ada.OutParameter(["RFLX_Result"], "Boolean"), ], - ) + ), + aspects=[ + ada.ClassPrecondition( + ada.And( + ada.Call("Initialized", [ada.Variable("Ctx")]), + ) + ), + ada.ClassPostcondition(ada.Call("Initialized", [ada.Variable("Ctx")])), + ], + abstract=True, ), ], ), @@ -347,31 +345,41 @@ def test_full_base_type_name() -> None: type_=rty.Message("T", is_definite=True), ), [ - ada.FormalSubprogramDeclaration( + ada.SubprogramDeclaration( specification=ada.ProcedureSpecification( identifier="F", parameters=[ - ada.OutParameter(["F"], "T.Structure"), + ada.InOutParameter(["Ctx"], "Context"), ada.Parameter(["P1"], "Boolean"), ada.Parameter(["P2"], const.TYPES_BYTES), ada.Parameter(["P3"], "T3"), ada.Parameter(["P4"], "T4"), ada.Parameter(["P5"], "T5.Structure"), + ada.OutParameter(["RFLX_Result"], "T.Structure"), ], - ) + ), + aspects=[ + ada.ClassPrecondition( + ada.And( + ada.Call("Initialized", [ada.Variable("Ctx")]), + ) + ), + ada.ClassPostcondition(ada.Call("Initialized", [ada.Variable("Ctx")])), + ], + abstract=True, ), ], ), ], ) -def test_session_create_formal_parameters( - parameter: decl.FormalDeclaration, expected: Sequence[ada.FormalDeclaration] +def test_session_create_abstract_function( + parameter: decl.FunctionDeclaration, expected: Sequence[ada.SubprogramDeclaration] ) -> None: session_generator = SessionGenerator( DUMMY_SESSION, AllocatorGenerator(DUMMY_SESSION, Integration()), debug=True ) # pylint: disable = protected-access - assert session_generator._create_formal_parameters([parameter]) == expected + assert session_generator._create_abstract_function(parameter) == expected class UnknownDeclaration(decl.FormalDeclaration, decl.BasicDeclaration): @@ -448,7 +456,7 @@ def type_(self) -> rty.Type: ), ], ) -def test_session_create_formal_parameters_error( +def test_session_create_abstract_functions_error( parameter: decl.FormalDeclaration, error_type: Type[BaseError], error_msg: str ) -> None: session_generator = SessionGenerator( @@ -457,7 +465,7 @@ def test_session_create_formal_parameters_error( with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access - session_generator._create_formal_parameters([parameter]) + session_generator._create_abstract_functions([parameter]) @pytest.mark.parametrize( @@ -479,7 +487,8 @@ def test_session_create_formal_parameters_error( decl.VariableDeclaration("X", "T", expr.Number(1), type_=rty.Integer("T")), True, EvaluatedDeclaration( - global_declarations=[ada.ObjectDeclaration("X", "P.T", ada.Number(1))] + global_declarations=[ada.ObjectDeclaration("X", "P.T", ada.Number(1))], + initialization=[ada.Assignment("Ctx.P.X", ada.Conversion("T", ada.Number(1)))], ), ), ( @@ -497,7 +506,7 @@ def test_session_create_formal_parameters_error( initialization=[ ada.Assignment( "X_Buffer", - ada.Variable("P.S_Allocator.Slot_Ptr_1"), + ada.Variable("Ctx.P.Slots.Slot_Ptr_1"), ), ada.PragmaStatement( "Warnings", @@ -506,7 +515,7 @@ def test_session_create_formal_parameters_error( ada.String("unused assignment"), ], ), - ada.Assignment(ada.Variable("P.S_Allocator.Slot_Ptr_1"), ada.Variable("null")), + ada.Assignment(ada.Variable("Ctx.P.Slots.Slot_Ptr_1"), ada.Variable("null")), ada.PragmaStatement( "Warnings", [ @@ -519,13 +528,6 @@ def test_session_create_formal_parameters_error( ), ], finalization=[ - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("Off"), - ada.String('unused assignment to "X_Ctx"'), - ], - ), ada.PragmaStatement( "Warnings", [ @@ -551,29 +553,8 @@ def test_session_create_formal_parameters_error( ), ], ), - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("On"), - ada.String('unused assignment to "X_Ctx"'), - ], - ), - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("Off"), - ada.String("unused assignment"), - ], - ), ada.Assignment( - ada.Variable("P.S_Allocator.Slot_Ptr_1"), ada.Variable("X_Buffer") - ), - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("On"), - ada.String("unused assignment"), - ], + ada.Variable("Ctx.P.Slots.Slot_Ptr_1"), ada.Variable("X_Buffer") ), ], ), @@ -591,9 +572,13 @@ def test_session_create_formal_parameters_error( ada.ObjectDeclaration(["X_Buffer"], const.TYPES_BYTES_PTR), ], initialization=[ + ada.CallStatement( + "P.S_Allocator.Initialize", + [ada.Variable("Ctx.P.Slots"), ada.Variable("Ctx.P.Memory")], + ), ada.Assignment( "X_Buffer", - ada.Variable("P.S_Allocator.Slot_Ptr_1"), + ada.Variable("Ctx.P.Slots.Slot_Ptr_1"), ), ada.PragmaStatement( "Warnings", @@ -602,7 +587,7 @@ def test_session_create_formal_parameters_error( ada.String("unused assignment"), ], ), - ada.Assignment(ada.Variable("P.S_Allocator.Slot_Ptr_1"), ada.Variable("null")), + ada.Assignment(ada.Variable("Ctx.P.Slots.Slot_Ptr_1"), ada.Variable("null")), ada.PragmaStatement( "Warnings", [ @@ -611,30 +596,23 @@ def test_session_create_formal_parameters_error( ], ), ada.CallStatement( - "P.T.Initialize", [ada.Variable("X_Ctx"), ada.Variable("X_Buffer")] + "P.T.Initialize", [ada.Variable("Ctx.P.X_Ctx"), ada.Variable("X_Buffer")] ), ], finalization=[ - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("Off"), - ada.String('unused assignment to "X_Ctx"'), - ], - ), ada.PragmaStatement( "Warnings", [ ada.Variable("Off"), ada.String( - '"X_Ctx" is set by "Take_Buffer" but not used after the call' + '"Ctx.P.X_Ctx" is set by "Take_Buffer" but not used after the call' ), ], ), ada.CallStatement( "P.T.Take_Buffer", [ - ada.Variable("X_Ctx"), + ada.Variable("Ctx.P.X_Ctx"), ada.Variable("X_Buffer"), ], ), @@ -643,34 +621,14 @@ def test_session_create_formal_parameters_error( [ ada.Variable("On"), ada.String( - '"X_Ctx" is set by "Take_Buffer" but not used after the call' + '"Ctx.P.X_Ctx" is set by "Take_Buffer" but not used after the call' ), ], ), - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("On"), - ada.String('unused assignment to "X_Ctx"'), - ], - ), - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("Off"), - ada.String("unused assignment"), - ], - ), ada.Assignment( - ada.Variable("P.S_Allocator.Slot_Ptr_1"), ada.Variable("X_Buffer") - ), - ada.PragmaStatement( - "Warnings", - [ - ada.Variable("On"), - ada.String("unused assignment"), - ], + ada.Variable("Ctx.P.Slots.Slot_Ptr_1"), ada.Variable("X_Buffer") ), + ada.CallStatement("P.S_Allocator.Finalize", [ada.Variable("Ctx.P.Slots")]), ], ), ), @@ -684,7 +642,12 @@ def test_session_evaluate_declarations( allocator._allocation_slots[Location(start=(1, 1))] = 1 session_generator = SessionGenerator(DUMMY_SESSION, allocator, debug=True) # pylint: disable = protected-access - assert session_generator._evaluate_declarations([declaration], session_global) == expected + assert ( + session_generator._evaluate_declarations( + [declaration], is_global=lambda x: False, session_global=session_global + ) + == expected + ) @pytest.mark.parametrize( @@ -716,7 +679,7 @@ def test_session_evaluate_declarations_error( with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access - session_generator._evaluate_declarations([declaration]) + session_generator._evaluate_declarations([declaration], is_global=lambda x: False) @dataclass @@ -746,6 +709,7 @@ class EvaluatedDeclarationStr: True, EvaluatedDeclarationStr( global_declarations="X : P.T := 1;", + initialization="X := T (1);", ), ), ( @@ -775,23 +739,19 @@ class EvaluatedDeclarationStr: global_declarations=("X_Ctx : P.T.Context;"), initialization_declarations=("X_Buffer : RFLX_Types.Bytes_Ptr;"), initialization=( - "X_Buffer := P.S_Allocator.Slot_Ptr_1;\n" + "X_Buffer := Ctx.P.Slots.Slot_Ptr_1;\n" 'pragma Warnings (Off, "unused assignment");\n' - "P.S_Allocator.Slot_Ptr_1 := null;\n" + "Ctx.P.Slots.Slot_Ptr_1 := null;\n" 'pragma Warnings (On, "unused assignment");\n' "P.T.Initialize (X_Ctx, X_Buffer);" ), finalization=( - 'pragma Warnings (Off, "unused assignment to ""X_Ctx""");\n' 'pragma Warnings (Off, """X_Ctx"" is set by ""Take_Buffer"" but not used after' ' the call");\n' "P.T.Take_Buffer (X_Ctx, X_Buffer);\n" 'pragma Warnings (On, """X_Ctx"" is set by ""Take_Buffer"" but not used after' ' the call");\n' - 'pragma Warnings (On, "unused assignment to ""X_Ctx""");\n' - 'pragma Warnings (Off, "unused assignment");\n' - "P.S_Allocator.Slot_Ptr_1 := X_Buffer;\n" - 'pragma Warnings (On, "unused assignment");' + "Ctx.P.Slots.Slot_Ptr_1 := X_Buffer;" ), ), ), @@ -804,23 +764,19 @@ class EvaluatedDeclarationStr: global_declarations=("X_Ctx : P.T.Context;"), initialization_declarations=("X_Buffer : RFLX_Types.Bytes_Ptr;"), initialization=( - "X_Buffer := P.S_Allocator.Slot_Ptr_1;\n" + "X_Buffer := Ctx.P.Slots.Slot_Ptr_1;\n" 'pragma Warnings (Off, "unused assignment");\n' - "P.S_Allocator.Slot_Ptr_1 := null;\n" + "Ctx.P.Slots.Slot_Ptr_1 := null;\n" 'pragma Warnings (On, "unused assignment");\n' "P.T.Initialize (X_Ctx, X_Buffer);" ), finalization=( - 'pragma Warnings (Off, "unused assignment to ""X_Ctx""");\n' 'pragma Warnings (Off, """X_Ctx"" is set by ""Take_Buffer"" but not used after' ' the call");\n' "P.T.Take_Buffer (X_Ctx, X_Buffer);\n" 'pragma Warnings (On, """X_Ctx"" is set by ""Take_Buffer"" but not used after' ' the call");\n' - 'pragma Warnings (On, "unused assignment to ""X_Ctx""");\n' - 'pragma Warnings (Off, "unused assignment");\n' - "P.S_Allocator.Slot_Ptr_1 := X_Buffer;\n" - 'pragma Warnings (On, "unused assignment");' + "Ctx.P.Slots.Slot_Ptr_1 := X_Buffer;" ), ), ), @@ -833,23 +789,19 @@ class EvaluatedDeclarationStr: global_declarations=("X_Ctx : P.T.Context;"), initialization_declarations=("X_Buffer : RFLX_Types.Bytes_Ptr;"), initialization=( - "X_Buffer := P.S_Allocator.Slot_Ptr_1;\n" + "X_Buffer := Ctx.P.Slots.Slot_Ptr_1;\n" 'pragma Warnings (Off, "unused assignment");\n' - "P.S_Allocator.Slot_Ptr_1 := null;\n" + "Ctx.P.Slots.Slot_Ptr_1 := null;\n" 'pragma Warnings (On, "unused assignment");\n' "P.T.Initialize (X_Ctx, X_Buffer);" ), finalization=( - 'pragma Warnings (Off, "unused assignment to ""X_Ctx""");\n' 'pragma Warnings (Off, """X_Ctx"" is set by ""Take_Buffer"" but not used after' ' the call");\n' "P.T.Take_Buffer (X_Ctx, X_Buffer);\n" 'pragma Warnings (On, """X_Ctx"" is set by ""Take_Buffer"" but not used after' ' the call");\n' - 'pragma Warnings (On, "unused assignment to ""X_Ctx""");\n' - 'pragma Warnings (Off, "unused assignment");\n' - "P.S_Allocator.Slot_Ptr_1 := X_Buffer;\n" - 'pragma Warnings (On, "unused assignment");' + "Ctx.P.Slots.Slot_Ptr_1 := X_Buffer;" ), ), ), @@ -979,7 +931,9 @@ def test_session_declare( allocator._allocation_slots[loc] = 1 session_generator = SessionGenerator(DUMMY_SESSION, allocator, debug=True) # pylint: disable = protected-access - result = session_generator._declare(ID("X"), type_, loc, expression, constant, session_global) + result = session_generator._declare( + ID("X"), type_, lambda x: False, loc, expression, constant, session_global + ) assert "\n".join(str(d) for d in result.global_declarations) == expected.global_declarations assert ( "\n".join(str(d) for d in result.initialization_declarations) @@ -1022,7 +976,11 @@ def test_session_declare_error( with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access session_generator._declare( - ID("X", location=Location((10, 20))), type_, expression=expression, alloc_id=None + ID("X", location=Location((10, 20))), + type_, + lambda x: False, + expression=expression, + alloc_id=None, ) @@ -1102,9 +1060,9 @@ def variables(self) -> Sequence[expr.Variable]: " C_Ctx : Universal.Option.Context;\n" " C_Buffer : RFLX_Types.Bytes_Ptr;\n" " begin\n" - " C_Buffer := P.S_Allocator.Slot_Ptr_1;\n" + " C_Buffer := Ctx.P.Slots.Slot_Ptr_1;\n" ' pragma Warnings (Off, "unused assignment");\n' - " P.S_Allocator.Slot_Ptr_1 := null;\n" + " Ctx.P.Slots.Slot_Ptr_1 := null;\n" ' pragma Warnings (On, "unused assignment");\n' " Universal.Option.Initialize (C_Ctx, C_Buffer);\n" " if RFLX_Types.To_First_Bit_Index (C_Ctx.Buffer_Last)" @@ -1158,26 +1116,22 @@ def variables(self) -> Sequence[expr.Variable]: ' Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx""");\n' " RFLX_Exception := True;\n" " end if;\n" - ' pragma Warnings (Off, "unused assignment to ""C_Ctx""");\n' ' pragma Warnings (Off, """C_Ctx"" is set by ""Take_Buffer""' ' but not used after the call");\n' " Universal.Option.Take_Buffer (C_Ctx, C_Buffer);\n" ' pragma Warnings (On, """C_Ctx"" is set by ""Take_Buffer""' ' but not used after the call");\n' - ' pragma Warnings (On, "unused assignment to ""C_Ctx""");\n' - ' pragma Warnings (Off, "unused assignment");\n' - " P.S_Allocator.Slot_Ptr_1 := C_Buffer;\n" - ' pragma Warnings (On, "unused assignment");\n' + " Ctx.P.Slots.Slot_Ptr_1 := C_Buffer;\n" " end;\n" " end;\n" " if RFLX_Exception then\n" - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" "end;\n" "if RFLX_Exception then\n" - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" "end if;", @@ -1225,7 +1179,7 @@ def variables(self) -> Sequence[expr.Variable]: " declare\n" " X : Universal.Message.Structure;\n" " begin\n" - " F (X, A, B, C);\n" + " F (Ctx, A, B, C, X);\n" " Universal.Message.To_Context (X, X_Ctx);\n" " end;\n" " end;\n" @@ -1285,9 +1239,9 @@ def variables(self) -> Sequence[expr.Variable]: " A_Ctx : Universal.Message.Context;\n" " A_Buffer : RFLX_Types.Bytes_Ptr;\n" "begin\n" - " A_Buffer := P.S_Allocator.Slot_Ptr_1;\n" + " A_Buffer := Ctx.P.Slots.Slot_Ptr_1;\n" ' pragma Warnings (Off, "unused assignment");\n' - " P.S_Allocator.Slot_Ptr_1 := null;\n" + " Ctx.P.Slots.Slot_Ptr_1 := null;\n" ' pragma Warnings (On, "unused assignment");\n' " Universal.Message.Initialize (A_Ctx, A_Buffer);\n" " if RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_Last)" @@ -1319,19 +1273,15 @@ def variables(self) -> Sequence[expr.Variable]: ' ""Universal::Option (A.Data)""");\n' " RFLX_Exception := True;\n" " end if;\n" - ' pragma Warnings (Off, "unused assignment to ""A_Ctx""");\n' ' pragma Warnings (Off, """A_Ctx"" is set by ""Take_Buffer"" but not used after the' ' call");\n' " Universal.Message.Take_Buffer (A_Ctx, A_Buffer);\n" ' pragma Warnings (On, """A_Ctx"" is set by ""Take_Buffer"" but not used after the' ' call");\n' - ' pragma Warnings (On, "unused assignment to ""A_Ctx""");\n' - ' pragma Warnings (Off, "unused assignment");\n' - " P.S_Allocator.Slot_Ptr_1 := A_Buffer;\n" - ' pragma Warnings (On, "unused assignment");\n' + " Ctx.P.Slots.Slot_Ptr_1 := A_Buffer;\n" "end;\n" "if RFLX_Exception then\n" - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" "end if;", @@ -1372,9 +1322,9 @@ def variables(self) -> Sequence[expr.Variable]: " A_Ctx : Universal.Message.Context;\n" " A_Buffer : RFLX_Types.Bytes_Ptr;\n" "begin\n" - " A_Buffer := P.S_Allocator.Slot_Ptr_1;\n" + " A_Buffer := Ctx.P.Slots.Slot_Ptr_1;\n" ' pragma Warnings (Off, "unused assignment");\n' - " P.S_Allocator.Slot_Ptr_1 := null;\n" + " Ctx.P.Slots.Slot_Ptr_1 := null;\n" ' pragma Warnings (On, "unused assignment");\n' " Universal.Message.Initialize (A_Ctx, A_Buffer);\n" " if RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_Last)" @@ -1396,19 +1346,15 @@ def variables(self) -> Sequence[expr.Variable]: ' of ""A_Ctx""");\n' " RFLX_Exception := True;\n" " end if;\n" - ' pragma Warnings (Off, "unused assignment to ""A_Ctx""");\n' ' pragma Warnings (Off, """A_Ctx"" is set by ""Take_Buffer"" but not used after the' ' call");\n' " Universal.Message.Take_Buffer (A_Ctx, A_Buffer);\n" ' pragma Warnings (On, """A_Ctx"" is set by ""Take_Buffer"" but not used after the' ' call");\n' - ' pragma Warnings (On, "unused assignment to ""A_Ctx""");\n' - ' pragma Warnings (Off, "unused assignment");\n' - " P.S_Allocator.Slot_Ptr_1 := A_Buffer;\n" - ' pragma Warnings (On, "unused assignment");\n' + " Ctx.P.Slots.Slot_Ptr_1 := A_Buffer;\n" "end;\n" "if RFLX_Exception then\n" - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" "end if;", @@ -1517,13 +1463,13 @@ def variables(self) -> Sequence[expr.Variable]: " Universal.Message.Set_Data_Empty (X_Ctx);\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: invalid message field size for ""[]""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" "else\n" ' Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" "end if;", @@ -1595,19 +1541,19 @@ def variables(self) -> Sequence[expr.Variable]: " else\n" ' Ada.Text_IO.Put_Line ("Error: invalid message field size' ' for ""Y\'Opaque""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" "else\n" ' Ada.Text_IO.Put_Line ("Error: unexpected size of ""Y""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" "end if;", @@ -1705,72 +1651,77 @@ def variables(self) -> Sequence[expr.Variable]: " if Universal.Message.Structural_Valid (Y_Ctx," " Universal.Message.F_Data) then\n" " declare\n" + ' pragma Warnings (Off, "is not modified, could be declared' + ' constant");\n' + " RFLX_Y_Ctx_Tmp : Universal.Message.Context := Y_Ctx;\n" + ' pragma Warnings (On, "is not modified, could be declared' + ' constant");\n' " function RFLX_Process_Data_Pre (Length : RFLX_Types.Length)" " return Boolean is\n" - " (Universal.Message.Has_Buffer (Y_Ctx)\n" + " (Universal.Message.Has_Buffer (RFLX_Y_Ctx_Tmp)\n" " and then Universal.Message.Structural_Valid" - " (Y_Ctx, Universal.Message.F_Data)\n" + " (RFLX_Y_Ctx_Tmp, Universal.Message.F_Data)\n" " and then Length >= RFLX_Types.To_Length" - " (Universal.Message.Field_Size (Y_Ctx, Universal.Message.F_Data)));\n" - " procedure RFLX_Process_Data" - " (Data : out RFLX_Types.Bytes) with\n" + " (Universal.Message.Field_Size (RFLX_Y_Ctx_Tmp, Universal.Message.F_Data)));\n" + " procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes)" + " with\n" " Pre =>\n" " RFLX_Process_Data_Pre (Data'Length)\n" " is\n" " begin\n" - " Universal.Message.Get_Data (Y_Ctx, Data);\n" + " Universal.Message.Get_Data (RFLX_Y_Ctx_Tmp, Data);\n" " end RFLX_Process_Data;\n" " procedure RFLX_Universal_Message_Set_Data is" " new Universal.Message.Generic_Set_Data (RFLX_Process_Data, RFLX_Process_Data_Pre);\n" " begin\n" - " RFLX_Universal_Message_Set_Data" - " (X_Ctx, RFLX_Types.To_Length (Universal.Message.Field_Size" - " (Y_Ctx, Universal.Message.F_Data)));\n" + " RFLX_Universal_Message_Set_Data (X_Ctx, RFLX_Types.To_Length" + " (Universal.Message.Field_Size (RFLX_Y_Ctx_Tmp, Universal.Message.F_Data)));\n" + " Y_Ctx := RFLX_Y_Ctx_Tmp;\n" " end;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: access to invalid message field' ' in ""Y.Data""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: invalid message field size' ' for ""Y.Data""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: access to invalid next message field' ' for ""Y.Data""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: access to invalid message field' ' in ""Y.Length""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: access to invalid message field' ' in ""Y.Message_Type""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" " else\n" ' Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" " end if;\n" "else\n" ' Ada.Text_IO.Put_Line ("Error: unexpected size of ""Y""");\n' - " P_Next_State := S_E;\n" + " Ctx.P.Next_State := S_E;\n" " pragma Finalization;\n" " return;\n" "end if;", @@ -1793,7 +1744,7 @@ def variables(self) -> Sequence[expr.Variable]: " A : Universal.Message.Structure;\n" "begin\n" " Universal.Message.To_Structure (A_Ctx, A);\n" - " F (X, A);\n" + " F (Ctx, A, X);\n" "end;", ), ( @@ -1815,7 +1766,7 @@ def variables(self) -> Sequence[expr.Variable]: " A : Universal.Message.Structure;\n" "begin\n" " Universal.Message.To_Structure (A_Ctx, A);\n" - " F (X, A);\n" + " F (Ctx, A, X);\n" " Universal.Option.To_Context (X, X_Ctx);\n" "end;", ), @@ -1850,6 +1801,7 @@ def test_session_state_action(action: stmt.Statement, expected: str) -> None: State("S", exception_transition=Transition("E")), [ada.PragmaStatement("Finalization", [])], ), + lambda x: False, ) ) == expected @@ -1907,7 +1859,12 @@ def test_session_state_action_error( with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access - session_generator._state_action(ID("S"), action, ExceptionHandler(set(), State("S"), [])) + session_generator._state_action( + ID("S"), + action, + ExceptionHandler(set(), State("S"), []), + lambda x: False, + ) @pytest.mark.parametrize( @@ -2258,6 +2215,7 @@ def test_session_assign_error( type_, expression, ExceptionHandler(set(), State("S", exception_transition=Transition("E")), []), + lambda x: False, ID("State"), alloc_id=None, ) @@ -2296,7 +2254,9 @@ def test_session_append_error( with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access session_generator._append( - append, ExceptionHandler(set(), State("S", exception_transition=Transition("E")), []) + append, + ExceptionHandler(set(), State("S", exception_transition=Transition("E")), []), + lambda x: False, ) @@ -2321,7 +2281,10 @@ def test_session_read_error(read: stmt.Read, error_type: Type[BaseError], error_ with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access - session_generator._read(read) + session_generator._read( + read, + lambda x: False, + ) @pytest.mark.parametrize( @@ -2466,7 +2429,7 @@ def test_session_substitution(expression: expr.Expr, expected: expr.Expr) -> Non DUMMY_SESSION, AllocatorGenerator(DUMMY_SESSION, Integration()), debug=True ) # pylint: disable = protected-access - assert expression.substituted(session_generator._substitution()) == expected + assert expression.substituted(session_generator._substitution(lambda x: False)) == expected @pytest.mark.parametrize( @@ -2497,7 +2460,7 @@ def test_session_substitution_error( ) with pytest.raises(error_type, match=rf"^:10:20: generator: error: {error_msg}$"): # pylint: disable = protected-access - expression.substituted(session_generator._substitution()) + expression.substituted(session_generator._substitution(lambda x: False)) @pytest.mark.parametrize( @@ -2552,8 +2515,14 @@ def test_session_substitution_equality( ) # pylint: disable = protected-access - assert relation(left, right).substituted(session_generator._substitution()) == expected - assert relation(right, left).substituted(session_generator._substitution()) == expected + assert ( + relation(left, right).substituted(session_generator._substitution(lambda x: False)) + == expected + ) + assert ( + relation(right, left).substituted(session_generator._substitution(lambda x: False)) + == expected + ) @pytest.mark.parametrize( diff --git a/tests/utils.py b/tests/utils.py index 95ceb53b62..621474decf 100644 --- a/tests/utils.py +++ b/tests/utils.py @@ -224,47 +224,52 @@ def session_main( output_channels: Sequence[str] = None, context: Sequence[ada.ContextItem] = None, subprograms: Sequence[ada.SubprogramBody] = None, - session_package: str = "RFLX.P.S", - session_parameters: Sequence[ada.StrID] = None, + session_package: ada.StrID = "RFLX.Test.Session", ) -> Mapping[str, str]: input_channels = input_channels or {} output_channels = output_channels or [] context = context or [] subprograms = subprograms or [] - session_parameters = session_parameters or [] + session_package = ada.ID(session_package) run_procedure_spec = ada.ProcedureSpecification("Run") - run_procedure_decl = ada.SubprogramDeclaration( - run_procedure_spec, - aspects=[ - ada.Precondition(ada.Variable("Session.Uninitialized")), - ada.Postcondition(ada.Variable("Session.Uninitialized")), - ], - ) + run_procedure_decl = ada.SubprogramDeclaration(run_procedure_spec) run_procedure_body = ada.SubprogramBody( run_procedure_spec, - [], [ - ada.CallStatement("Session.Initialize"), + ada.ObjectDeclaration(["Ctx"], "Session.Context"), + ], + [ + ada.CallStatement(session_package * "Initialize", [ada.Variable("Ctx")]), ada.While( - ada.Variable("Session.Active"), + ada.Call(session_package * "Active", [ada.Variable("Ctx")]), [ - ada.PragmaStatement("Loop_Invariant", [ada.Variable("Session.Initialized")]), + ada.PragmaStatement( + "Loop_Invariant", + [ada.Call(session_package * "Initialized", [ada.Variable("Ctx")])], + ), ada.ForIn( "C", - ada.Range("Session.Channel"), + ada.Range(session_package * "Channel"), [ ada.PragmaStatement( - "Loop_Invariant", [ada.Variable("Session.Initialized")] + "Loop_Invariant", + [ada.Call(session_package * "Initialized", [ada.Variable("Ctx")])], ), *( [ ada.IfStatement( [ ( - ada.Call("Session.Has_Data", [ada.Variable("C")]), + ada.Call( + session_package * "Has_Data", + [ada.Variable("Ctx"), ada.Variable("C")], + ), [ - ada.CallStatement("Read", [ada.Variable("C")]), + ada.CallStatement( + "Read", + [ada.Variable("Ctx"), ada.Variable("C")], + ), ], ) ] @@ -278,9 +283,15 @@ def session_main( ada.IfStatement( [ ( - ada.Call("Session.Needs_Data", [ada.Variable("C")]), + ada.Call( + session_package * "Needs_Data", + [ada.Variable("Ctx"), ada.Variable("C")], + ), [ - ada.CallStatement("Write", [ada.Variable("C")]), + ada.CallStatement( + "Write", + [ada.Variable("Ctx"), ada.Variable("C")], + ), ], ) ] @@ -291,10 +302,9 @@ def session_main( ), ], ), - ada.CallStatement("Session.Run"), + ada.CallStatement(session_package * "Run", [ada.Variable("Ctx")]), ], ), - ada.CallStatement("Session.Finalize"), ], ) @@ -303,7 +313,7 @@ def session_main( "Print", [ ada.Parameter(["Prefix"], "String"), - ada.Parameter(["Chan"], "Session.Channel"), + ada.Parameter(["Chan"], session_package * "Channel"), ada.Parameter(["Buffer"], "RFLX" * const.TYPES_BYTES), ], ), @@ -318,7 +328,10 @@ def session_main( ada.Case( ada.Variable("Chan"), [ - (ada.Variable(f"Session.C_{channel}"), ada.String(channel)) + ( + ada.Variable(session_package * f"C_{channel}"), + ada.String(channel), + ) for channel in sorted({*input_channels.keys(), *output_channels}) ], ), @@ -341,7 +354,8 @@ def session_main( ada.ProcedureSpecification( "Read", [ - ada.Parameter(["Chan"], "Session.Channel"), + ada.Parameter(["Ctx"], "Session.Context"), + ada.Parameter(["Chan"], session_package * "Channel"), ], ), [ @@ -356,94 +370,109 @@ def session_main( ), ada.NamedAggregate(("others", ada.Number(0))), ), + ada.ObjectDeclaration( + ["Size"], + "RFLX" * const.TYPES_LENGTH, + ada.Call( + session_package * "Read_Buffer_Size", + [ + ada.Variable("Ctx"), + ada.Variable("Chan"), + ], + ), + constant=True, + ), ], [ ada.IfStatement( [ ( - ada.GreaterEqual( - ada.Length("Buffer"), - ada.Call("Session.Read_Buffer_Size", [ada.Variable("Chan")]), - ), + ada.Equal(ada.Variable("Size"), ada.Number(0)), [ ada.CallStatement( - "Session.Read", + "Ada.Text_IO.Put_Line", [ - ada.Variable("Chan"), - ada.Slice( - ada.Variable("Buffer"), - ada.First("Buffer"), - ada.Add( - ada.First("Buffer"), - -ada.Number(2), - ada.Call( - "RFLX" * const.TYPES_INDEX, - [ - ada.Add( - ada.Call( - "Session.Read_Buffer_Size", - [ada.Variable("Chan")], - ), - ada.Number(1), - ) - ], - ), - ), - ), + ada.Concatenation( + ada.String("Read "), + ada.Image("Chan"), + ada.String(": read buffer size is 0"), + ) ], ), + ada.ReturnStatement(), + ], + ), + ] + ), + ada.IfStatement( + [ + ( + ada.Less(ada.Length("Buffer"), ada.Variable("Size")), + [ ada.CallStatement( - "Print", + "Ada.Text_IO.Put_Line", [ - ada.String("Read"), - ada.Variable("Chan"), - ada.Slice( - ada.Variable("Buffer"), - ada.First("Buffer"), - ada.Add( - ada.First("Buffer"), - -ada.Number(2), - ada.Call( - "RFLX" * const.TYPES_INDEX, - [ - ada.Add( - ada.Call( - "Session.Read_Buffer_Size", - [ada.Variable("Chan")], - ), - ada.Number(1), - ) - ], - ), - ), - ), + ada.Concatenation( + ada.String("Read "), + ada.Image("Chan"), + ada.String(": read buffer size too small"), + ) ], ), + ada.ReturnStatement(), ], - ) + ), ], + ), + ada.CallStatement( + session_package * "Read", [ - ada.CallStatement( - "Ada.Text_IO.Put_Line", - [ - ada.Concatenation( - ada.String("Read "), - ada.Image("Chan"), - ada.String(": buffer too small"), - ) - ], + ada.Variable("Ctx"), + ada.Variable("Chan"), + ada.Slice( + ada.Variable("Buffer"), + ada.First("Buffer"), + ada.Add( + ada.First("Buffer"), + -ada.Number(2), + ada.Call( + "RFLX" * const.TYPES_INDEX, + [ada.Add(ada.Variable("Size"), ada.Number(1))], + ), + ), ), ], - ) + ), + ada.CallStatement( + "Print", + [ + ada.String("Read"), + ada.Variable("Chan"), + ada.Slice( + ada.Variable("Buffer"), + ada.First("Buffer"), + ada.Add( + ada.First("Buffer"), + -ada.Number(2), + ada.Call( + "RFLX" * const.TYPES_INDEX, + [ada.Add(ada.Variable("Size"), ada.Number(1))], + ), + ), + ), + ], + ), ], aspects=[ ada.Precondition( ada.AndThen( - ada.Variable("Session.Initialized"), - ada.Call("Session.Has_Data", [ada.Variable("Chan")]), + ada.Call(session_package * "Initialized", [ada.Variable("Ctx")]), + ada.Call( + session_package * "Has_Data", [ada.Variable("Ctx"), ada.Variable("Chan")] + ), ), ), - ada.Postcondition(ada.Variable("Session.Initialized")), + ada.Postcondition(ada.Call(session_package * "Initialized", [ada.Variable("Ctx")])), ], ) @@ -451,12 +480,13 @@ def session_main( ada.ProcedureSpecification( "Write", [ - ada.Parameter(["Chan"], "Session.Channel"), + ada.InOutParameter(["Ctx"], "Session.Context"), + ada.Parameter(["Chan"], session_package * "Channel"), ], ), [ ada.UseTypeClause("RFLX" * const.TYPES_LENGTH), - *([ada.UseTypeClause("Session.Channel")] if len(input_channels) > 1 else []), + *([ada.UseTypeClause(session_package * "Channel")] if len(input_channels) > 1 else []), ada.ObjectDeclaration( ["None"], ada.Slice( @@ -478,7 +508,7 @@ def session_main( [ ada.Equal( ada.Variable("Chan"), - ada.Variable(f"Session.C_{channel}"), + ada.Variable(session_package * f"C_{channel}"), ) ] if len(input_channels) > 1 @@ -519,7 +549,10 @@ def session_main( ), ada.LessEqual( ada.Length("Message"), - ada.Call("Session.Write_Buffer_Size", [ada.Variable("Chan")]), + ada.Call( + session_package * "Write_Buffer_Size", + [ada.Variable("Ctx"), ada.Variable("Chan")], + ), ), ), [ @@ -532,8 +565,9 @@ def session_main( ], ), ada.CallStatement( - "Session.Write", + session_package * "Write", [ + ada.Variable("Ctx"), ada.Variable("Chan"), ada.Variable("Message"), ], @@ -569,32 +603,34 @@ def session_main( aspects=[ ada.Precondition( ada.AndThen( - ada.Variable("Session.Initialized"), - ada.Call("Session.Needs_Data", [ada.Variable("Chan")]), + ada.Call(session_package * "Initialized", [ada.Variable("Ctx")]), + ada.Call( + session_package * "Needs_Data", [ada.Variable("Ctx"), ada.Variable("Chan")] + ), ), ), - ada.Postcondition(ada.Variable("Session.Initialized")), + ada.Postcondition(ada.Call(session_package * "Initialized", [ada.Variable("Ctx")])), ], ) lib_unit = ada.PackageUnit( [ *const.CONFIGURATION_PRAGMAS, - ada.WithClause(session_package), *context, ], ada.PackageDeclaration( "Lib", [ - ada.GenericPackageInstantiation("Session", session_package, session_parameters), run_procedure_decl, ], - aspects=[ada.SparkMode(), ada.InitialCondition(ada.Call("Session.Uninitialized"))], + aspects=[ada.SparkMode()], ), [ *const.CONFIGURATION_PRAGMAS, ada.WithClause("Ada.Text_IO"), ada.WithClause("RFLX" * const.TYPES), + ada.WithClause(session_package), + ada.WithClause("Session"), ], ada.PackageBody( "Lib", @@ -603,7 +639,7 @@ def session_main( *([read_procedure] if output_channels else []), *( [ - ada.ArrayType("Number_Per_Channel", "Session.Channel", "Natural"), + ada.ArrayType("Number_Per_Channel", session_package * "Channel", "Natural"), ada.ObjectDeclaration( ["Written_Messages"], "Number_Per_Channel", @@ -624,15 +660,32 @@ def session_main( ), ) + session_unit = ada.PackageUnit( + [ + *const.CONFIGURATION_PRAGMAS, + ada.WithClause(session_package), + ], + ada.PackageDeclaration( + "Session", + [ + ada.DerivedType("Context", session_package * "Context", []), + ], + aspects=[ + ada.SparkMode(), + ], + ), + [], + ada.PackageBody("Session"), + ) + return { + f"{session_unit.name}.ads": session_unit.ads, f"{lib_unit.name}.ads": lib_unit.ads, f"{lib_unit.name}.adb": lib_unit.adb, "main.adb": """with Lib; -pragma Elaborate (Lib); procedure Main with - SPARK_Mode, - Pre => Lib.Session.Uninitialized + SPARK_Mode is begin Lib.Run;