From 62882c1615906b36e3d0f40bc4b8628b3237f3d4 Mon Sep 17 00:00:00 2001 From: Tobias Reiher Date: Thu, 9 Jun 2022 19:26:12 +0200 Subject: [PATCH] Allow setting of single message fields in sessions Ref. #1067 --- doc/Language-Reference.adoc | 48 +- rflx/generator/session.py | 386 ++-- rflx/model/session.py | 2 +- rflx/model/statement.py | 35 + rflx/specification/parser.py | 11 + setup.py | 2 +- .../generated/rflx-test-session.adb | 72 +- .../generated/rflx-test-session.adb | 58 +- .../generated/rflx-test-session.adb | 74 +- .../generated/rflx-test-session.adb | 109 +- .../generated/rflx-test-session.adb | 32 +- .../generated/rflx-test-session.adb | 44 +- .../generated/rflx-test-session.adb | 167 +- .../generated/rflx-test-session.adb | 64 +- .../generated/rflx-test-session.adb | 76 +- .../generated/rflx-test-session.adb | 88 +- .../generated/rflx-test-session.adb | 118 +- .../generated/rflx-test-session.adb | 32 +- .../config.yml | 12 + .../generated/rflx-rflx_arithmetic.adb | 65 + .../generated/rflx-rflx_arithmetic.ads | 85 + .../rflx-rflx_builtin_types-conversions.ads | 37 + .../generated/rflx-rflx_builtin_types.ads | 21 + .../generated/rflx-rflx_generic_types.adb | 373 ++++ .../generated/rflx-rflx_generic_types.ads | 122 ++ .../generated/rflx-rflx_message_sequence.adb | 83 + .../generated/rflx-rflx_message_sequence.ads | 260 +++ .../generated/rflx-rflx_scalar_sequence.adb | 95 + .../generated/rflx-rflx_scalar_sequence.ads | 235 +++ .../generated/rflx-rflx_types.ads | 6 + .../generated/rflx-test-session.adb | 259 +++ .../generated/rflx-test-session.ads | 174 ++ .../generated/rflx-test-session_allocator.adb | 24 + .../generated/rflx-test-session_allocator.ads | 46 + .../generated/rflx-test.ads | 8 + .../generated/rflx-universal-contains.adb | 31 + .../generated/rflx-universal-contains.ads | 59 + .../generated/rflx-universal-message.adb | 877 +++++++++ .../generated/rflx-universal-message.ads | 1614 +++++++++++++++++ .../generated/rflx-universal-option.adb | 447 +++++ .../generated/rflx-universal-option.ads | 856 +++++++++ .../generated/rflx-universal-option_types.ads | 9 + .../generated/rflx-universal-options.ads | 10 + .../generated/rflx-universal-values.ads | 9 + .../generated/rflx-universal.ads | 144 ++ .../generated/rflx.ads | 3 + .../test.rflx | 48 + .../universal.rflx | 1 + .../generated/rflx-test-session.adb | 44 +- .../generated/rflx-test-session.adb | 42 +- tests/unit/generator_test.py | 256 ++- tests/unit/specification/grammar_test.py | 10 + 52 files changed, 7377 insertions(+), 406 deletions(-) create mode 100644 tests/integration/session_setting_of_message_fields/config.yml create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types-conversions.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-rflx_types.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-test-session.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-test-session.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-test.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.adb create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-option_types.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-options.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal-values.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx-universal.ads create mode 100644 tests/integration/session_setting_of_message_fields/generated/rflx.ads create mode 100644 tests/integration/session_setting_of_message_fields/test.rflx create mode 120000 tests/integration/session_setting_of_message_fields/universal.rflx diff --git a/doc/Language-Reference.adoc b/doc/Language-Reference.adoc index 8423c6ced4..b6edb46025 100644 --- a/doc/Language-Reference.adoc +++ b/doc/Language-Reference.adoc @@ -739,7 +739,7 @@ The state actions are executed after entering a state. [subs="+macros,quotes"] ---- -[[syntax-state_action]]state_action ::= ( xref:syntax-assignment[assignment] | xref:syntax-append[append] | xref:syntax-extend[extend] | xref:syntax-reset[reset] | xref:syntax-read[read] | xref:syntax-write[write] ) *;* +[[syntax-state_action]]state_action ::= ( xref:syntax-assignment[assignment] | xref:syntax-message_field_assignment[message_field_assignment] | xref:syntax-append[append] | xref:syntax-extend[extend] | xref:syntax-reset[reset] | xref:syntax-read[read] | xref:syntax-write[write] ) *;* ---- ===== Assignment Statements @@ -788,6 +788,52 @@ An assignment always creates a copy of the original object. Error_Sent := True ---- +===== Message Field Assignment Statements + +// Message Field Assignment Statements [§S-S-A-MFA] + +A message field assignment sets the value of a message field. + +*Syntax* + +[subs="+macros,quotes"] +---- +[[syntax-message_field_assignment]]message_field_assignment ::= variable_xref:syntax-name[name] *.* field_xref:syntax-name[name] *:=* xref:syntax-expression[expression] +---- + +// *Static Semantics* +// +// Expressions: +// +// * Mathematical Expressions [§S-S-A-MFA-ME] +// * Boolean Expressions [§S-S-A-MFA-BE] +// * Literals [§S-S-A-MFA-L] +// * Variables [§S-S-A-MFA-V] +// * Message Aggregates [§S-S-A-MFA-MA] +// * Aggregates [§S-S-A-MFA-A] +// * Valid Attributes [§S-S-A-MFA-VAT] +// * Opaque Attributes [§S-S-A-MFA-OAT] +// * Size Attributes [§S-S-A-MFA-SAT] +// * Head Attributes [§S-S-A-MFA-HAT] +// * Has_Data Attributes [§S-S-A-MFA-HDAT] +// * Selected Expressions [§S-S-A-MFA-S] +// * List Comprehensions [§S-S-A-MFA-LC] +// * Bindings [§S-S-A-MFA-B] +// * Quantified Expressions [§S-S-A-MFA-Q] +// * Calls [§S-S-A-MFA-CL] +// * Conversions [§S-S-A-MFA-CV] + +*Dynamic Semantics* + +Message fields must be set in order. Trying to set a message field which is not a valid next field leads to an exception transition. All subsequent fields of the set message field are invalidated. + +*Example* + +[source,ada,rflx,message_field_assignment_statement] +---- +Packet.Length := 42 +---- + ===== Append Attribute Statements // Append Attribute Statements [§S-S-A-AP] diff --git a/rflx/generator/session.py b/rflx/generator/session.py index 477575faba..7dddb91606 100644 --- a/rflx/generator/session.py +++ b/rflx/generator/session.py @@ -1957,6 +1957,16 @@ def _state_action( action.location, ) + elif isinstance(action, stmt.MessageFieldAssignment): + result = self._assign_message_field( + action.message, + action.field, + action.type_, + action.value, + exception_handler, + is_global, + ) + elif isinstance(action, stmt.Append): result = self._append(action, exception_handler, is_global, state) @@ -2465,7 +2475,7 @@ def _assign_to_message_aggregate( }, ), *self._set_message_fields( - target_type, target_context, message_aggregate, exception_handler, is_global + target_context, message_aggregate, exception_handler, is_global ), ], exception_handler, @@ -3052,14 +3062,6 @@ def _assign_to_call( # pylint: disable = too-many-locals return call - @staticmethod - def contains_function_name( - refinement_package: rid.ID, pdu: rid.ID, sdu: rid.ID, field: rid.ID - ) -> str: - sdu_name = sdu.name if sdu.parent == refinement_package else sdu - pdu_name = pdu.name if pdu.parent == refinement_package else pdu - return f"{sdu_name.flat}_In_{pdu_name.flat}_{field}" - def _assign_to_conversion( self, target: rid.ID, @@ -3096,7 +3098,7 @@ def _assign_to_conversion( self._if( Call( ID(contains_package) - * self.contains_function_name( + * common.contains_function_name( refinement.package, pdu.identifier, sdu.identifier, field ), [Variable(context_id(conversion.argument.prefix.identifier, is_global))], @@ -3121,6 +3123,25 @@ def _assign_to_conversion( ) ] + def _assign_message_field( # pylint: disable = too-many-arguments + self, + target: rid.ID, + target_field: rid.ID, + message_type: rty.Type, + value: expr.Expr, + exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], + ) -> Sequence[Statement]: + assert isinstance(message_type, rty.Message) + return self._set_message_field( + context_id(target, is_global), + ID(target_field), + message_type, + value, + exception_handler, + is_global, + ) + def _append( self, append: stmt.Append, @@ -3226,7 +3247,6 @@ def check( ), *( self._set_message_fields( - element_type, element_context, append.parameters[0], local_exception_handler, @@ -3773,184 +3793,242 @@ def _exit_on_deferred_exception() -> ExitStatement: def _set_message_fields( self, - target_type: ID, 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 - assert isinstance(message_aggregate.type_, rty.Message) - statements: List[Statement] = [] - result = statements + message_type = message_aggregate.type_ + statements = [] for f, v in message_aggregate.field_values.items(): - if f not in message_aggregate.type_.field_types: + if f not in message_type.field_types: continue - field_type = message_aggregate.type_.field_types[f] + statements.extend( + self._set_message_field( + target_context, ID(f), message_type, v, exception_handler, is_global + ) + ) - if isinstance(field_type, rty.Sequence): - size: Expr - if isinstance(v, expr.Aggregate): - size = Mul(Number(len(v.elements)), Size(const.TYPES_BYTE)) - elif isinstance(v, expr.Variable) and isinstance( - v.type_, (rty.Message, rty.Sequence) - ): - type_ = ID(v.type_.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, is_global) - statements = self._ensure( - statements, - Call( - message_type * "Valid_Next", - [ - Variable(message_context), - Variable(message_type * f"F_{v.selector}"), - ], - ), - f'access to invalid next message field for "{v}"', - exception_handler, - ) - size = Call( - message_type * "Field_Size", - [ - Variable(message_context), - Variable(message_type * f"F_{v.selector}"), - ], - ) - elif isinstance(v, expr.Opaque): - size = expr.Size(v.prefix).substituted(self._substitution(is_global)).ada_expr() - else: - size = Size(v.substituted(self._substitution(is_global)).ada_expr()) + return statements + + def _set_message_field( + self, + message_context: ID, + field: ID, + message_type: rty.Message, + value: expr.Expr, + exception_handler: ExceptionHandler, + is_global: Callable[[ID], bool], + ) -> list[Statement]: + # pylint: disable = too-many-arguments, too-many-statements, too-many-branches, too-many-locals + + message_type_id = ID(message_type.identifier) + field_type = message_type.field_types[field] + statements: list[Statement] = [] + result = statements + + statements = self._ensure( + statements, + Call( + message_type_id * "Valid_Next", + [ + Variable(message_context), + Variable(message_type_id * f"F_{field}"), + ], + ), + f'trying to set message field "{field}" to "{value}" although "{field}" is not valid' + " next field", + exception_handler, + ) + + statements = self._ensure( + statements, + GreaterEqual( + Call( + message_type_id * "Available_Space", + [ + Variable(message_context), + Variable(message_type_id * f"F_{field}"), + ], + ), + Call( + message_type_id * "Field_Size", + [ + Variable(message_context), + Variable(message_type_id * f"F_{field}"), + ], + ), + ), + f'insufficient space in message "{message_context}" to set field "{field}"' + f' to "{value}"', + exception_handler, + ) + + if isinstance(field_type, rty.Sequence): + size: Expr + if isinstance(value, expr.Aggregate): + size = Mul(Number(len(value.elements)), Size(const.TYPES_BYTE)) + elif isinstance(value, expr.Variable) and isinstance( + value.type_, (rty.Message, rty.Sequence) + ): + type_ = ID(value.type_.identifier) + context = context_id(value.identifier, is_global) + size = Call(type_ * "Size", [Variable(context)]) + elif isinstance(value, expr.Selected): + assert isinstance(value.prefix, expr.Variable) + assert isinstance(value.prefix.type_, rty.Message) + value_message_type_id = ID(value.prefix.type_.identifier) + value_message_context = context_id(value.prefix.identifier, is_global) statements = self._ensure( statements, Call( - target_type * "Valid_Length", + value_message_type_id * "Valid_Next", [ - Variable(target_context), - Variable(target_type * f"F_{f}"), - Call(const.TYPES_TO_LENGTH, [size]), + Variable(value_message_context), + Variable(value_message_type_id * f"F_{value.selector}"), ], ), - f'invalid message field size for "{v}"', + f'access to invalid next message field for "{value}"', exception_handler, ) + size = Call( + value_message_type_id * "Field_Size", + [ + Variable(value_message_context), + Variable(value_message_type_id * f"F_{value.selector}"), + ], + ) + elif isinstance(value, expr.Opaque): + size = expr.Size(value.prefix).substituted(self._substitution(is_global)).ada_expr() + else: + size = Size(value.substituted(self._substitution(is_global)).ada_expr()) + statements = self._ensure( + statements, + Call( + message_type_id * "Valid_Length", + [ + Variable(message_context), + Variable(message_type_id * f"F_{field}"), + Call(const.TYPES_TO_LENGTH, [size]), + ], + ), + f'invalid message field size for "{value}"', + exception_handler, + ) - if isinstance(v, (expr.Number, expr.Aggregate)) or ( - isinstance(v, (expr.Variable, expr.MathBinExpr, expr.MathAssExpr, expr.Size)) - and isinstance(v.type_, (rty.AnyInteger, rty.Enumeration, rty.Aggregate)) - ): - field_type = message_aggregate.type_.types[f] - if isinstance(v, expr.Aggregate) and len(v.elements) == 0: - statements.append( - CallStatement(target_type * f"Set_{f}_Empty", [Variable(target_context)]) - ) - else: - value = self._convert_type(v, field_type).substituted( - self._substitution(is_global) + if isinstance(value, (expr.Number, expr.Aggregate)) or ( + isinstance(value, (expr.Variable, expr.MathBinExpr, expr.MathAssExpr, expr.Size)) + and isinstance(value.type_, (rty.AnyInteger, rty.Enumeration, rty.Aggregate)) + ): + if isinstance(value, expr.Aggregate) and len(value.elements) == 0: + statements.append( + CallStatement( + message_type_id * f"Set_{field}_Empty", [Variable(message_context)] ) - statements.append( - CallStatement( - target_type * f"Set_{f}", - [ - Variable(target_context), - value.ada_expr(), - ], - ) + ) + else: + value = self._convert_type(value, field_type).substituted( + self._substitution(is_global) + ) + statements.append( + CallStatement( + message_type_id * f"Set_{field}", + [ + Variable(message_context), + value.ada_expr(), + ], ) - elif isinstance(v, expr.Variable) and isinstance(v.type_, rty.Sequence): - sequence_context = context_id(v.identifier, is_global) + ) + elif isinstance(value, expr.Variable) and isinstance(value.type_, rty.Sequence): + sequence_context = context_id(value.identifier, is_global) + statements.extend( + [ + CallStatement( + message_type_id * f"Set_{field}", + [Variable(message_context), Variable(sequence_context)], + ), + ] + ) + elif isinstance(value, expr.Variable) and isinstance(value.type_, rty.Message): + _unsupported_expression(value, "in message aggregate") + elif ( + isinstance(value, expr.Selected) + and isinstance(value.prefix, expr.Variable) + and isinstance(value.prefix.type_, rty.Message) + ): + value_message_type_id = ID(value.prefix.type_.identifier) + value_message_context = context_id(value.prefix.identifier, is_global) + statements = self._ensure( + statements, + Call( + value_message_type_id + * ("Structural_Valid" if isinstance(value.type_, rty.Sequence) else "Valid"), + [ + Variable(value_message_context), + Variable(value_message_type_id * f"F_{value.selector}"), + ], + ), + f'access to invalid message field in "{value}"', + exception_handler, + ) + if isinstance(field_type, (rty.Integer, rty.Enumeration)): + get_field_value = self._convert_type( + expr.Call( + value_message_type_id * f"Get_{value.selector}", + [expr.Variable(value_message_context)], + ), + field_type, + value.type_, + ).ada_expr() statements.extend( [ CallStatement( - target_type * f"Set_{f}", - [Variable(target_context), Variable(sequence_context)], + message_type_id * f"Set_{field}", + [ + Variable(message_context), + get_field_value, + ], ), ] ) - elif isinstance(v, expr.Variable) and isinstance(v.type_, rty.Message): - _unsupported_expression(v, "in message aggregate") - elif ( - isinstance(v, expr.Selected) - and isinstance(v.prefix, expr.Variable) - and isinstance(v.prefix.type_, rty.Message) - ): - message_type = ID(v.prefix.type_.identifier) - message_context = context_id(v.prefix.identifier, is_global) - target_field_type = message_aggregate.type_.types[f] - statements = self._ensure( - statements, - Call( - message_type - * ("Structural_Valid" if isinstance(v.type_, rty.Sequence) else "Valid"), - [ - Variable(message_context), - Variable(message_type * f"F_{v.selector}"), - ], - ), - f'access to invalid message field in "{v}"', - exception_handler, - ) - if isinstance(target_field_type, (rty.Integer, rty.Enumeration)): - get_field_value = self._convert_type( - expr.Call( - message_type * f"Get_{v.selector}", [expr.Variable(message_context)] - ), - target_field_type, - v.type_, - ).ada_expr() - statements.extend( - [ - CallStatement( - target_type * f"Set_{f}", - [ - Variable(target_context), - get_field_value, - ], - ), - ] - ) - else: - assert target_field_type == rty.OPAQUE - self._session_context.used_types_body.append(const.TYPES_LENGTH) - statements.extend( - [ - self._set_opaque_field_to_message_field( - target_type, - target_context, - ID(f), - message_type, - message_context, - ID(v.selector), - ), - ] - ) - elif isinstance(v, expr.Opaque) and isinstance(v.prefix, expr.Variable): - 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, is_global) + else: + assert field_type == rty.OPAQUE + self._session_context.used_types_body.append(const.TYPES_LENGTH) statements.extend( [ - self._set_opaque_field_to_message( - target_type, - target_context, - ID(f), - message_type, + self._set_opaque_field_to_message_field( + message_type_id, message_context, + ID(field), + value_message_type_id, + value_message_context, + ID(value.selector), ), ] ) - else: - _unsupported_expression(v, "in message aggregate") + elif isinstance(value, expr.Opaque) and isinstance(value.prefix, expr.Variable): + assert value.type_ == rty.OPAQUE + assert isinstance(value.prefix.type_, rty.Message) + value_message_type_id = ID(value.prefix.type_.identifier) + value_message_context = context_id(value.prefix.identifier, is_global) + statements.extend( + [ + self._set_opaque_field_to_message( + message_type_id, + message_context, + ID(field), + value_message_type_id, + value_message_context, + ), + ] + ) + else: + _unsupported_expression(value, "as value of message field") + return result @staticmethod diff --git a/rflx/model/session.py b/rflx/model/session.py index b86133214d..3d531d1d69 100644 --- a/rflx/model/session.py +++ b/rflx/model/session.py @@ -109,7 +109,7 @@ def is_null(self) -> bool: @property def has_exceptions(self) -> bool: return any( - isinstance(a, (stmt.Append, stmt.Extend)) + isinstance(a, (stmt.Append, stmt.Extend, stmt.MessageFieldAssignment)) or ( isinstance(a, stmt.Assignment) and ( diff --git a/rflx/model/statement.py b/rflx/model/statement.py index b0347e7daa..bc3f89444e 100644 --- a/rflx/model/statement.py +++ b/rflx/model/statement.py @@ -56,6 +56,41 @@ def variables(self) -> Sequence[Variable]: return [Variable(self.identifier), *self.expression.variables()] +class MessageFieldAssignment(Statement): + def __init__( + self, + message: StrID, + field: StrID, + value: Expr, + type_: rty.Type = rty.Undefined(), + location: Location = None, + ) -> None: + super().__init__(message, type_, location) + self.message = ID(message) + self.field = ID(field) + self.value = value + + def __str__(self) -> str: + return f"{self.message}.{self.field} := {self.value}" + + def check_type( + self, statement_type: rty.Type, typify_variable: Callable[[Expr], Expr] + ) -> RecordFluxError: + field_type = ( + statement_type.types[self.field] + if isinstance(statement_type, rty.Message) + else rty.Undefined() + ) + self.type_ = statement_type + self.value = self.value.substituted(typify_variable) + return rty.check_type_instance( + field_type, rty.Any, self.location, f'variable "{self.identifier}"' + ) + self.value.check_type(field_type) + + def variables(self) -> Sequence[Variable]: + return [Variable(self.message), *self.value.variables()] + + class AttributeStatement(Statement): def __init__( self, diff --git a/rflx/specification/parser.py b/rflx/specification/parser.py index b70ecb43cd..19e2e2e6a4 100644 --- a/rflx/specification/parser.py +++ b/rflx/specification/parser.py @@ -116,6 +116,16 @@ def create_assignment(assignment: lang.Statement, filename: Path) -> stmt.Statem ) +def create_message_field_assignment(assignment: lang.Statement, filename: Path) -> stmt.Statement: + assert isinstance(assignment, lang.MessageFieldAssignment) + return stmt.MessageFieldAssignment( + create_id(assignment.f_message, filename), + create_id(assignment.f_field, filename), + create_expression(assignment.f_expression, filename), + location=node_location(assignment, filename), + ) + + def create_attribute_statement(expression: lang.Statement, filename: Path) -> stmt.Statement: assert isinstance(expression, lang.AttributeStatement) attrs = { @@ -137,6 +147,7 @@ def create_statement(statement: lang.Statement, filename: Path) -> stmt.Statemen handlers = { "Reset": create_reset, "Assignment": create_assignment, + "MessageFieldAssignment": create_message_field_assignment, "AttributeStatement": create_attribute_statement, } return handlers[statement.kind_name](statement, filename) diff --git a/setup.py b/setup.py index 7985754f01..31df671920 100644 --- a/setup.py +++ b/setup.py @@ -55,7 +55,7 @@ "pydotplus >=2, <3", "ruamel.yaml >=0.17, <0.18", "z3-solver >=4, <5", - "RecordFlux-parser ==0.10.0", + "RecordFlux-parser ==0.11.0", ], extras_require={ "devel": [ 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 5fbb739774..2a08087b92 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 @@ -53,30 +53,54 @@ is 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 (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 (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 (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; + if Universal.Message.Valid_Next (Ctx.P.M_S_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.M_S_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.M_S_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.M_S_Ctx, Universal.MT_Unconstrained_Data); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.M_S_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (Ctx.P.M_S_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (Ctx.P.M_S_Ctx, Universal.Message.F_Data) then + 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 (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 (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 (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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); diff --git a/tests/integration/messages_with_single_opaque_field/generated/rflx-test-session.adb b/tests/integration/messages_with_single_opaque_field/generated/rflx-test-session.adb index b469f5cc83..ed077df8df 100644 --- a/tests/integration/messages_with_single_opaque_field/generated/rflx-test-session.adb +++ b/tests/integration/messages_with_single_opaque_field/generated/rflx-test-session.adb @@ -53,29 +53,41 @@ is 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 >= Test.Message.Field_Size (Ctx.P.M_R_Ctx, Test.Message.F_Data) 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) + Test.Message.Field_Size (Ctx.P.M_R_Ctx, Test.Message.F_Data) - 1); - 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 (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 (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 (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_Next (Ctx.P.M_S_Ctx, Test.Message.F_Data) then + if Test.Message.Available_Space (Ctx.P.M_S_Ctx, Test.Message.F_Data) >= Test.Message.Field_Size (Ctx.P.M_S_Ctx, Test.Message.F_Data) then + 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 (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 (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 (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; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); diff --git a/tests/integration/parameterized_messages/generated/rflx-test-session.adb b/tests/integration/parameterized_messages/generated/rflx-test-session.adb index 9a683c16ff..8543a9fabc 100644 --- a/tests/integration/parameterized_messages/generated/rflx-test-session.adb +++ b/tests/integration/parameterized_messages/generated/rflx-test-session.adb @@ -79,31 +79,36 @@ is 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 (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 (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 (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 (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))); + if Test.Message.Valid_Next (Ctx.P.M_S_Ctx, Test.Message.F_Data) then + if Test.Message.Available_Space (Ctx.P.M_S_Ctx, Test.Message.F_Data) >= Test.Message.Field_Size (Ctx.P.M_S_Ctx, Test.Message.F_Data) then + 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 (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 (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 (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; + else + Ctx.P.Next_State := S_Error; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Error; pragma Assert (Process_Invariant); @@ -124,6 +129,25 @@ is pragma Assert (Process_Invariant); goto Finalize_Process; end if; + if Test.Message.Valid_Next (Ctx.P.M_S_Ctx, Test.Message.F_Extension) then + if Test.Message.Available_Space (Ctx.P.M_S_Ctx, Test.Message.F_Extension) >= Test.Message.Field_Size (Ctx.P.M_S_Ctx, Test.Message.F_Extension) then + 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 + Ctx.P.Next_State := S_Error; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Error; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Error; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Error; pragma Assert (Process_Invariant); 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 c20c02e263..cb5d786e1d 100644 --- a/tests/integration/session_append_unconstrained/generated/rflx-test-session.adb +++ b/tests/integration/session_append_unconstrained/generated/rflx-test-session.adb @@ -52,10 +52,34 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin Universal.Options.Switch (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 - Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (1))); + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Length) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + Universal.Option.Set_Length (RFLX_Element_Options_Ctx, 1); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Data) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then + Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (1))); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; @@ -81,10 +105,34 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin Universal.Options.Switch (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 - Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Byte'Val (2), RFLX_Types.Byte'Val (3))); + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Length) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + Universal.Option.Set_Length (RFLX_Element_Options_Ctx, 2); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Data) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then + Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Byte'Val (2), RFLX_Types.Byte'Val (3))); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; @@ -110,11 +158,24 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin Universal.Options.Switch (Options_Ctx, RFLX_Element_Options_Ctx); - Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Null); + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Null); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; 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"); end; + if RFLX_Exception then + Ctx.P.Next_State := S_Terminated; + pragma Assert (Start_Invariant); + goto Finalize_Start; + end if; -- tests/integration/session_append_unconstrained/test.rflx:23:10 if Universal.Options.Size (Options_Ctx) <= 32768 @@ -122,9 +183,33 @@ is then 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); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Unconstrained_Options); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Start_Invariant); + goto Finalize_Start; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Start_Invariant); + goto Finalize_Start; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Options) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Options) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Options) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Start_Invariant); + goto Finalize_Start; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Start_Invariant); + goto Finalize_Start; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Start_Invariant); diff --git a/tests/integration/session_binding/generated/rflx-test-session.adb b/tests/integration/session_binding/generated/rflx-test-session.adb index 2166155d05..dc7f75cf83 100644 --- a/tests/integration/session_binding/generated/rflx-test-session.adb +++ b/tests/integration/session_binding/generated/rflx-test-session.adb @@ -73,10 +73,34 @@ is begin 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); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, MT); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Length); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + 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; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; 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 e5cba0d978..ebf9db1bb5 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 @@ -237,10 +237,46 @@ is then 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); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Option_Types); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Universal.Length (Universal.Option_Types.Size (Option_Types_Ctx) / 8)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Option_Types) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Option_Types) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Option_Types) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); 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 cf2fd8713b..9d3e410c07 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 @@ -49,10 +49,34 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin 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 - Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Length) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + Universal.Option.Set_Length (RFLX_Element_Options_Ctx, 1); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Data) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then + Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; @@ -78,11 +102,24 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin Universal.Options.Switch (Ctx.P.Options_Ctx, RFLX_Element_Options_Ctx); - Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Null); + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Null); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; pragma Warnings (Off, """RFLX_Element_Options_Ctx"" is set by ""Update"" but not used after the call"); 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"); end; + if RFLX_Exception then + Ctx.P.Next_State := S_Terminated; + pragma Assert (Start_Invariant); + goto Finalize_Start; + end if; -- tests/integration/session_comprehension_on_sequence/test.rflx:22:10 if not Universal.Options.Has_Element (Ctx.P.Options_Ctx) @@ -96,10 +133,34 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin 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 - Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Byte'Val (2), RFLX_Types.Byte'Val (3))); + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Length) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + Universal.Option.Set_Length (RFLX_Element_Options_Ctx, 2); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Data) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then + Universal.Option.Set_Data (RFLX_Element_Options_Ctx, (RFLX_Types.Byte'Val (2), RFLX_Types.Byte'Val (3))); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; @@ -314,10 +375,46 @@ is then 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); + if Universal.Message.Valid_Next (Ctx.P.Message_1_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_1_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_1_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_1_Ctx, Universal.MT_Option_Types); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_1_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_1_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_1_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_1_Ctx, Universal.Length (Universal.Option_Types.Size (Option_Types_Ctx) / 8)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_1_Ctx, Universal.Message.F_Option_Types) then + if Universal.Message.Available_Space (Ctx.P.Message_1_Ctx, Universal.Message.F_Option_Types) >= Universal.Message.Field_Size (Ctx.P.Message_1_Ctx, Universal.Message.F_Option_Types) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); @@ -421,10 +518,46 @@ is then 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); + if Universal.Message.Valid_Next (Ctx.P.Message_2_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_2_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_2_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_2_Ctx, Universal.MT_Options); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_2_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_2_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_2_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_2_Ctx, Universal.Length (Universal.Options.Size (Message_Options_Ctx) / 8)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_2_Ctx, Universal.Message.F_Options) then + if Universal.Message.Available_Space (Ctx.P.Message_2_Ctx, Universal.Message.F_Options) >= Universal.Message.Field_Size (Ctx.P.Message_2_Ctx, Universal.Message.F_Options) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); diff --git a/tests/integration/session_endianness/generated/rflx-test-session.adb b/tests/integration/session_endianness/generated/rflx-test-session.adb index cdbf6d60a9..7e904637b9 100644 --- a/tests/integration/session_endianness/generated/rflx-test-session.adb +++ b/tests/integration/session_endianness/generated/rflx-test-session.adb @@ -57,10 +57,34 @@ is -- tests/integration/session_endianness/test.rflx:28:10 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_LE_Nested.Valid (Ctx.P.In_Msg_Ctx, Messages.Msg_LE_Nested.F_X_A) then - Messages.Msg_LE.Set_C (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE_Nested.Get_X_A (Ctx.P.In_Msg_Ctx)); - if Messages.Msg_LE_Nested.Valid (Ctx.P.In_Msg_Ctx, Messages.Msg_LE_Nested.F_X_B) then - Messages.Msg_LE.Set_D (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE_Nested.Get_X_B (Ctx.P.In_Msg_Ctx)); + if Messages.Msg_LE.Valid_Next (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE.F_C) then + if Messages.Msg_LE.Available_Space (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE.F_C) >= Messages.Msg_LE.Field_Size (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE.F_C) then + if Messages.Msg_LE_Nested.Valid (Ctx.P.In_Msg_Ctx, Messages.Msg_LE_Nested.F_X_A) then + Messages.Msg_LE.Set_C (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE_Nested.Get_X_A (Ctx.P.In_Msg_Ctx)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy_Invariant); + goto Finalize_Copy; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy_Invariant); + goto Finalize_Copy; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy_Invariant); + goto Finalize_Copy; + end if; + if Messages.Msg_LE.Valid_Next (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE.F_D) then + if Messages.Msg_LE.Available_Space (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE.F_D) >= Messages.Msg_LE.Field_Size (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE.F_D) then + if Messages.Msg_LE_Nested.Valid (Ctx.P.In_Msg_Ctx, Messages.Msg_LE_Nested.F_X_B) then + Messages.Msg_LE.Set_D (Ctx.P.Out_Msg_Ctx, Messages.Msg_LE_Nested.Get_X_B (Ctx.P.In_Msg_Ctx)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy_Invariant); + goto Finalize_Copy; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Copy_Invariant); @@ -150,10 +174,34 @@ is -- tests/integration/session_endianness/test.rflx:53:10 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)); + if Messages.Msg.Valid_Next (Ctx.P.Out_Msg2_Ctx, Messages.Msg.F_A) then + if Messages.Msg.Available_Space (Ctx.P.Out_Msg2_Ctx, Messages.Msg.F_A) >= Messages.Msg.Field_Size (Ctx.P.Out_Msg2_Ctx, Messages.Msg.F_A) then + 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)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy2_Invariant); + goto Finalize_Copy2; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy2_Invariant); + goto Finalize_Copy2; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy2_Invariant); + goto Finalize_Copy2; + end if; + if Messages.Msg.Valid_Next (Ctx.P.Out_Msg2_Ctx, Messages.Msg.F_B) then + if Messages.Msg.Available_Space (Ctx.P.Out_Msg2_Ctx, Messages.Msg.F_B) >= Messages.Msg.Field_Size (Ctx.P.Out_Msg2_Ctx, Messages.Msg.F_B) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Copy2_Invariant); + goto Finalize_Copy2; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Copy2_Invariant); diff --git a/tests/integration/session_functions_opaque/generated/rflx-test-session.adb b/tests/integration/session_functions_opaque/generated/rflx-test-session.adb index eedc429986..15ac6d9fae 100644 --- a/tests/integration/session_functions_opaque/generated/rflx-test-session.adb +++ b/tests/integration/session_functions_opaque/generated/rflx-test-session.adb @@ -65,10 +65,46 @@ is -- tests/integration/session_functions_opaque/test.rflx:27:10 if RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Message_Ctx.Buffer_First) + 1 >= 40 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) + 40 - 1); - Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Data); - Universal.Message.Set_Length (Message_Ctx, 2); - if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then - Universal.Message.Set_Data (Message_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + if Universal.Message.Valid_Next (Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Message_Ctx, Universal.MT_Data); + else + Ctx.P.Next_State := S_Error; + pragma Assert (Check_Message_Invariant); + goto Finalize_Check_Message; + end if; + else + Ctx.P.Next_State := S_Error; + pragma Assert (Check_Message_Invariant); + goto Finalize_Check_Message; + end if; + if Universal.Message.Valid_Next (Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Message_Ctx, 2); + else + Ctx.P.Next_State := S_Error; + pragma Assert (Check_Message_Invariant); + goto Finalize_Check_Message; + end if; + else + Ctx.P.Next_State := S_Error; + pragma Assert (Check_Message_Invariant); + goto Finalize_Check_Message; + end if; + if Universal.Message.Valid_Next (Message_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (Message_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (Message_Ctx, Universal.Message.F_Data) then + if Universal.Message.Valid_Length (Message_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then + Universal.Message.Set_Data (Message_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + else + Ctx.P.Next_State := S_Error; + pragma Assert (Check_Message_Invariant); + goto Finalize_Check_Message; + end if; + else + Ctx.P.Next_State := S_Error; + pragma Assert (Check_Message_Invariant); + goto Finalize_Check_Message; + end if; else Ctx.P.Next_State := S_Error; pragma Assert (Check_Message_Invariant); @@ -144,10 +180,34 @@ is RFLX_Element_Message_Sequence_Ctx : Universal.Option.Context; begin Universal.Options.Switch (Message_Sequence_Ctx, RFLX_Element_Message_Sequence_Ctx); - Universal.Option.Set_Option_Type (RFLX_Element_Message_Sequence_Ctx, Universal.OT_Data); - Universal.Option.Set_Length (RFLX_Element_Message_Sequence_Ctx, 2); - if Universal.Option.Valid_Length (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then - Universal.Option.Set_Data (RFLX_Element_Message_Sequence_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + if Universal.Option.Valid_Next (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Message_Sequence_Ctx, Universal.OT_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Length) then + if Universal.Option.Available_Space (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Length) >= Universal.Option.Field_Size (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Length) then + Universal.Option.Set_Length (RFLX_Element_Message_Sequence_Ctx, 2); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Data) then + if Universal.Option.Available_Space (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Data) >= Universal.Option.Field_Size (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Length (RFLX_Element_Message_Sequence_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then + Universal.Option.Set_Data (RFLX_Element_Message_Sequence_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; diff --git a/tests/integration/session_integration/generated/rflx-test-session.adb b/tests/integration/session_integration/generated/rflx-test-session.adb index 9d21749e5b..9f2fbc2661 100644 --- a/tests/integration/session_integration/generated/rflx-test-session.adb +++ b/tests/integration/session_integration/generated/rflx-test-session.adb @@ -61,10 +61,46 @@ is -- tests/integration/session_integration/test.rflx:26:10 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))); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Data); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Prepare_Message_Invariant); + goto Finalize_Prepare_Message; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Prepare_Message_Invariant); + goto Finalize_Prepare_Message; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, 1); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Prepare_Message_Invariant); + goto Finalize_Prepare_Message; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Prepare_Message_Invariant); + goto Finalize_Prepare_Message; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Prepare_Message_Invariant); + goto Finalize_Prepare_Message; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Prepare_Message_Invariant); + goto Finalize_Prepare_Message; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Prepare_Message_Invariant); @@ -129,10 +165,46 @@ is -- tests/integration/session_integration/test.rflx:44:10 if RFLX_Types.To_First_Bit_Index (M_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (M_Ctx.Buffer_First) + 1 >= 32 then Universal.Message.Reset (M_Ctx, RFLX_Types.To_First_Bit_Index (M_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (M_Ctx.Buffer_First) + 32 - 1); - Universal.Message.Set_Message_Type (M_Ctx, Universal.MT_Data); - Universal.Message.Set_Length (M_Ctx, 1); - 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))); + if Universal.Message.Valid_Next (M_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (M_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (M_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (M_Ctx, Universal.MT_Data); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Next_Invariant); + goto Finalize_Next; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Next_Invariant); + goto Finalize_Next; + end if; + if Universal.Message.Valid_Next (M_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (M_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (M_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (M_Ctx, 1); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Next_Invariant); + goto Finalize_Next; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Next_Invariant); + goto Finalize_Next; + end if; + if Universal.Message.Valid_Next (M_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (M_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (M_Ctx, Universal.Message.F_Data) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Next_Invariant); + goto Finalize_Next; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Next_Invariant); + goto Finalize_Next; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Next_Invariant); diff --git a/tests/integration/session_sequence_append/generated/rflx-test-session.adb b/tests/integration/session_sequence_append/generated/rflx-test-session.adb index 857d471d21..fe9f221e8f 100644 --- a/tests/integration/session_sequence_append/generated/rflx-test-session.adb +++ b/tests/integration/session_sequence_append/generated/rflx-test-session.adb @@ -82,32 +82,56 @@ is RFLX_Element_Options_Ctx : Universal.Option.Context; begin Universal.Options.Switch (Options_Ctx, RFLX_Element_Options_Ctx); - Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); - if Universal.Option.Valid (Ctx.P.Option_Ctx, Universal.Option.F_Length) then - Universal.Option.Set_Length (RFLX_Element_Options_Ctx, Universal.Option.Get_Length (Ctx.P.Option_Ctx)); - if Universal.Option.Valid_Next (Ctx.P.Option_Ctx, Universal.Option.F_Data) then - if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (Universal.Option.Field_Size (Ctx.P.Option_Ctx, Universal.Option.F_Data))) then - if Universal.Option.Structural_Valid (Ctx.P.Option_Ctx, Universal.Option.F_Data) then - declare - pragma Warnings (Off, "is not modified, could be declared constant"); - RFLX_Ctx_P_Option_Ctx_Tmp : Universal.Option.Context := Ctx.P.Option_Ctx; - pragma Warnings (On, "is not modified, could be declared constant"); - function RFLX_Process_Data_Pre (Length : RFLX_Types.Length) return Boolean is - (Universal.Option.Has_Buffer (RFLX_Ctx_P_Option_Ctx_Tmp) - and then Universal.Option.Structural_Valid (RFLX_Ctx_P_Option_Ctx_Tmp, Universal.Option.F_Data) - and then Length = RFLX_Types.To_Length (Universal.Option.Field_Size (RFLX_Ctx_P_Option_Ctx_Tmp, Universal.Option.F_Data))); - procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes) with - Pre => - RFLX_Process_Data_Pre (Data'Length) - is + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (RFLX_Element_Options_Ctx, Universal.OT_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Length) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Length) then + if Universal.Option.Valid (Ctx.P.Option_Ctx, Universal.Option.F_Length) then + Universal.Option.Set_Length (RFLX_Element_Options_Ctx, Universal.Option.Get_Length (Ctx.P.Option_Ctx)); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if Universal.Option.Valid_Next (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Available_Space (RFLX_Element_Options_Ctx, Universal.Option.F_Data) >= Universal.Option.Field_Size (RFLX_Element_Options_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Next (Ctx.P.Option_Ctx, Universal.Option.F_Data) then + if Universal.Option.Valid_Length (RFLX_Element_Options_Ctx, Universal.Option.F_Data, RFLX_Types.To_Length (Universal.Option.Field_Size (Ctx.P.Option_Ctx, Universal.Option.F_Data))) then + if Universal.Option.Structural_Valid (Ctx.P.Option_Ctx, Universal.Option.F_Data) then + declare + pragma Warnings (Off, "is not modified, could be declared constant"); + RFLX_Ctx_P_Option_Ctx_Tmp : Universal.Option.Context := Ctx.P.Option_Ctx; + pragma Warnings (On, "is not modified, could be declared constant"); + function RFLX_Process_Data_Pre (Length : RFLX_Types.Length) return Boolean is + (Universal.Option.Has_Buffer (RFLX_Ctx_P_Option_Ctx_Tmp) + and then Universal.Option.Structural_Valid (RFLX_Ctx_P_Option_Ctx_Tmp, Universal.Option.F_Data) + and then Length = RFLX_Types.To_Length (Universal.Option.Field_Size (RFLX_Ctx_P_Option_Ctx_Tmp, Universal.Option.F_Data))); + procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes) with + Pre => + RFLX_Process_Data_Pre (Data'Length) + is + begin + Universal.Option.Get_Data (RFLX_Ctx_P_Option_Ctx_Tmp, Data); + end RFLX_Process_Data; + procedure RFLX_Universal_Option_Set_Data is new Universal.Option.Generic_Set_Data (RFLX_Process_Data, RFLX_Process_Data_Pre); begin - Universal.Option.Get_Data (RFLX_Ctx_P_Option_Ctx_Tmp, Data); - end RFLX_Process_Data; - procedure RFLX_Universal_Option_Set_Data is new Universal.Option.Generic_Set_Data (RFLX_Process_Data, RFLX_Process_Data_Pre); - begin - RFLX_Universal_Option_Set_Data (RFLX_Element_Options_Ctx, RFLX_Types.To_Length (Universal.Option.Field_Size (RFLX_Ctx_P_Option_Ctx_Tmp, Universal.Option.F_Data))); - Ctx.P.Option_Ctx := RFLX_Ctx_P_Option_Ctx_Tmp; - end; + RFLX_Universal_Option_Set_Data (RFLX_Element_Options_Ctx, RFLX_Types.To_Length (Universal.Option.Field_Size (RFLX_Ctx_P_Option_Ctx_Tmp, Universal.Option.F_Data))); + Ctx.P.Option_Ctx := RFLX_Ctx_P_Option_Ctx_Tmp; + end; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; @@ -136,10 +160,46 @@ is then 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) + 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.Options.Size (Options_Ctx) + 24) - 1); - Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Options); - Universal.Message.Set_Length (Ctx.P.Message_Ctx, Universal.Length (Universal.Options.Size (Options_Ctx) / 8)); - 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); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Options); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Universal.Length (Universal.Options.Size (Options_Ctx) / 8)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Options) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Options) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Options) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); 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 ff9383b3f7..654d636276 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 @@ -46,10 +46,34 @@ is RFLX_Element_Messages_Ctx : TLV.Message.Context; begin 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 - TLV.Message.Set_Value (RFLX_Element_Messages_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); + if TLV.Message.Valid_Next (RFLX_Element_Messages_Ctx, TLV.Message.F_Tag) then + if TLV.Message.Available_Space (RFLX_Element_Messages_Ctx, TLV.Message.F_Tag) >= TLV.Message.Field_Size (RFLX_Element_Messages_Ctx, TLV.Message.F_Tag) then + TLV.Message.Set_Tag (RFLX_Element_Messages_Ctx, TLV.Msg_Data); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if TLV.Message.Valid_Next (RFLX_Element_Messages_Ctx, TLV.Message.F_Length) then + if TLV.Message.Available_Space (RFLX_Element_Messages_Ctx, TLV.Message.F_Length) >= TLV.Message.Field_Size (RFLX_Element_Messages_Ctx, TLV.Message.F_Length) then + TLV.Message.Set_Length (RFLX_Element_Messages_Ctx, 1); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; + if TLV.Message.Valid_Next (RFLX_Element_Messages_Ctx, TLV.Message.F_Value) then + if TLV.Message.Available_Space (RFLX_Element_Messages_Ctx, TLV.Message.F_Value) >= TLV.Message.Field_Size (RFLX_Element_Messages_Ctx, TLV.Message.F_Value) then + if TLV.Message.Valid_Length (RFLX_Element_Messages_Ctx, TLV.Message.F_Value, RFLX_Types.To_Length (1 * RFLX_Types.Byte'Size)) then + TLV.Message.Set_Value (RFLX_Element_Messages_Ctx, (RFLX_Types.Index'First => RFLX_Types.Byte'Val (2))); + else + RFLX_Exception := True; + end if; + else + RFLX_Exception := True; + end if; else RFLX_Exception := True; end if; diff --git a/tests/integration/session_setting_of_message_fields/config.yml b/tests/integration/session_setting_of_message_fields/config.yml new file mode 100644 index 0000000000..2df229905c --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/config.yml @@ -0,0 +1,12 @@ +input: + Channel: + - 1 0 1 0 +output: + - Channel +sequence: | + Write Channel: 1 0 1 0 + State: Start + State: Process + Read Channel: 1 0 1 2 + State: Reply +prove: diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.adb new file mode 100644 index 0000000000..111eaafda5 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.adb @@ -0,0 +1,65 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +package body RFLX.RFLX_Arithmetic with + SPARK_Mode +is + + function Shift_Left (Value : U64; Amount : Natural) return U64 with + Import, + Convention => Intrinsic, + Global => null; + + function Shift_Right (Value : U64; Amount : Natural) return U64 with + Import, + Convention => Intrinsic, + Global => null; + + function Shift_Add (V : U64; + Data : U64; + Amount : Natural; + Bits : Natural) return U64 + is + pragma Unreferenced (Bits); + begin + return Shift_Left (V, Amount) + Data; + end Shift_Add; + + function Right_Shift (V : U64; Amount : Natural; Size : Natural) return U64 + is + pragma Unreferenced (Size); + begin + return Shift_Right (V, Amount); + end Right_Shift; + + function Left_Shift (V : U64; Amount : Natural; Size : Natural) return U64 + is + pragma Unreferenced (Size); + Result : constant U64 := Shift_Left (V, Amount); + begin + return Result; + end Left_Shift; + + function Mask_Lower (V : U64; Mask, Bits : Natural) return U64 + is + Result : constant U64 := Shift_Left (Shift_Right (V, Mask), Mask); + begin + pragma Assert + (if Bits < U64'Size then Result <= 2 ** Bits - 2 ** Mask + elsif Mask < U64'Size then Result <= U64'Last - 2 ** Mask + 1); + return Result; + end Mask_Lower; + + function Mask_Upper (V : U64; Mask : Natural) return U64 + is + begin + return V and (2 ** Mask - 1); + end Mask_Upper; + + function Add (A : U64; B : U64; Total_Bits, Lower_Bits : Natural) return U64 + is + pragma Unreferenced (Total_Bits, Lower_Bits); + begin + return A + B; + end Add; + +end RFLX.RFLX_Arithmetic; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.ads new file mode 100644 index 0000000000..5b6279a875 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_arithmetic.ads @@ -0,0 +1,85 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +package RFLX.RFLX_Arithmetic with + SPARK_Mode +is + + type U64 is mod 2**64 with + Annotate => (GNATprove, No_Wrap_Around); + + -- Express that V contains at most Bits non-zero bits, in the least + -- significant part (the rest is zero). + pragma Warnings (Off, "postcondition does not mention function result"); + function Fits_Into (V : U64; Bits : Natural) return Boolean + is (if Bits < U64'Size then V < 2 ** Bits) + with Post => True; + + -- Express that V contains (U64'Size - Bits) leading zero bits, then (Bits - + -- Lower) bits of data, then Lower bits of zeros. + -- |- (U64'Size - bits) -|- (Bits-Lower) -|- Lower -| + -- |000000000000000000000|xxxxxxxxxxxxxxxx|000000000| + function Fits_Into_Upper (V : U64; Bits, Lower : Natural) return Boolean + is (if Bits < U64'Size then V <= 2 ** Bits - 2 ** Lower + elsif Lower > 0 and then Lower < U64'Size then V <= U64'Last - 2 ** Lower + 1) + with Pre => Bits <= U64'Size and then Lower <= Bits, + Post => True; + pragma Warnings (On, "postcondition does not mention function result"); + + -- V is assumed to contain Bits bits of data. Add the Amount bits contained + -- in Data by shifting V to the left and adding Data. The result contains + -- (Bits + Amount) bits of data. + function Shift_Add (V : U64; + Data : U64; + Amount : Natural; + Bits : Natural) return U64 + with Pre => + Bits < U64'Size + and then Amount < U64'Size + and then Fits_Into (V, Bits) + and then U64'Size - Amount >= Bits + and then Fits_Into (Data, Amount), + Post => Fits_Into (Shift_Add'Result, Bits + Amount); + + -- Wrapper of Shift_Right that expresses the operation in terms of + -- Fits_Into. + function Right_Shift (V : U64; Amount : Natural; Size : Natural) return U64 with + Pre => + Size <= U64'Size + and then Fits_Into (V, Size) + and then Amount <= Size + and then Size - Amount < U64'Size, + Post => Fits_Into (Right_Shift'Result, Size - Amount); + + -- Wrapper of Shift_Left that expresses the operation in terms of + -- Fits_Into/Fits_Into_Upper. + function Left_Shift (V : U64; Amount : Natural; Size : Natural) return U64 with + Pre => + Size < U64'Size + and then Amount < U64'Size + and then Fits_Into (V, Size) + and then Size + Amount < U64'Size, + Post => Fits_Into_Upper (Left_Shift'Result, Size + Amount, Amount); + + -- V is assumed to have Bits bits of data. Set the lower bits of V to zero. + function Mask_Lower (V : U64; Mask, Bits : Natural) return U64 + with Pre => Bits <= U64'Size and then Fits_Into (V, Bits) and then Mask <= Bits and then Mask >= 1, + Post => Fits_Into_Upper (Mask_Lower'Result, Bits, Mask); + + -- Set the upper bits of V to zero. + function Mask_Upper (V : U64; Mask : Natural) return U64 + with Pre => Mask < U64'Size, + Post => Fits_Into (Mask_Upper'Result, Mask); + + -- Add A and B in the special case where A only uses the upper bits and B + -- only the lower bits. + function Add (A : U64; B : U64; Total_Bits, Lower_Bits : Natural) return U64 + with Pre => + Total_Bits <= U64'Size + and then Lower_Bits <= Total_Bits + and then (if Total_Bits = U64'Size then Lower_Bits /= U64'Size) + and then Fits_Into_Upper (A, Total_Bits, Lower_Bits) + and then Fits_Into (B, Lower_Bits), + Post => Add'Result = A + B and Fits_Into (Add'Result, Total_Bits), + Global => null; + +end RFLX.RFLX_Arithmetic; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types-conversions.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types-conversions.ads new file mode 100644 index 0000000000..ff3cc8ddc6 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types-conversions.ads @@ -0,0 +1,37 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +with RFLX.RFLX_Arithmetic; + +package RFLX.RFLX_Builtin_Types.Conversions with + SPARK_Mode +is + + pragma Annotate (GNATprove, Terminating, Conversions); + + function Valid_Boolean (Val : RFLX.RFLX_Arithmetic.U64) return Boolean is + (case Val is + when 0 | 1 => + True, + when others => + False); + + function To_U64 (Enum : Boolean) return RFLX.RFLX_Arithmetic.U64 is + (case Enum is + when False => + 0, + when True => + 1); + + function To_Actual (Val : RFLX.RFLX_Arithmetic.U64) return Boolean is + (case Val is + when 0 => + False, + when 1 => + True, + when others => + False) + with + Pre => + Valid_Boolean (Val); + +end RFLX.RFLX_Builtin_Types.Conversions; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types.ads new file mode 100644 index 0000000000..52dc6a1b36 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_builtin_types.ads @@ -0,0 +1,21 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +package RFLX.RFLX_Builtin_Types with + SPARK_Mode +is + + type Length is new Natural; + + type Index is new Length range 1 .. Length'Last; + + type Byte is mod 2**8; + + type Bytes is array (Index range <>) of Byte; + + type Bytes_Ptr is access Bytes; + + type Bit_Length is range 0 .. Length'Last * 8; + + type Boolean_Base is mod 2; + +end RFLX.RFLX_Builtin_Types; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.adb new file mode 100644 index 0000000000..2cb298219f --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.adb @@ -0,0 +1,373 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +package body RFLX.RFLX_Generic_Types with + SPARK_Mode +is + + -- + -- Terminology + -- + -- -----XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX---- Data + -- + -- |-------|-------|-------|-------|-------| Value Bytes + -- 3 LMB 11 19 27 35 RMB 43 + -- + -- |----| |----| + -- LME_Offset RME_Offset + -- + -- |--| |--| + -- LME_Size RME_Size + -- + -- |-------|-------|-------|-------|-------|-------| Data Bytes + -- 0 8 16 24 32 40 + -- LME RME + -- + -- LME: Leftmost Element of Data + -- RME: Rightmost Element of Data + -- + -- LSB: Leftmost Byte of Value + -- RMB: Rightmost Byte of Value + -- + -- LME_Offset: Bits the LME is shifted right relative to first of LME + -- RME_Offset: Bits the RME is shifted left relative to last of RME + -- + -- LME_Size: Number of bits of LME contained in LMB + -- RME_Size: Number of bits of RME contained in RMB + -- + -- LME_Index: Index pointing to LME + -- RME_Index: Index pointing to RME + -- + + use RFLX.RFLX_Arithmetic; + + procedure Get_Index_Offset + (First, Last : Long_Integer; + Off : Offset; + Value_Size : Positive; + RME_Index : out Index; + LME_Index : out Index; + RME_Size : out Natural; + LME_Size : out Natural) + with + Pre => + (Value_Size in 1 .. U64'Size + and then Last >= Long_Integer (Index'First) and then Last <= Long_Integer (Index'Last) + and then First >= Long_Integer (Index'First) and then First <= Long_Integer (Index'Last) + and then Long_Integer ((Natural (Off) + Value_Size - 1) / Byte'Size) < Long_Integer (Last - First + 1)), + Post => + (RME_Index = Index (Last - Long_Integer (Off) / Byte'Size) + and then LME_Index = Index (Last - (Long_Integer (Off) + Long_Integer (Value_Size) - 1) / Byte'Size) + and then RME_Size = Byte'Size - Natural (Off) + and then LME_Size = (Natural (Off) + Value_Size + Byte'Size - 1) mod Byte'Size + 1) + is + begin + RME_Index := Index (Last - Long_Integer (Off) / Byte'Size); + LME_Index := Index (Last - (Long_Integer (Off) + Long_Integer (Value_Size) - 1) / Byte'Size); + RME_Size := Byte'Size - Natural (Off); + LME_Size := (Natural (Off) + Value_Size + Byte'Size - 1) mod Byte'Size + 1; + end Get_Index_Offset; + + function U64_Extract + (Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Value_Size : Positive) return U64 + with + Pre => + (Buffer /= null + and then First >= Buffer'First + and then Last <= Buffer'Last + and then Value_Size in 1 .. U64'Size + and then Long_Integer ((Natural (Off) + Value_Size - 1) / Byte'Size) < Buffer.all (First .. Last)'Length), + Post => + (if Value_Size < U64'Size then U64_Extract'Result < 2**Value_Size) + is + Data : constant Bytes := Buffer.all (First .. Last); + + RME_Index : Index; + LME_Index : Index; + + RME_Offset : constant Natural := Natural (Off); + RME_Size : Natural; + + LME_Size : Natural; + LME_Offset : Natural; + Result : U64 := 0; + + begin + -- This function simply iterates over all data bytes that contain + -- relevant data, from most significant to least significant, and adds + -- them up in Result, shifting the Result before the addition as needed + -- (see helper function Shift_Add). + + -- We track the number of bits that are contained in Result to bound the + -- current value of Result by 2 ** (number of bits). At the end of the + -- function, the number of bits should be Value_Size. + + -- We start with the most significant byte. In network-byte order this + -- is the rightmost byte. We need to take into account the case where + -- this is the only byte. + + Get_Index_Offset (Long_Integer (Data'First), Long_Integer (Data'Last), Off, Value_Size, RME_Index, LME_Index, RME_Size, LME_Size); + LME_Offset := Byte'Size - LME_Size; + + declare + Tmp : U64 := Mask_Upper (Byte'Pos (Data (LME_Index)), LME_Size); + begin + if RME_Index = LME_Index then + Tmp := Right_Shift (Tmp, RME_Offset, LME_Size); + end if; + Result := Result + Tmp; + end; + + -- If it was the only byte, we are done. + + if RME_Index = LME_Index then + pragma Assert (Result < 2 ** (LME_Size - RME_Offset)); + return Result; + end if; + + pragma Assert (Fits_Into (Result, LME_Size)); + + -- We now iterate over the "inner bytes" excluding the two extreme bytes. + for I in LME_Index + 1 .. RME_Index - 1 loop + Result := + Shift_Add + (Result, + Byte'Pos (Data (I)), + Byte'Size, + Natural (I - LME_Index) * Byte'Size - LME_Offset); + pragma Loop_Invariant + (Fits_Into (Result, Natural (I - LME_Index + 1) * Byte'Size - LME_Offset)); + end loop; + + -- We now add the relevant bits from the last byte. + pragma Assert (RME_Size in 1 .. U64'Size); + pragma Assert (if LME_Index + 1 <= RME_Index - 1 then Fits_Into (Result, Natural (RME_Index - LME_Index) * Byte'Size - LME_Offset)); + pragma Assert (if LME_Index + 1 > RME_Index - 1 then Fits_Into (Result, Natural (RME_Index - LME_Index) * Byte'Size - LME_Offset)); + pragma Assert (Value_Size - RME_Size = Natural (RME_Index - LME_Index) * Byte'Size - LME_Offset); + pragma Assert (Fits_Into (Result, Value_Size - RME_Size)); + declare + Bits_To_Read : constant U64 := + Right_Shift (Byte'Pos (Data (RME_Index)), RME_Offset, Byte'Size); + begin + Result := Shift_Add (Result, Bits_To_Read, RME_Size, Value_Size - RME_Size); + end; + return Result; + end U64_Extract; + + function U64_Extract_LE + (Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Value_Size : Positive) return U64 + with + Pre => + (Buffer /= null + and then First >= Buffer'First + and then Last <= Buffer'Last + and then Value_Size in 1 .. U64'Size + and then Long_Integer ((Natural (Off) + Value_Size - 1) / Byte'Size) < Buffer.all (First .. Last)'Length), + Post => + (if Value_Size < U64'Size then U64_Extract_LE'Result < 2**Value_Size) + is + Data : constant Bytes := Buffer.all (First .. Last); + + RME_Index : Index; + LME_Index : Index; + + RME_Offset : constant Natural := Natural (Off); + RME_Size : Natural; + + LME_Size : Natural; + Result : U64 := 0; + + begin + -- This function is identical in structure to the U64_Extract function. + -- See the comments there for more details. However, in little endian we + -- traverse the relevant bytes in the opposite order. + + Get_Index_Offset (Long_Integer (Data'First), Long_Integer (Data'Last), Off, Value_Size, RME_Index, LME_Index, RME_Size, LME_Size); + + declare + Tmp : U64 := Byte'Pos (Data (RME_Index)); + begin + if RME_Index = LME_Index then + Tmp := Mask_Upper (Tmp, LME_Size); + end if; + Tmp := + Right_Shift + (Tmp, + RME_Offset, + (if RME_Index = LME_Index then LME_Size else Byte'Size)); + Result := Result + Tmp; + end; + + if RME_Index = LME_Index then + pragma Assert (Fits_Into (Result, Value_Size)); + return Result; + end if; + + pragma Assert (Fits_Into (Result, RME_Size)); + + for I in reverse LME_Index + 1 .. RME_Index - 1 loop + Result := + Shift_Add + (Result, + Byte'Pos (Data (I)), + Byte'Size, + Natural (RME_Index - I) * Byte'Size - RME_Offset); + pragma Loop_Invariant + (Fits_Into (Result, Natural (RME_Index - I + 1) * Byte'Size - RME_Offset)); + end loop; + + pragma Assert (LME_Size < U64'Size); + pragma Assert (if LME_Index + 1 <= RME_Index - 1 then Fits_Into (Result, Natural (RME_Index - LME_Index) * Byte'Size - RME_Offset)); + pragma Assert (if LME_Index + 1 > RME_Index - 1 then Fits_Into (Result, Natural (RME_Index - LME_Index) * Byte'Size - RME_Offset)); + pragma Assert (Value_Size - LME_Size = Natural (RME_Index - LME_Index) * Byte'Size - RME_Offset); + pragma Assert (Fits_Into (Result, Value_Size - LME_Size)); + Result := + Shift_Add (Result, + Mask_Upper (Byte'Pos (Data (LME_Index)), LME_Size), + LME_Size, + Value_Size - LME_Size); + pragma Assert (Fits_Into (Result, Value_Size)); + return Result; + end U64_Extract_LE; + + procedure U64_Insert + (Val : U64; + Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Value_Size : Positive; + BO : Byte_Order) + with + Pre => + Buffer /= null + and then First >= Buffer'First + and then Last <= Buffer'Last + and then Value_Size <= U64'Size + and then (if Value_Size < U64'Size then Val < 2**Value_Size) + and then Long_Integer (Natural (Off) + Value_Size - 1) / Byte'Size < Buffer.all (First .. Last)'Length, + Post => + Buffer'First = Buffer.all'Old'First and Buffer'Last = Buffer.all'Old'Last + is + RME_Index : Index; + LME_Index : Index; + + RME_Offset : constant Natural := Natural (Off); + RME_Size : Natural; + + LME_Size : Natural; + + RV : U64; + begin + Get_Index_Offset (Long_Integer (First), Long_Integer (Last), Off, Value_Size, RME_Index, LME_Index, RME_Size, LME_Size); + + if RME_Index = LME_Index then + declare + D : constant U64 := Byte'Pos (Buffer.all (RME_Index)); + pragma Assert (Fits_Into (D, Byte'Size)); + L_Bits : constant U64 := Mask_Lower (D, RME_Offset + Value_Size, Byte'Size); + R_Bits : constant U64 := Mask_Upper (D, RME_Offset); + Bits_To_Add : constant U64 := Left_Shift (Val, RME_Offset, Value_Size); + Result : constant U64 := + Add (L_Bits, Add (Bits_To_Add, R_Bits, RME_Offset + Value_Size, RME_Offset), Byte'Size, RME_Offset + Value_Size); + begin + Buffer.all (RME_Index) := Byte'Val (Result); + end; + + else + case BO is + when Low_Order_First => + declare + L_Bits : constant U64 := Mask_Lower (Byte'Pos (Buffer.all (LME_Index)), LME_Size, Byte'Size); + V_Bits : constant U64 := Mask_Upper (Val, LME_Size); + begin + Buffer.all (LME_Index) := Byte'Val (Add (L_Bits, V_Bits, Byte'Size, LME_Size)); + end; + RV := Right_Shift (Val, LME_Size, Value_Size); + pragma Assert (Fits_Into (RV, Value_Size - LME_Size)); + + for I in LME_Index + 1 .. RME_Index - 1 + loop + Buffer.all (I) := Byte'Val (RV mod 2**Byte'Size); + RV := Right_Shift (RV, Byte'Size, Value_Size - LME_Size - Natural (I - LME_Index - 1) * Byte'Size); + pragma Loop_Invariant (Fits_Into (RV, Value_Size - LME_Size - Natural (I - LME_Index) * Byte'Size)); + end loop; + + pragma Assert (RME_Size = Value_Size - LME_Size - Natural (RME_Index - LME_Index - 1) * Byte'Size); + pragma Assert (Fits_Into (RV, RME_Size)); + declare + U_Value : constant U64 := Mask_Upper (Byte'Pos (Buffer.all (RME_Index)), RME_Offset); + R_Value : constant U64 := Left_Shift (RV, RME_Offset, RME_Size); + begin + Buffer.all (RME_Index) := Byte'Val (Add (R_Value, U_Value, Byte'Size, RME_Offset)); + end; + when High_Order_First => + declare + L_Bits : constant U64 := Mask_Upper (Byte'Pos (Buffer.all (RME_Index)), RME_Offset); + V_Bits : constant U64 := Mask_Upper (Val, RME_Size); + V_Value : constant U64 := Left_Shift (V_Bits, RME_Offset, RME_Size); + begin + Buffer.all (RME_Index) := Byte'Val (L_Bits + V_Value); + RV := Right_Shift (Val, RME_Size, Value_Size); + end; + + pragma Assert (RME_Size < Value_Size); + pragma Assert (Fits_Into (RV, Value_Size - RME_Size)); + + for I in reverse LME_Index + 1 .. RME_Index - 1 + loop + Buffer.all (I) := Byte'Val (RV mod 2**Byte'Size); + RV := Right_Shift (RV, Byte'Size, Value_Size - RME_Size - Natural (RME_Index - I - 1) * Byte'Size); + pragma Loop_Invariant (Fits_Into (RV, Value_Size - RME_Size - Natural (RME_Index - I) * Byte'Size)); + end loop; + + pragma Assert (LME_Size = Value_Size - RME_Size - Natural (RME_Index - LME_Index - 1) * Byte'Size); + pragma Assert (Fits_Into (RV, LME_Size)); + declare + U_Value : constant U64 := Mask_Lower (Byte'Pos (Buffer.all (LME_Index)), LME_Size, Byte'Size); + Sum : U64; + begin + Sum := Add (U_Value, RV, Byte'Size, LME_Size); + Buffer.all (LME_Index) := Byte'Val (Sum); + end; + end case; + end if; + end U64_Insert; + + function Extract + (Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Size : Positive; + BO : Byte_Order) return U64 + is + begin + if BO = High_Order_First then + return U64_Extract (Buffer, First, Last, Off, Size); + else + return U64_Extract_LE (Buffer, First, Last, Off, Size); + end if; + end Extract; + + procedure Insert + (Val : U64; + Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Size : Positive; + BO : Byte_Order) + is + begin + U64_Insert (Val, Buffer, First, Last, Off, Size, BO); + end Insert; + +end RFLX.RFLX_Generic_Types; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.ads new file mode 100644 index 0000000000..b5bdea39fd --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_generic_types.ads @@ -0,0 +1,122 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +with Ada.Unchecked_Deallocation; +with RFLX.RFLX_Arithmetic; + +generic + type Custom_Index is range <>; + type Custom_Byte is (<>); + type Custom_Bytes is array (Custom_Index range <>) of Custom_Byte; + type Custom_Bytes_Ptr is access Custom_Bytes; + type Custom_Length is range <>; + type Custom_Bit_Length is range <>; +package RFLX.RFLX_Generic_Types with + SPARK_Mode +is + + subtype Index is Custom_Index; + + subtype Byte is Custom_Byte; + + subtype Bytes is Custom_Bytes; + + subtype Bytes_Ptr is Custom_Bytes_Ptr; + + subtype Length is Custom_Length; + + subtype Bit_Length is Custom_Bit_Length; + + pragma Compile_Time_Error (Index'First /= 1, "Index'First must be 1"); + + pragma Compile_Time_Error (Byte'Size /= 8, "Byte must be of size 8"); + + pragma Compile_Time_Error (Byte'Pos (Byte'Last) - Byte'Pos (Byte'First) + 1 /= 2**Byte'Size, + "Byte must cover entire value range"); + + pragma Compile_Time_Error (Length'First /= 0, "Length'First must be 0"); + + pragma Compile_Time_Error (Length'Pos (Length'Last) /= Index'Pos (Index'Last), + "Length'Last must be equal to Index'Last"); + + pragma Compile_Time_Error (Bit_Length'First /= 0, "Bit_Length'First must be 0"); + + pragma Compile_Time_Error (Bit_Length'Pos (Bit_Length'Last) /= Length'Pos (Length'Last) * 8, + "Bit_Length'Last must be equal to Length'Last * 8"); + + subtype U64 is RFLX.RFLX_Arithmetic.U64; + + use type U64; + + subtype Bit_Index is Bit_Length range 1 .. Bit_Length'Last; + + function To_Index (Bit_Idx : Bit_Length) return Index is + (Index (Length ((Bit_Idx - 1) / 8) + 1)); + + function To_Length (Bit_Len : Bit_Length) return Length is + (Length ((Bit_Len + 7) / 8)); + + function To_Bit_Length (Len : Length) return Bit_Length is + (Bit_Length (Len) * 8); + + function To_First_Bit_Index (Idx : Index) return Bit_Index is + ((Bit_Length (Idx) - 1) * 8 + 1); + + function To_Last_Bit_Index (Idx : Index) return Bit_Index is + ((Bit_Length (Idx) - 1) * 8 + 8); + + function To_Last_Bit_Index (Idx : Length) return Bit_Length is + ((Bit_Length (Idx) - 1) * 8 + 8); + + type Offset is mod 8; + + type Byte_Order is (High_Order_First, Low_Order_First); + + function Extract + (Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Size : Positive; + BO : Byte_Order) return U64 + with + Pre => + (Buffer /= null + and then First >= Buffer'First + and then Last <= Buffer'Last + and then Size in 1 .. U64'Size + and then First <= Last + and then Last - First <= Index'Last - 1 + and then Length ((Offset'Pos (Off) + Size - 1) / Byte'Size) < Length (Last - First + 1) + and then (Offset'Pos (Off) + Size - 1) / Byte'Size <= Natural'Size + and then (Byte'Size - Natural (Offset'Pos (Off) mod Byte'Size)) < Long_Integer'Size - 1); + + procedure Insert + (Val : U64; + Buffer : Bytes_Ptr; + First : Index; + Last : Index; + Off : Offset; + Size : Positive; + BO : Byte_Order) + with + Pre => + (Buffer /= null + and then First >= Buffer'First + and then Last <= Buffer'Last + and then Size in 1 .. U64'Size + and then (if Size < U64'Size then Val < 2**Size) + and then First <= Last + and then Last - First <= Index'Last - 1 + and then Length ((Offset'Pos (Off) + Size - 1) / Byte'Size) < Length (Last - First + 1)), + Post => + (Buffer'First = Buffer.all'Old'First and Buffer'Last = Buffer.all'Old'Last); + + procedure Free is new Ada.Unchecked_Deallocation (Object => Bytes, Name => Bytes_Ptr); + + function Unreachable return Boolean is (False) with Pre => False; + + function Unreachable return Bit_Length is (0) with Pre => False; + + function Unreachable return Length is (0) with Pre => False; + +end RFLX.RFLX_Generic_Types; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.adb new file mode 100644 index 0000000000..bd148a441c --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.adb @@ -0,0 +1,83 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +package body RFLX.RFLX_Message_Sequence with + SPARK_Mode +is + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr) is + begin + Initialize (Ctx, Buffer, RFLX_Types.To_First_Bit_Index (Buffer'First), RFLX_Types.To_Last_Bit_Index (Buffer'Last)); + end Initialize; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) + is + Buffer_First : constant RFLX_Types.Index := Buffer'First; + Buffer_Last : constant RFLX_Types.Index := Buffer'Last; + begin + Ctx := (Buffer_First => Buffer_First, Buffer_Last => Buffer_Last, First => First, Last => Last, Buffer => Buffer, Sequence_Last => First - 1, State => S_Valid); + Buffer := null; + end Initialize; + + procedure Reset (Ctx : in out Context) is + begin + Ctx.Sequence_Last := Ctx.First - 1; + Ctx.State := S_Valid; + end Reset; + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) is + begin + Buffer := Ctx.Buffer; + Ctx.Buffer := null; + end Take_Buffer; + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) is + begin + if Buffer'Length > 0 then + Buffer := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Sequence_Last)); + else + Buffer := Ctx.Buffer.all (RFLX_Types.Index'Last .. RFLX_Types.Index'First); + end if; + end Copy; + + procedure Append_Element (Ctx : in out Context; Element_Ctx : Element_Context) is + begin + Element_Copy (Element_Ctx, Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.Sequence_Last + 1) .. RFLX_Types.To_Index (Ctx.Sequence_Last + Element_Size (Element_Ctx)))); + Ctx.Sequence_Last := Ctx.Sequence_Last + Element_Size (Element_Ctx); + end Append_Element; + + procedure Switch (Ctx : in out Context; Element_Ctx : out Element_Context) is + Buffer : RFLX_Types.Bytes_Ptr := Ctx.Buffer; + begin + Ctx.Buffer := null; + pragma Warnings (Off, "unused assignment to ""Buffer"""); + Element_Initialize (Element_Ctx, Buffer, Ctx.Sequence_Last + 1, Ctx.Last, Ctx.Last); + pragma Warnings (On, "unused assignment to ""Buffer"""); + end Switch; + + procedure Update (Ctx : in out Context; Element_Ctx : in out Element_Context) is + Buffer : RFLX_Types.Bytes_Ptr; + Valid_Message : constant Boolean := Element_Valid_Message (Element_Ctx); + Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First; + begin + if Valid_Message then + Last := Element_Last (Element_Ctx); + end if; + Element_Take_Buffer (Element_Ctx, Buffer); + Ctx.Buffer := Buffer; + if Valid_Message then + Ctx.Sequence_Last := Last; + else + Ctx.State := S_Invalid; + end if; + end Update; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) is + begin + if Data'Length > 0 then + Data := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Sequence_Last)); + else + Data := Ctx.Buffer.all (1 .. 0); + end if; + end Data; + +end RFLX.RFLX_Message_Sequence; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.ads new file mode 100644 index 0000000000..5b03d57510 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_message_sequence.ads @@ -0,0 +1,260 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +with RFLX.RFLX_Types; + +generic + type Element_Context (Buffer_First, Buffer_Last : RFLX_Types.Index; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) is private; + with procedure Element_Initialize (Ctx : out Element_Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length := 0); + with procedure Element_Take_Buffer (Ctx : in out Element_Context; Buffer : out RFLX_Types.Bytes_Ptr); + with procedure Element_Copy (Ctx : Element_Context; Buffer : out RFLX_Types.Bytes); + with function Element_Has_Buffer (Ctx : Element_Context) return Boolean; + with function Element_Size (Ctx : Element_Context) return RFLX_Types.Bit_Length; + with function Element_Last (Ctx : Element_Context) return RFLX_Types.Bit_Index; + with function Element_Initialized (Ctx : Element_Context) return Boolean; + with function Element_Valid_Message (Ctx : Element_Context) return Boolean; +package RFLX.RFLX_Message_Sequence with + SPARK_Mode +is + + pragma Annotate (GNATprove, Terminating, RFLX_Message_Sequence); + + pragma Unevaluated_Use_Of_Old (Allow); + + pragma Warnings (Off, """LENGTH"" is already use-visible through previous use_type_clause"); + + use type RFLX_Types.Bytes_Ptr, RFLX_Types.Index, RFLX_Types.Length, RFLX_Types.Bit_Index; + + pragma Warnings (On, """LENGTH"" is already use-visible through previous use_type_clause"); + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is private with + Default_Initial_Condition => + RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last <= RFLX_Types.Bit_Length'Last - 1 + and First mod RFLX_Types.Byte'Size = 1 + and Last mod RFLX_Types.Byte'Size = 0; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr) with + Pre => + (not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last), + Post => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Buffer = null + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Ctx.Last = RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last) + and Sequence_Last (Ctx) = Ctx.First - 1), + Depends => + (Ctx => Buffer, Buffer => null); + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) with + Pre => + (not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last + and then RFLX_Types.To_Index (First) >= Buffer'First + and then RFLX_Types.To_Index (Last) <= Buffer'Last + and then First <= Last + 1 + and then Last <= RFLX_Types.Bit_Length'Last - 1 + and then First mod RFLX_Types.Byte'Size = 1 + and then Last mod RFLX_Types.Byte'Size = 0), + Post => + (Buffer = null + and Has_Buffer (Ctx) + and Valid (Ctx) + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = First + and Ctx.Last = Last + and Sequence_Last (Ctx) = First - 1), + Depends => + (Ctx => (Buffer, First, Last), Buffer => null); + + procedure Reset (Ctx : in out Context) with + Pre => + Has_Buffer (Ctx), + Post => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Sequence_Last (Ctx) = Ctx.First - 1); + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) with + Pre => + Has_Buffer (Ctx), + Post => + (not Has_Buffer (Ctx) + and Buffer /= null + and Buffer'First = Ctx.Buffer_First + and Buffer'Last = Ctx.Buffer_Last + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Valid (Ctx) = Valid (Ctx)'Old + and Sequence_Last (Ctx) = Sequence_Last (Ctx)'Old), + Depends => + (Ctx => Ctx, Buffer => Ctx); + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) with + Pre => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Byte_Size (Ctx) = Buffer'Length); + + function Has_Element (Ctx : Context) return Boolean with + Contract_Cases => + (Has_Buffer (Ctx) => (Has_Element'Result or not Has_Element'Result) and Has_Buffer (Ctx), + not Has_Buffer (Ctx) => (Has_Element'Result or not Has_Element'Result) and not Has_Buffer (Ctx)); + + procedure Append_Element (Ctx : in out Context; Element_Ctx : Element_Context) with + Pre => + (Has_Buffer (Ctx) + and then Valid (Ctx) + and then Element_Has_Buffer (Element_Ctx) + and then Element_Valid_Message (Element_Ctx) + and then Element_Size (Element_Ctx) > 0 + and then Available_Space (Ctx) >= Element_Size (Element_Ctx)), + Post => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Sequence_Last (Ctx) = Sequence_Last (Ctx)'Old + Element_Size (Element_Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old); + + procedure Switch (Ctx : in out Context; Element_Ctx : out Element_Context) with + Pre => + (not Element_Ctx'Constrained + and then Has_Buffer (Ctx) + and then Has_Element (Ctx) + and then Valid (Ctx)), + Post => + (not Has_Buffer (Ctx) + and Has_Element (Ctx) + and Valid (Ctx) + and Element_Has_Buffer (Element_Ctx) + and Ctx.Buffer_First = Element_Ctx.Buffer_First + and Ctx.Buffer_Last = Element_Ctx.Buffer_Last + and Ctx.First <= Element_Ctx.First + and Ctx.Last >= Element_Ctx.Last + and Element_Ctx.First = Sequence_Last (Ctx) + 1 + and Element_Ctx.Last = Ctx.Last + and Element_Initialized (Element_Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Sequence_Last (Ctx) = Sequence_Last (Ctx)'Old), + Depends => + (Ctx => Ctx, Element_Ctx => Ctx); + + procedure Update (Ctx : in out Context; Element_Ctx : in out Element_Context) with + Pre => + (not Has_Buffer (Ctx) + and then Element_Has_Buffer (Element_Ctx) + and then Has_Element (Ctx) + and then Valid (Ctx) + and then Ctx.Buffer_First = Element_Ctx.Buffer_First + and then Ctx.Buffer_Last = Element_Ctx.Buffer_Last + and then Ctx.First <= Element_Ctx.First + and then Ctx.Last >= Element_Ctx.Last), + Post => + (Has_Buffer (Ctx) + and not Element_Has_Buffer (Element_Ctx) + and (if Element_Valid_Message (Element_Ctx)'Old then Valid (Ctx)) + and Sequence_Last (Ctx) = RFLX_Types.Bit_Length'(if Element_Valid_Message (Element_Ctx) then Element_Last (Element_Ctx) else Sequence_Last (Ctx))'Old + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old), + Contract_Cases => + (Element_Valid_Message (Element_Ctx) => + (Sequence_Last (Ctx) = Element_Last (Element_Ctx)'Old), + others => + True), + Depends => + (Ctx => (Ctx, Element_Ctx), Element_Ctx => Element_Ctx); + + function Valid (Ctx : Context) return Boolean; + + function Has_Buffer (Ctx : Context) return Boolean; + + function Available_Space (Ctx : Context) return RFLX_Types.Bit_Length; + + function Sequence_Last (Ctx : Context) return RFLX_Types.Bit_Length; + + function Size (Ctx : Context) return RFLX_Types.Bit_Length; + + function Byte_Size (Ctx : Context) return RFLX_Types.Length; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) with + Pre => + (Has_Buffer (Ctx) + and then Valid (Ctx) + and then Data'Length = Byte_Size (Ctx)); + +private + + pragma Warnings (Off, "use clause for package * has no effect"); + + use RFLX.RFLX_Types; + + pragma Warnings (On, "use clause for package * has no effect"); + + type Context_State is (S_Valid, S_Invalid); + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is + record + Sequence_Last : RFLX_Types.Bit_Length := First - 1; + Buffer : RFLX_Types.Bytes_Ptr := null; + State : Context_State := S_Valid; + end record with + Dynamic_Predicate => + ((if Buffer /= null then + (Buffer'First = Buffer_First + and Buffer'Last = Buffer_Last)) + and RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last <= RFLX_Types.Bit_Length'Last - 1 + and First - 1 <= Sequence_Last + and Sequence_Last <= Last + and First mod RFLX_Types.Byte'Size = 1 + and Last mod RFLX_Types.Byte'Size = 0 + and Sequence_Last mod RFLX_Types.Byte'Size = 0); + + function Has_Element (Ctx : Context) return Boolean is + (Ctx.State = S_Valid and Ctx.Sequence_Last < Ctx.Last); + + function Valid (Ctx : Context) return Boolean is + (Ctx.State = S_Valid); + + function Has_Buffer (Ctx : Context) return Boolean is + (Ctx.Buffer /= null); + + function Available_Space (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Last - Ctx.Sequence_Last); + + function Sequence_Last (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Sequence_Last); + + function Size (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Sequence_Last - Ctx.First + 1); + + function Byte_Size (Ctx : Context) return RFLX_Types.Length is + (RFLX_Types.To_Length (Size (Ctx))); + +end RFLX.RFLX_Message_Sequence; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.adb new file mode 100644 index 0000000000..0a71858729 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.adb @@ -0,0 +1,95 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); + +package body RFLX.RFLX_Scalar_Sequence with + SPARK_Mode +is + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr) is + begin + Initialize (Ctx, Buffer, RFLX_Types.To_First_Bit_Index (Buffer'First), RFLX_Types.To_Last_Bit_Index (Buffer'Last)); + end Initialize; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) + is + Buffer_First : constant RFLX_Types.Index := Buffer'First; + Buffer_Last : constant RFLX_Types.Index := Buffer'Last; + begin + Ctx := (Buffer_First => Buffer_First, Buffer_Last => Buffer_Last, First => First, Last => Last, Buffer => Buffer, Sequence_Last => First - 1, State => S_Valid, First_Element => RFLX.RFLX_Types.U64'First, Next_Element => RFLX.RFLX_Types.U64'First); + Buffer := null; + end Initialize; + + procedure Reset (Ctx : in out Context) is + begin + Ctx.Sequence_Last := Ctx.First - 1; + Ctx.State := S_Valid; + end Reset; + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) is + begin + Buffer := Ctx.Buffer; + Ctx.Buffer := null; + end Take_Buffer; + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) is + begin + if Buffer'Length > 0 then + Buffer := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Sequence_Last)); + else + Buffer := Ctx.Buffer.all (RFLX_Types.Index'Last .. RFLX_Types.Index'First); + end if; + end Copy; + + procedure Next (Ctx : in out Context) is + Last_Bit : constant RFLX_Types.Bit_Index := Ctx.Sequence_Last + RFLX.RFLX_Types.Bit_Index (Element_Size); + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Sequence_Last + 1); + Buffer_Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Last_Bit); + Offset : constant RFLX_Types.Offset := RFLX_Types.Offset ((8 - (Last_Bit mod 8)) mod 8); + begin + if Buffer_First >= Ctx.Buffer'First and Buffer_Last <= Ctx.Buffer'Last and Buffer_First <= Buffer_Last then + Ctx.Next_Element := Extract (Ctx.Buffer, Buffer_First, Buffer_Last, Offset, Element_Size, RFLX_Types.High_Order_First); + if Valid_Element (Ctx) then + if Size (Ctx) = 0 then + Ctx.First_Element := Ctx.Next_Element; + end if; + else + Ctx.State := S_Invalid; + end if; + end if; + Ctx.Sequence_Last := Ctx.Sequence_Last + RFLX.RFLX_Types.Bit_Index (Element_Size); + end Next; + + function Get_Element (Ctx : Context) return Element_Type is + (To_Actual (Ctx.Next_Element)); + + function Head (Ctx : Context) return Element_Type is + (To_Actual (Ctx.First_Element)); + + procedure Append_Element (Ctx : in out Context; Value : Element_Type) is + Last_Bit : RFLX_Types.Bit_Index; + First : RFLX_Types.Index; + Last : RFLX_Types.Index; + Offset : RFLX_Types.Offset; + begin + Last_Bit := Ctx.Sequence_Last + RFLX.RFLX_Types.Bit_Index (Element_Size); + First := RFLX_Types.To_Index (Ctx.Sequence_Last + 1); + Last := RFLX_Types.To_Index (Last_Bit); + Offset := RFLX_Types.Offset ((8 - (Last_Bit mod 8)) mod 8); + if First >= Ctx.Buffer'First and Last <= Ctx.Buffer'Last and First <= Last then + Insert (To_U64 (Value), Ctx.Buffer, First, Last, Offset, Element_Size, RFLX_Types.High_Order_First); + end if; + if Size (Ctx) = 0 then + Ctx.First_Element := To_U64 (Value); + end if; + Ctx.Sequence_Last := Ctx.Sequence_Last + RFLX.RFLX_Types.Bit_Index (Element_Size); + end Append_Element; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) is + begin + if Data'Length > 0 then + Data := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Sequence_Last)); + else + Data := Ctx.Buffer.all (1 .. 0); + end if; + end Data; + +end RFLX.RFLX_Scalar_Sequence; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.ads new file mode 100644 index 0000000000..4569acf4bd --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_scalar_sequence.ads @@ -0,0 +1,235 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +with RFLX.RFLX_Types; + +generic + type Element_Type is private; + Element_Size : Positive; + with function Valid (Element : RFLX.RFLX_Types.U64) return Boolean; + with function To_Actual (Element : RFLX.RFLX_Types.U64) return Element_Type; + with function To_U64 (Element : Element_Type) return RFLX.RFLX_Types.U64; +package RFLX.RFLX_Scalar_Sequence with + SPARK_Mode +is + + pragma Annotate (GNATprove, Terminating, RFLX_Scalar_Sequence); + + use type RFLX_Types.Bytes_Ptr; + + use type RFLX_Types.Index; + + pragma Warnings (Off, """LENGTH"" is already use-visible through previous use_type_clause"); + + use type RFLX_Types.Length; + + pragma Warnings (On, """LENGTH"" is already use-visible through previous use_type_clause"); + + use type RFLX_Types.Bit_Index; + + use type RFLX_Types.U64; + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is private with + Default_Initial_Condition => + RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last <= RFLX_Types.Bit_Length'Last - 1 + and First mod RFLX_Types.Byte'Size = 1; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr) with + Pre => + (not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last), + Post => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Buffer = null + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Ctx.Last = RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last) + and Sequence_Last (Ctx) = Ctx.First - 1), + Depends => + (Ctx => Buffer, Buffer => null); + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) with + Pre => + (not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last + and then RFLX_Types.To_Index (First) >= Buffer'First + and then RFLX_Types.To_Index (Last) <= Buffer'Last + and then First <= Last + 1 + and then Last <= RFLX_Types.Bit_Length'Last - 1 + and then First mod RFLX_Types.Byte'Size = 1), + Post => + (Buffer = null + and Has_Buffer (Ctx) + and Valid (Ctx) + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = First + and Ctx.Last = Last + and Sequence_Last (Ctx) = First - 1), + Depends => + (Ctx => (Buffer, First, Last), Buffer => null); + + procedure Reset (Ctx : in out Context) with + Pre => + Has_Buffer (Ctx), + Post => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Sequence_Last (Ctx) = Ctx.First - 1); + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) with + Pre => + Has_Buffer (Ctx), + Post => + (not Has_Buffer (Ctx) + and Buffer /= null + and Buffer'First = Ctx.Buffer_First + and Buffer'Last = Ctx.Buffer_Last + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Valid (Ctx) = Valid (Ctx)'Old + and Sequence_Last (Ctx) = Sequence_Last (Ctx)'Old), + Depends => + (Ctx => Ctx, Buffer => Ctx); + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) with + Pre => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Byte_Size (Ctx) = Buffer'Length); + + procedure Next (Ctx : in out Context) with + Pre => + (Has_Buffer (Ctx) + and then Has_Element (Ctx)), + Post => + (Has_Buffer (Ctx) + and Sequence_Last (Ctx) = Sequence_Last (Ctx)'Old + RFLX.RFLX_Types.Bit_Index (Element_Size) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old); + + function Has_Element (Ctx : Context) return Boolean; + + function Valid_Element (Ctx : Context) return Boolean with + Contract_Cases => + (Has_Buffer (Ctx) => (Valid_Element'Result or not Valid_Element'Result) + and Has_Buffer (Ctx), + not Has_Buffer (Ctx) => (Valid_Element'Result or not Valid_Element'Result) + and not Has_Buffer (Ctx)); + + function Get_Element (Ctx : Context) return Element_Type with + Pre => + Valid_Element (Ctx); + + function Head (Ctx : Context) return Element_Type with + Pre => + (Valid (Ctx) + and then Sequence_Last (Ctx) >= Ctx.First + RFLX.RFLX_Types.Bit_Index (Element_Size) - 1); + + procedure Append_Element (Ctx : in out Context; Value : Element_Type) with + Pre => + (Has_Buffer (Ctx) + and then Valid (Ctx) + and then Valid (To_U64 (Value)) + and then (if Element_Size < 64 then To_U64 (Value) < 2**Element_Size) + and then Available_Space (Ctx) >= RFLX.RFLX_Types.Bit_Index (Element_Size)), + Post => + (Has_Buffer (Ctx) + and Valid (Ctx) + and Sequence_Last (Ctx) = Sequence_Last (Ctx)'Old + RFLX.RFLX_Types.Bit_Index (Element_Size) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old); + + function Valid (Ctx : Context) return Boolean; + + function Has_Buffer (Ctx : Context) return Boolean; + + function Available_Space (Ctx : Context) return RFLX_Types.Bit_Length; + + function Sequence_Last (Ctx : Context) return RFLX_Types.Bit_Length; + + function Size (Ctx : Context) return RFLX_Types.Bit_Length; + + function Byte_Size (Ctx : Context) return RFLX_Types.Length; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) with + Pre => + (Has_Buffer (Ctx) + and then Valid (Ctx) + and then Data'Length = Byte_Size (Ctx)); + +private + + pragma Warnings (Off, "use clause for package * has no effect"); + + use RFLX.RFLX_Types; + + pragma Warnings (On, "use clause for package * has no effect"); + + type Context_State is (S_Valid, S_Invalid); + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is + record + Sequence_Last : RFLX_Types.Bit_Length := First - 1; + Buffer : RFLX_Types.Bytes_Ptr := null; + State : Context_State := S_Valid; + First_Element : RFLX.RFLX_Types.U64 := RFLX.RFLX_Types.U64'First; + Next_Element : RFLX.RFLX_Types.U64 := RFLX.RFLX_Types.U64'First; + end record with + Dynamic_Predicate => + ((if Buffer /= null then + (Buffer'First = Buffer_First + and Buffer'Last = Buffer_Last)) + and RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and First mod RFLX_Types.Byte'Size = 1 + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last <= RFLX_Types.Bit_Length'Last - 1 + and Sequence_Last >= First - 1 + and Sequence_Last <= Last + and (if Sequence_Last > First - 1 and State = S_Valid then Valid (First_Element))); + + function Has_Element (Ctx : Context) return Boolean is + (Ctx.State = S_Valid and Ctx.Last - Ctx.Sequence_Last >= RFLX.RFLX_Types.Bit_Index (Element_Size)); + + function Valid_Element (Ctx : Context) return Boolean is + (Ctx.State = S_Valid and Valid (Ctx.Next_Element)); + + function Valid (Ctx : Context) return Boolean is + (Ctx.State = S_Valid); + + function Has_Buffer (Ctx : Context) return Boolean is + (Ctx.Buffer /= null); + + function Available_Space (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Last - Ctx.Sequence_Last); + + function Sequence_Last (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Sequence_Last); + + function Size (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Sequence_Last - Ctx.First + 1); + + function Byte_Size (Ctx : Context) return RFLX_Types.Length is + (RFLX_Types.To_Length (Size (Ctx))); + +end RFLX.RFLX_Scalar_Sequence; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_types.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_types.ads new file mode 100644 index 0000000000..a7db63be74 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-rflx_types.ads @@ -0,0 +1,6 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma SPARK_Mode; +with RFLX.RFLX_Generic_Types; +with RFLX.RFLX_Builtin_Types; + +package RFLX.RFLX_Types is new RFLX.RFLX_Generic_Types (RFLX_Builtin_Types.Index, RFLX_Builtin_Types.Byte, RFLX_Builtin_Types.Bytes, RFLX_Builtin_Types.Bytes_Ptr, RFLX_Builtin_Types.Length, RFLX_Builtin_Types.Bit_Length); diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-test-session.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session.adb new file mode 100644 index 0000000000..5ddbb71d2d --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session.adb @@ -0,0 +1,259 @@ +pragma Restrictions (No_Streams); +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); + +package body RFLX.Test.Session with + SPARK_Mode +is + + use type RFLX.RFLX_Types.Bytes_Ptr; + + use type RFLX.Universal.Message_Type; + + use type RFLX.Universal.Length; + + use type RFLX.RFLX_Types.Bit_Length; + + procedure Start (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Initialized (Ctx) + is + function Start_Invariant return Boolean is + (Ctx.P.Slots.Slot_Ptr_1 = null) + with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + begin + pragma Assert (Start_Invariant); + -- tests/integration/session_setting_of_message_fields/test.rflx:15:10 + Universal.Message.Verify_Message (Ctx.P.Message_Ctx); + if + (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 + Ctx.P.Next_State := S_Process; + else + Ctx.P.Next_State := S_Terminated; + end if; + pragma Assert (Start_Invariant); + end Start; + + procedure Process (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Initialized (Ctx) + is + function Process_Invariant return Boolean is + (Ctx.P.Slots.Slot_Ptr_1 = null) + with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + begin + pragma Assert (Process_Invariant); + -- tests/integration/session_setting_of_message_fields/test.rflx:27:10 + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Data); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + -- tests/integration/session_setting_of_message_fields/test.rflx:29:10 + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, 1); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + -- tests/integration/session_setting_of_message_fields/test.rflx:31:10 + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + Ctx.P.Next_State := S_Reply; + pragma Assert (Process_Invariant); + <> + end Process; + + procedure Reply (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Initialized (Ctx) + is + function Reply_Invariant return Boolean is + (Ctx.P.Slots.Slot_Ptr_1 = null) + with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + begin + pragma Assert (Reply_Invariant); + -- tests/integration/session_setting_of_message_fields/test.rflx:40:10 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Reply_Invariant); + end Reply; + + procedure Initialize (Ctx : in out Context'Class) is + Message_Buffer : RFLX_Types.Bytes_Ptr; + begin + Test.Session_Allocator.Initialize (Ctx.P.Slots, Ctx.P.Memory); + Message_Buffer := Ctx.P.Slots.Slot_Ptr_1; + pragma Warnings (Off, "unused assignment"); + Ctx.P.Slots.Slot_Ptr_1 := null; + pragma Warnings (On, "unused assignment"); + Universal.Message.Initialize (Ctx.P.Message_Ctx, Message_Buffer); + Ctx.P.Next_State := S_Start; + end Initialize; + + procedure Finalize (Ctx : in out Context'Class) is + Message_Buffer : RFLX_Types.Bytes_Ptr; + begin + 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 (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Initialized (Ctx) + is + begin + case Ctx.P.Next_State is + when S_Start => + 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 (Ctx : in out Context'Class) is + begin + case Ctx.P.Next_State is + when S_Start => + Start (Ctx); + when S_Process => + Process (Ctx); + when S_Reply => + Reply (Ctx); + when S_Terminated => + null; + end case; + Reset_Messages_Before_Write (Ctx); + end Tick; + + function In_IO_State (Ctx : Context'Class) return Boolean is + (Ctx.P.Next_State in S_Start | S_Reply); + + procedure Run (Ctx : in out Context'Class) is + begin + Tick (Ctx); + while + Active (Ctx) + and not In_IO_State (Ctx) + loop + pragma Loop_Invariant (Initialized (Ctx)); + Tick (Ctx); + end loop; + end Run; + + 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); + procedure Read (Message_Buffer : RFLX_Types.Bytes) with + Pre => + Read_Pre (Message_Buffer) + is + Length : constant RFLX_Types.Index := RFLX_Types.Index (RFLX_Types.Length'Min (Buffer'Length, Message_Buffer'Length - Offset)); + Buffer_Last : constant RFLX_Types.Index := Buffer'First - 1 + Length; + begin + Buffer (Buffer'First .. RFLX_Types.Index (Buffer_Last)) := Message_Buffer (RFLX_Types.Index (RFLX_Types.Length (Message_Buffer'First) + Offset) .. Message_Buffer'First - 2 + RFLX_Types.Index (Offset + 1) + Length); + end Read; + procedure Universal_Message_Read is new Universal.Message.Generic_Read (Read, Read_Pre); + begin + Buffer := (others => 0); + case Chan is + when C_Channel => + case Ctx.P.Next_State is + when S_Reply => + Universal_Message_Read (Ctx.P.Message_Ctx); + when others => + null; + end case; + end case; + end Read; + + 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_Length + and then Offset <= RFLX_Types.Length'Last - Buffer'Length + 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_Length, + Post => + Length <= Message_Buffer'Length + is + begin + Length := Buffer'Length; + Message_Buffer := (others => 0); + Message_Buffer (Message_Buffer'First .. RFLX_Types.Index (RFLX_Types.Length (Message_Buffer'First) - 1 + Length)) := Buffer; + end Write; + procedure Universal_Message_Write is new Universal.Message.Generic_Write (Write, Write_Pre); + begin + case Chan is + when C_Channel => + case Ctx.P.Next_State is + when S_Start => + Universal_Message_Write (Ctx.P.Message_Ctx, Offset); + when others => + null; + end case; + end case; + end Write; + +end RFLX.Test.Session; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-test-session.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session.ads new file mode 100644 index 0000000000..4712bfc625 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session.ads @@ -0,0 +1,174 @@ +pragma Restrictions (No_Streams); +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +with RFLX.Test.Session_Allocator; +with RFLX.RFLX_Types; +with RFLX.Universal; +with RFLX.Universal.Message; + +package RFLX.Test.Session with + SPARK_Mode +is + + use type RFLX.RFLX_Types.Index; + + use type RFLX.RFLX_Types.Length; + + type Channel is (C_Channel); + + type State is (S_Start, S_Process, S_Reply, S_Terminated); + + type Private_Context is private; + + type Context is abstract tagged limited + record + P : Private_Context; + end record; + + 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 (Ctx), + Post => + Initialized (Ctx) + and Active (Ctx); + + procedure Finalize (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Uninitialized (Ctx) + and not Active (Ctx); + + pragma Warnings (Off, "subprogram ""Tick"" has no effect"); + + procedure Tick (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Initialized (Ctx); + + pragma Warnings (On, "subprogram ""Tick"" has no effect"); + + pragma Warnings (Off, "subprogram ""Run"" has no effect"); + + procedure Run (Ctx : in out Context'Class) with + Pre => + Initialized (Ctx), + Post => + Initialized (Ctx); + + pragma Warnings (On, "subprogram ""Run"" has no effect"); + + function Next_State (Ctx : Context'Class) return State; + + function Has_Data (Ctx : Context'Class; Chan : Channel) return Boolean with + Pre => + Initialized (Ctx); + + function Read_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with + Pre => + Initialized (Ctx) + and then Has_Data (Ctx, Chan); + + procedure Read (Ctx : Context'Class; Chan : Channel; Buffer : out RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + Pre => + 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 (Ctx, Chan), + Post => + Initialized (Ctx); + + function Needs_Data (Ctx : Context'Class; Chan : Channel) return Boolean with + Pre => + Initialized (Ctx); + + function Write_Buffer_Size (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length with + Pre => + Initialized (Ctx) + and then Needs_Data (Ctx, Chan); + + procedure Write (Ctx : in out Context'Class; Chan : Channel; Buffer : RFLX_Types.Bytes; Offset : RFLX_Types.Length := 0) with + Pre => + 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 (Ctx, Chan), + Post => + Initialized (Ctx); + +private + + 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 Global_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); + + function Initialized (Ctx : Context'Class) return Boolean is + (Global_Initialized (Ctx) + 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 => + RFLX_Types.Unreachable))); + + 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 (Ctx : Context'Class; Chan : Channel) return RFLX_Types.Length is + ((case Chan is + when C_Channel => + (case Ctx.P.Next_State is + when S_Start => + Universal.Message.Buffer_Length (Ctx.P.Message_Ctx), + when others => + RFLX_Types.Unreachable))); + +end RFLX.Test.Session; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.adb new file mode 100644 index 0000000000..e1ad070138 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.adb @@ -0,0 +1,24 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); + +package body RFLX.Test.Session_Allocator with + SPARK_Mode +is + + procedure Initialize (S : out Slots; M : Memory) with + SPARK_Mode => + Off + is + begin + 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_setting_of_message_fields/generated/rflx-test-session_allocator.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.ads new file mode 100644 index 0000000000..2d0256b13a --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-test-session_allocator.ads @@ -0,0 +1,46 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +with RFLX.RFLX_Types; +use type RFLX.RFLX_Types.Index; +use type RFLX.RFLX_Types.Bytes_Ptr; + +package RFLX.Test.Session_Allocator with + SPARK_Mode, + Annotate => + (GNATprove, Terminating) +is + + 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 => + Slot_Ptr_Type_4096 = null + or else (Slot_Ptr_Type_4096'First = RFLX_Types.Index'First + and then Slot_Ptr_Type_4096'Last = RFLX_Types.Index'First + 4095); + + type Slots is + record + Slot_Ptr_1 : Slot_Ptr_Type_4096; + end record; + + function Initialized (S : Slots) return Boolean is + (S.Slot_Ptr_1 /= null); + + 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 => + Uninitialized (S); + + function Global_Allocated (S : Slots) return Boolean is + (S.Slot_Ptr_1 = null); + +end RFLX.Test.Session_Allocator; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-test.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-test.ads new file mode 100644 index 0000000000..5c577e81f0 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-test.ads @@ -0,0 +1,8 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); + +package RFLX.Test with + SPARK_Mode +is + +end RFLX.Test; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.adb new file mode 100644 index 0000000000..29e6826791 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.adb @@ -0,0 +1,31 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); + +package body RFLX.Universal.Contains with + SPARK_Mode +is + + procedure Switch_To_Data (Universal_Message_PDU_Context : in out RFLX.Universal.Message.Context; Universal_Option_SDU_Context : out RFLX.Universal.Option.Context) is + First : constant RFLX_Types.Bit_Index := RFLX.Universal.Message.Field_First (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data); + Last : constant RFLX_Types.Bit_Length := RFLX.Universal.Message.Field_Last (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data); + Buffer : RFLX_Types.Bytes_Ptr; + begin + RFLX.Universal.Message.Take_Buffer (Universal_Message_PDU_Context, Buffer); + pragma Warnings (Off, "unused assignment to ""Buffer"""); + RFLX.Universal.Option.Initialize (Universal_Option_SDU_Context, Buffer, First, Last, Last); + pragma Warnings (On, "unused assignment to ""Buffer"""); + end Switch_To_Data; + + procedure Copy_Data (Universal_Message_PDU_Context : RFLX.Universal.Message.Context; Universal_Option_SDU_Context : in out RFLX.Universal.Option.Context) is + First : constant RFLX_Types.Bit_Index := RFLX_Types.To_First_Bit_Index (Universal_Option_SDU_Context.Buffer_First); + Size : constant RFLX_Types.Bit_Index := RFLX.Universal.Message.Field_Size (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data); + Buffer : RFLX_Types.Bytes_Ptr; + begin + pragma Warnings (Off, """Universal_Option_SDU_Context"" is set by ""Take_Buffer"" but not used after the call"); + RFLX.Universal.Option.Take_Buffer (Universal_Option_SDU_Context, Buffer); + pragma Warnings (On, """Universal_Option_SDU_Context"" is set by ""Take_Buffer"" but not used after the call"); + RFLX.Universal.Message.Get_Data (Universal_Message_PDU_Context, Buffer.all (Buffer'First .. Buffer'First + RFLX_Types.Index (RFLX_Types.To_Length (Size)) - 1)); + RFLX.Universal.Option.Initialize (Universal_Option_SDU_Context, Buffer, First, First + Size - 1, First + Size - 1); + end Copy_Data; + +end RFLX.Universal.Contains; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.ads new file mode 100644 index 0000000000..f48c9d48a1 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-contains.ads @@ -0,0 +1,59 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +with RFLX.RFLX_Types; +with RFLX.Universal.Message; +with RFLX.Universal.Option; + +package RFLX.Universal.Contains with + SPARK_Mode, + Annotate => + (GNATprove, Terminating) +is + + use type RFLX_Types.Index; + + use type RFLX_Types.Bit_Index; + + function Option_In_Message_Data (Ctx : RFLX.Universal.Message.Context) return Boolean is + (RFLX.Universal.Message.Has_Buffer (Ctx) + and then RFLX.Universal.Message.Present (Ctx, RFLX.Universal.Message.F_Data)); + + use type RFLX.Universal.Message.Field_Cursors; + + procedure Switch_To_Data (Universal_Message_PDU_Context : in out RFLX.Universal.Message.Context; Universal_Option_SDU_Context : out RFLX.Universal.Option.Context) with + Pre => + not Universal_Message_PDU_Context'Constrained + and not Universal_Option_SDU_Context'Constrained + and RFLX.Universal.Message.Has_Buffer (Universal_Message_PDU_Context) + and RFLX.Universal.Message.Present (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data) + and Option_In_Message_Data (Universal_Message_PDU_Context), + Post => + not RFLX.Universal.Message.Has_Buffer (Universal_Message_PDU_Context) + and RFLX.Universal.Option.Has_Buffer (Universal_Option_SDU_Context) + and Universal_Message_PDU_Context.Buffer_First = Universal_Option_SDU_Context.Buffer_First + and Universal_Message_PDU_Context.Buffer_Last = Universal_Option_SDU_Context.Buffer_Last + and Universal_Option_SDU_Context.First = RFLX.Universal.Message.Field_First (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data) + and Universal_Option_SDU_Context.Last = RFLX.Universal.Message.Field_Last (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data) + and RFLX.Universal.Option.Initialized (Universal_Option_SDU_Context) + and Universal_Message_PDU_Context.Buffer_First = Universal_Message_PDU_Context.Buffer_First'Old + and Universal_Message_PDU_Context.Buffer_Last = Universal_Message_PDU_Context.Buffer_Last'Old + and Universal_Message_PDU_Context.First = Universal_Message_PDU_Context.First'Old + and RFLX.Universal.Message.Context_Cursors (Universal_Message_PDU_Context) = RFLX.Universal.Message.Context_Cursors (Universal_Message_PDU_Context)'Old; + + procedure Copy_Data (Universal_Message_PDU_Context : RFLX.Universal.Message.Context; Universal_Option_SDU_Context : in out RFLX.Universal.Option.Context) with + Pre => + not Universal_Option_SDU_Context'Constrained + and then RFLX.Universal.Option.Has_Buffer (Universal_Option_SDU_Context) + and then RFLX.Universal.Message.Has_Buffer (Universal_Message_PDU_Context) + and then RFLX.Universal.Message.Present (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data) + and then Option_In_Message_Data (Universal_Message_PDU_Context) + and then RFLX_Types.To_Last_Bit_Index (Universal_Option_SDU_Context.Buffer_Last) - RFLX_Types.To_First_Bit_Index (Universal_Option_SDU_Context.Buffer_First) + 1 >= RFLX.Universal.Message.Field_Size (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data) + and then RFLX_Types.To_First_Bit_Index (Universal_Option_SDU_Context.Buffer_First) + RFLX.Universal.Message.Field_Size (Universal_Message_PDU_Context, RFLX.Universal.Message.F_Data) - 1 < RFLX_Types.Bit_Index'Last, + Post => + RFLX.Universal.Message.Has_Buffer (Universal_Message_PDU_Context) + and RFLX.Universal.Option.Has_Buffer (Universal_Option_SDU_Context) + and RFLX.Universal.Option.Initialized (Universal_Option_SDU_Context) + and Universal_Option_SDU_Context.Buffer_First = Universal_Option_SDU_Context.Buffer_First'Old + and Universal_Option_SDU_Context.Buffer_Last = Universal_Option_SDU_Context.Buffer_Last'Old; + +end RFLX.Universal.Contains; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.adb new file mode 100644 index 0000000000..d1a7d33254 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.adb @@ -0,0 +1,877 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); + +package body RFLX.Universal.Message with + SPARK_Mode +is + + pragma Unevaluated_Use_Of_Old (Allow); + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; Written_Last : RFLX_Types.Bit_Length := 0) is + begin + Initialize (Ctx, Buffer, RFLX_Types.To_First_Bit_Index (Buffer'First), RFLX_Types.To_Last_Bit_Index (Buffer'Last), Written_Last); + end Initialize; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length := 0) is + Buffer_First : constant RFLX_Types.Index := Buffer'First; + Buffer_Last : constant RFLX_Types.Index := Buffer'Last; + begin + Ctx := (Buffer_First, Buffer_Last, First, Last, First - 1, (if Written_Last = 0 then First - 1 else Written_Last), Buffer, (F_Message_Type => (State => S_Invalid, Predecessor => F_Initial), others => (State => S_Invalid, Predecessor => F_Final))); + Buffer := null; + end Initialize; + + procedure Reset (Ctx : in out Context) is + begin + Reset (Ctx, RFLX_Types.To_First_Bit_Index (Ctx.Buffer'First), RFLX_Types.To_Last_Bit_Index (Ctx.Buffer'Last)); + end Reset; + + procedure Reset (Ctx : in out Context; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) is + begin + Ctx := (Ctx.Buffer_First, Ctx.Buffer_Last, First, Last, First - 1, First - 1, Ctx.Buffer, (F_Message_Type => (State => S_Invalid, Predecessor => F_Initial), others => (State => S_Invalid, Predecessor => F_Final))); + end Reset; + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) is + begin + Buffer := Ctx.Buffer; + Ctx.Buffer := null; + end Take_Buffer; + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) is + begin + if Buffer'Length > 0 then + Buffer := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last)); + else + Buffer := Ctx.Buffer.all (1 .. 0); + end if; + end Copy; + + function Read (Ctx : Context) return RFLX_Types.Bytes is + (Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last))); + + procedure Generic_Read (Ctx : Context) is + begin + Read (Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last))); + end Generic_Read; + + procedure Generic_Write (Ctx : in out Context; Offset : RFLX_Types.Length := 0) is + Length : RFLX_Types.Length; + begin + Reset (Ctx, RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First), RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last)); + Write (Ctx.Buffer.all (Ctx.Buffer'First + RFLX_Types.Index (Offset + 1) - 1 .. Ctx.Buffer'Last), Length, Ctx.Buffer'Length, Offset); + pragma Assert (Length <= Ctx.Buffer.all'Length, "Length <= Buffer'Length is not ensured by postcondition of ""Write"""); + Ctx.Written_Last := RFLX_Types.Bit_Index'Max (Ctx.Written_Last, RFLX_Types.To_Last_Bit_Index (RFLX_Types.Length (Ctx.Buffer_First) + Offset + Length - 1)); + end Generic_Write; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) is + begin + Data := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last)); + end Data; + + pragma Warnings (Off, "precondition is always False"); + + function Successor (Ctx : Context; Fld : Field) return Virtual_Field is + ((case Fld is + when F_Message_Type => + (if + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + F_Data + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + then + F_Final + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + F_Length + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + F_Options + else + F_Initial), + when F_Length => + (if + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)) + then + F_Data + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)) + then + F_Option_Types + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)) + then + F_Options + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Ctx.Cursors (F_Length).Value) = Universal.Value'Size / 8 + then + F_Value + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)) + then + F_Values + else + F_Initial), + when F_Data | F_Option_Types | F_Options | F_Value | F_Values => + F_Final)) + with + Pre => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, Fld) + and Valid_Predecessor (Ctx, Fld); + + pragma Warnings (On, "precondition is always False"); + + function Invalid_Successor (Ctx : Context; Fld : Field) return Boolean is + ((case Fld is + when F_Message_Type => + Invalid (Ctx.Cursors (F_Data)) + and Invalid (Ctx.Cursors (F_Length)) + and Invalid (Ctx.Cursors (F_Options)), + when F_Length => + Invalid (Ctx.Cursors (F_Data)) + and Invalid (Ctx.Cursors (F_Option_Types)) + and Invalid (Ctx.Cursors (F_Options)) + and Invalid (Ctx.Cursors (F_Value)) + and Invalid (Ctx.Cursors (F_Values)), + when F_Data | F_Option_Types | F_Options | F_Value | F_Values => + True)); + + function Sufficient_Buffer_Length (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Buffer /= null + and Field_First (Ctx, Fld) + Field_Size (Ctx, Fld) < RFLX_Types.Bit_Length'Last + and Ctx.First <= Field_First (Ctx, Fld) + and Field_First (Ctx, Fld) + Field_Size (Ctx, Fld) - 1 <= Ctx.Written_Last) + with + Pre => + Has_Buffer (Ctx) + and Valid_Next (Ctx, Fld); + + function Equal (Ctx : Context; Fld : Field; Data : RFLX_Types.Bytes) return Boolean is + (Sufficient_Buffer_Length (Ctx, Fld) + and then (case Fld is + when F_Data | F_Option_Types | F_Options | F_Values => + Ctx.Buffer.all (RFLX_Types.To_Index (Field_First (Ctx, Fld)) .. RFLX_Types.To_Index (Field_Last (Ctx, Fld))) = Data, + when others => + False)); + + procedure Reset_Dependent_Fields (Ctx : in out Context; Fld : Field) with + Pre => + Valid_Next (Ctx, Fld), + Post => + Valid_Next (Ctx, Fld) + and Invalid (Ctx.Cursors (Fld)) + and Invalid_Successor (Ctx, Fld) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Ctx.Cursors (Fld).Predecessor = Ctx.Cursors (Fld).Predecessor'Old + and Has_Buffer (Ctx) = Has_Buffer (Ctx)'Old + and Field_First (Ctx, Fld) = Field_First (Ctx, Fld)'Old + and Field_Size (Ctx, Fld) = Field_Size (Ctx, Fld)'Old + and (for all F in Field => + (if F < Fld then Ctx.Cursors (F) = Ctx.Cursors'Old (F) else Invalid (Ctx, F))) + is + First : constant RFLX_Types.Bit_Length := Field_First (Ctx, Fld) with + Ghost; + Size : constant RFLX_Types.Bit_Length := Field_Size (Ctx, Fld) with + Ghost; + begin + pragma Assert (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + for Fld_Loop in reverse Field'Succ (Fld) .. Field'Last loop + Ctx.Cursors (Fld_Loop) := (S_Invalid, F_Final); + pragma Loop_Invariant (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + pragma Loop_Invariant ((for all F in Field => + (if F < Fld_Loop then Ctx.Cursors (F) = Ctx.Cursors'Loop_Entry (F) else Invalid (Ctx, F)))); + end loop; + pragma Assert (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + Ctx.Cursors (Fld) := (S_Invalid, Ctx.Cursors (Fld).Predecessor); + pragma Assert (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + end Reset_Dependent_Fields; + + function Composite_Field (Fld : Field) return Boolean is + (Fld in F_Data | F_Option_Types | F_Options | F_Values); + + function Get (Ctx : Context; Fld : Field) return RFLX_Types.U64 with + Pre => + Has_Buffer (Ctx) + and then Valid_Next (Ctx, Fld) + and then Sufficient_Buffer_Length (Ctx, Fld) + and then not Composite_Field (Fld) + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, Fld); + Last : constant RFLX_Types.Bit_Index := Field_Last (Ctx, Fld); + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (First); + Buffer_Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Last); + Offset : constant RFLX_Types.Offset := RFLX_Types.Offset ((RFLX_Types.Byte'Size - Last mod RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size); + Size : constant Positive := (case Fld is + when F_Message_Type => + 8, + when F_Length => + 16, + when F_Value => + 8, + when others => + Positive'Last); + Byte_Order : constant RFLX_Types.Byte_Order := RFLX_Types.High_Order_First; + begin + return RFLX_Types.Extract (Ctx.Buffer, Buffer_First, Buffer_Last, Offset, Size, Byte_Order); + end Get; + + procedure Verify (Ctx : in out Context; Fld : Field) is + Value : RFLX_Types.U64; + begin + if + Invalid (Ctx.Cursors (Fld)) + and then Valid_Predecessor (Ctx, Fld) + and then Path_Condition (Ctx, Fld) + then + if Sufficient_Buffer_Length (Ctx, Fld) then + Value := (if Composite_Field (Fld) then 0 else Get (Ctx, Fld)); + if + Valid_Value (Fld, Value) + and then Field_Condition (Ctx, Fld, Value) + then + pragma Assert ((if + Fld = F_Data + or Fld = F_Message_Type + or Fld = F_Option_Types + or Fld = F_Options + or Fld = F_Value + or Fld = F_Values + then + Field_Last (Ctx, Fld) mod RFLX_Types.Byte'Size = 0)); + pragma Assert ((((Field_Last (Ctx, Fld) + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size = 0); + Ctx.Verified_Last := ((Field_Last (Ctx, Fld) + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size; + pragma Assert (Field_Last (Ctx, Fld) <= Ctx.Verified_Last); + if Composite_Field (Fld) then + Ctx.Cursors (Fld) := (State => S_Structural_Valid, First => Field_First (Ctx, Fld), Last => Field_Last (Ctx, Fld), Value => Value, Predecessor => Ctx.Cursors (Fld).Predecessor); + else + Ctx.Cursors (Fld) := (State => S_Valid, First => Field_First (Ctx, Fld), Last => Field_Last (Ctx, Fld), Value => Value, Predecessor => Ctx.Cursors (Fld).Predecessor); + end if; + Ctx.Cursors (Successor (Ctx, Fld)) := (State => S_Invalid, Predecessor => Fld); + else + Ctx.Cursors (Fld) := (State => S_Invalid, Predecessor => F_Final); + end if; + else + Ctx.Cursors (Fld) := (State => S_Incomplete, Predecessor => F_Final); + end if; + end if; + end Verify; + + procedure Verify_Message (Ctx : in out Context) is + begin + for F in Field loop + Verify (Ctx, F); + end loop; + end Verify_Message; + + function Get_Data (Ctx : Context) return RFLX_Types.Bytes is + First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).First); + Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).Last); + begin + return Ctx.Buffer.all (First .. Last); + end Get_Data; + + procedure Get_Data (Ctx : Context; Data : out RFLX_Types.Bytes) is + First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).First); + Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).Last); + begin + Data := (others => RFLX_Types.Byte'First); + Data (Data'First .. Data'First + (Last - First)) := Ctx.Buffer.all (First .. Last); + end Get_Data; + + procedure Generic_Get_Data (Ctx : Context) is + First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).First); + Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).Last); + begin + Process_Data (Ctx.Buffer.all (First .. Last)); + end Generic_Get_Data; + + procedure Set (Ctx : in out Context; Fld : Field; Val : RFLX_Types.U64; Size : RFLX_Types.Bit_Length; State_Valid : Boolean; Buffer_First : out RFLX_Types.Index; Buffer_Last : out RFLX_Types.Index; Offset : out RFLX_Types.Offset) with + Pre => + Has_Buffer (Ctx) + and then Valid_Next (Ctx, Fld) + and then Valid_Value (Fld, Val) + and then Valid_Size (Ctx, Fld, Size) + and then Size <= Available_Space (Ctx, Fld) + and then (if Composite_Field (Fld) then Size mod RFLX_Types.Byte'Size = 0 else State_Valid), + Post => + Valid_Next (Ctx, Fld) + and then Invalid_Successor (Ctx, Fld) + and then Buffer_First = RFLX_Types.To_Index (Field_First (Ctx, Fld)) + and then Buffer_Last = RFLX_Types.To_Index (Field_First (Ctx, Fld) + Size - 1) + and then Offset = RFLX_Types.Offset ((RFLX_Types.Byte'Size - (Field_First (Ctx, Fld) + Size - 1) mod RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size) + and then Ctx.Buffer_First = Ctx.Buffer_First'Old + and then Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and then Ctx.First = Ctx.First'Old + and then Ctx.Last = Ctx.Last'Old + and then Ctx.Buffer_First = Ctx.Buffer_First'Old + and then Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and then Ctx.First = Ctx.First'Old + and then Ctx.Last = Ctx.Last'Old + and then Has_Buffer (Ctx) = Has_Buffer (Ctx)'Old + and then Predecessor (Ctx, Fld) = Predecessor (Ctx, Fld)'Old + and then Field_First (Ctx, Fld) = Field_First (Ctx, Fld)'Old + and then Available_Space (Ctx, Fld) >= Field_Size (Ctx, Fld) + and then (if State_Valid and Size > 0 then Valid (Ctx, Fld) else Structural_Valid (Ctx, Fld)) + and then (case Fld is + when F_Message_Type => + Get_Message_Type (Ctx) = To_Actual (Val) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Predecessor (Ctx, F_Data) = F_Message_Type + and Valid_Next (Ctx, F_Data)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Predecessor (Ctx, F_Length) = F_Message_Type + and Valid_Next (Ctx, F_Length)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + Predecessor (Ctx, F_Options) = F_Message_Type + and Valid_Next (Ctx, F_Options)) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Length => + Get_Length (Ctx) = To_Actual (Val) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)) + then + Predecessor (Ctx, F_Data) = F_Length + and Valid_Next (Ctx, F_Data)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)) + then + Predecessor (Ctx, F_Option_Types) = F_Length + and Valid_Next (Ctx, F_Option_Types)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)) + then + Predecessor (Ctx, F_Options) = F_Length + and Valid_Next (Ctx, F_Options)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Get_Length (Ctx)) = Universal.Value'Size / 8 + then + Predecessor (Ctx, F_Value) = F_Length + and Valid_Next (Ctx, F_Value)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)) + then + Predecessor (Ctx, F_Values) = F_Length + and Valid_Next (Ctx, F_Values)), + when F_Data | F_Option_Types | F_Options => + (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Value => + Get_Value (Ctx) = To_Actual (Val) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Values => + (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld))) + and then (for all F in Field => + (if F < Fld then Ctx.Cursors (F) = Ctx.Cursors'Old (F))) + is + First : RFLX_Types.Bit_Index; + Last : RFLX_Types.Bit_Length; + begin + Reset_Dependent_Fields (Ctx, Fld); + First := Field_First (Ctx, Fld); + Last := Field_First (Ctx, Fld) + Size - 1; + Offset := RFLX_Types.Offset ((RFLX_Types.Byte'Size - Last mod RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size); + Buffer_First := RFLX_Types.To_Index (First); + Buffer_Last := RFLX_Types.To_Index (Last); + pragma Assert ((((Last + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size = 0); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => ((Last + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size, Written_Last => ((Last + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + pragma Assert (Size = (case Fld is + when F_Message_Type => + 8, + when F_Length => + 16, + when F_Data => + (if + Ctx.Cursors (Fld).Predecessor = F_Length + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Data)) + then + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8 + elsif + Ctx.Cursors (Fld).Predecessor = F_Message_Type + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + RFLX_Types.Bit_Length (Ctx.Written_Last) - RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Last) + else + RFLX_Types.Unreachable), + when F_Option_Types => + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8, + when F_Options => + (if + Ctx.Cursors (Fld).Predecessor = F_Length + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Options)) + then + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8 + elsif + Ctx.Cursors (Fld).Predecessor = F_Message_Type + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + RFLX_Types.Bit_Length (Ctx.Written_Last) - RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Last) + else + RFLX_Types.Unreachable), + when F_Value => + 8, + when F_Values => + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8)); + if State_Valid then + Ctx.Cursors (Fld) := (State => S_Valid, First => First, Last => Last, Value => Val, Predecessor => Ctx.Cursors (Fld).Predecessor); + else + Ctx.Cursors (Fld) := (State => S_Structural_Valid, First => First, Last => Last, Value => Val, Predecessor => Ctx.Cursors (Fld).Predecessor); + end if; + Ctx.Cursors (Successor (Ctx, Fld)) := (State => S_Invalid, Predecessor => Fld); + end Set; + + procedure Set_Scalar (Ctx : in out Context; Fld : Field; Val : RFLX_Types.U64) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, Fld) + and then Valid_Value (Fld, Val) + and then Valid_Size (Ctx, Fld, Field_Size (Ctx, Fld)) + and then Available_Space (Ctx, Fld) >= Field_Size (Ctx, Fld) + and then Field_Size (Ctx, Fld) in 1 .. RFLX_Types.U64'Size + and then (if Field_Size (Ctx, Fld) < RFLX_Types.U64'Size then Val < 2**Natural (Field_Size (Ctx, Fld))), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, Fld) + and Invalid_Successor (Ctx, Fld) + and (case Fld is + when F_Message_Type => + Get_Message_Type (Ctx) = To_Actual (Val) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Predecessor (Ctx, F_Data) = F_Message_Type + and Valid_Next (Ctx, F_Data)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Predecessor (Ctx, F_Length) = F_Message_Type + and Valid_Next (Ctx, F_Length)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + Predecessor (Ctx, F_Options) = F_Message_Type + and Valid_Next (Ctx, F_Options)) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Length => + Get_Length (Ctx) = To_Actual (Val) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)) + then + Predecessor (Ctx, F_Data) = F_Length + and Valid_Next (Ctx, F_Data)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)) + then + Predecessor (Ctx, F_Option_Types) = F_Length + and Valid_Next (Ctx, F_Option_Types)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)) + then + Predecessor (Ctx, F_Options) = F_Length + and Valid_Next (Ctx, F_Options)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Get_Length (Ctx)) = Universal.Value'Size / 8 + then + Predecessor (Ctx, F_Value) = F_Length + and Valid_Next (Ctx, F_Value)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)) + then + Predecessor (Ctx, F_Values) = F_Length + and Valid_Next (Ctx, F_Values)), + when F_Data | F_Option_Types | F_Options => + (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Value => + Get_Value (Ctx) = To_Actual (Val) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Values => + (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld))) + and (for all F in Field => + (if F < Fld then Ctx.Cursors (F) = Ctx.Cursors'Old (F))) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Has_Buffer (Ctx) = Has_Buffer (Ctx)'Old + and Predecessor (Ctx, Fld) = Predecessor (Ctx, Fld)'Old + and Field_First (Ctx, Fld) = Field_First (Ctx, Fld)'Old + is + Buffer_First, Buffer_Last : RFLX_Types.Index; + Offset : RFLX_Types.Offset; + Size : constant RFLX_Types.Bit_Length := Field_Size (Ctx, Fld); + begin + Set (Ctx, Fld, Val, Size, True, Buffer_First, Buffer_Last, Offset); + RFLX_Types.Insert (Val, Ctx.Buffer, Buffer_First, Buffer_Last, Offset, Positive (Size), RFLX_Types.High_Order_First); + end Set_Scalar; + + procedure Set_Message_Type (Ctx : in out Context; Val : RFLX.Universal.Message_Type) is + begin + Set_Scalar (Ctx, F_Message_Type, To_U64 (Val)); + end Set_Message_Type; + + procedure Set_Length (Ctx : in out Context; Val : RFLX.Universal.Length) is + begin + Set_Scalar (Ctx, F_Length, To_U64 (Val)); + end Set_Length; + + procedure Set_Value (Ctx : in out Context; Val : RFLX.Universal.Value) is + begin + Set_Scalar (Ctx, F_Value, To_U64 (Val)); + end Set_Value; + + procedure Set_Data_Empty (Ctx : in out Context) is + Unused_Buffer_First, Unused_Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Data, 0, 0, True, Unused_Buffer_First, Unused_Buffer_Last, Unused_Offset); + end Set_Data_Empty; + + procedure Set_Option_Types_Empty (Ctx : in out Context) is + Unused_Buffer_First, Unused_Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Option_Types, 0, 0, True, Unused_Buffer_First, Unused_Buffer_Last, Unused_Offset); + end Set_Option_Types_Empty; + + procedure Set_Options_Empty (Ctx : in out Context) is + Unused_Buffer_First, Unused_Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Options, 0, 0, True, Unused_Buffer_First, Unused_Buffer_Last, Unused_Offset); + end Set_Options_Empty; + + procedure Set_Values_Empty (Ctx : in out Context) is + Unused_Buffer_First, Unused_Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Values, 0, 0, True, Unused_Buffer_First, Unused_Buffer_Last, Unused_Offset); + end Set_Values_Empty; + + procedure Set_Option_Types (Ctx : in out Context; Seq_Ctx : Universal.Option_Types.Context) is + Size : constant RFLX_Types.Bit_Length := RFLX_Types.To_Bit_Length (Universal.Option_Types.Byte_Size (Seq_Ctx)); + Unused_First, Unused_Last : RFLX_Types.Bit_Index; + Buffer_First, Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Option_Types, 0, Size, True, Buffer_First, Buffer_Last, Unused_Offset); + Universal.Option_Types.Copy (Seq_Ctx, Ctx.Buffer.all (Buffer_First .. Buffer_Last)); + end Set_Option_Types; + + procedure Set_Options (Ctx : in out Context; Seq_Ctx : Universal.Options.Context) is + Size : constant RFLX_Types.Bit_Length := RFLX_Types.To_Bit_Length (Universal.Options.Byte_Size (Seq_Ctx)); + Unused_First, Unused_Last : RFLX_Types.Bit_Index; + Buffer_First, Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Options, 0, Size, True, Buffer_First, Buffer_Last, Unused_Offset); + Universal.Options.Copy (Seq_Ctx, Ctx.Buffer.all (Buffer_First .. Buffer_Last)); + end Set_Options; + + procedure Set_Values (Ctx : in out Context; Seq_Ctx : Universal.Values.Context) is + Size : constant RFLX_Types.Bit_Length := RFLX_Types.To_Bit_Length (Universal.Values.Byte_Size (Seq_Ctx)); + Unused_First, Unused_Last : RFLX_Types.Bit_Index; + Buffer_First, Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Values, 0, Size, True, Buffer_First, Buffer_Last, Unused_Offset); + Universal.Values.Copy (Seq_Ctx, Ctx.Buffer.all (Buffer_First .. Buffer_Last)); + end Set_Values; + + procedure Initialize_Data_Private (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Valid_Length (Ctx, F_Data, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Data)) >= Length + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and Field_Size (Ctx, F_Data) = RFLX_Types.To_Bit_Length (Length) + and Ctx.Verified_Last = Field_Last (Ctx, F_Data) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Data); + Last : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Data) + RFLX_Types.Bit_Length (Length) * RFLX_Types.Byte'Size - 1; + begin + pragma Assert (Last mod RFLX_Types.Byte'Size = 0); + Reset_Dependent_Fields (Ctx, F_Data); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => Last); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Data) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Data).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Data)) := (State => S_Invalid, Predecessor => F_Data); + end Initialize_Data_Private; + + procedure Initialize_Data (Ctx : in out Context; Length : RFLX_Types.Length) is + begin + Initialize_Data_Private (Ctx, Length); + end Initialize_Data; + + procedure Initialize_Option_Types_Private (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Option_Types) + and then Valid_Length (Ctx, F_Option_Types, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Option_Types)) >= Length + and then Field_First (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 1, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Option_Types) + and Field_Size (Ctx, F_Option_Types) = RFLX_Types.To_Bit_Length (Length) + and Ctx.Verified_Last = Field_Last (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Option_Types) = Predecessor (Ctx, F_Option_Types)'Old + and Valid_Next (Ctx, F_Option_Types) = Valid_Next (Ctx, F_Option_Types)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Option_Types); + Last : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Option_Types) + RFLX_Types.Bit_Length (Length) * RFLX_Types.Byte'Size - 1; + begin + pragma Assert (Last mod RFLX_Types.Byte'Size = 0); + Reset_Dependent_Fields (Ctx, F_Option_Types); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => Last); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Option_Types) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Option_Types).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Option_Types)) := (State => S_Invalid, Predecessor => F_Option_Types); + end Initialize_Option_Types_Private; + + procedure Initialize_Option_Types (Ctx : in out Context) is + begin + Initialize_Option_Types_Private (Ctx, RFLX_Types.To_Length (Field_Size (Ctx, F_Option_Types))); + end Initialize_Option_Types; + + procedure Initialize_Options_Private (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Options) + and then Valid_Length (Ctx, F_Options, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Options)) >= Length + and then Field_First (Ctx, F_Options) mod RFLX_Types.Byte'Size = 1, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Options) + and Field_Size (Ctx, F_Options) = RFLX_Types.To_Bit_Length (Length) + and Ctx.Verified_Last = Field_Last (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Options) = Predecessor (Ctx, F_Options)'Old + and Valid_Next (Ctx, F_Options) = Valid_Next (Ctx, F_Options)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Options); + Last : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Options) + RFLX_Types.Bit_Length (Length) * RFLX_Types.Byte'Size - 1; + begin + pragma Assert (Last mod RFLX_Types.Byte'Size = 0); + Reset_Dependent_Fields (Ctx, F_Options); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => Last); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Options) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Options).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Options)) := (State => S_Invalid, Predecessor => F_Options); + end Initialize_Options_Private; + + procedure Initialize_Options (Ctx : in out Context; Length : RFLX_Types.Length) is + begin + Initialize_Options_Private (Ctx, Length); + end Initialize_Options; + + procedure Initialize_Values_Private (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Values) + and then Valid_Length (Ctx, F_Values, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Values)) >= Length + and then Field_First (Ctx, F_Values) mod RFLX_Types.Byte'Size = 1, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Values) + and Field_Size (Ctx, F_Values) = RFLX_Types.To_Bit_Length (Length) + and Ctx.Verified_Last = Field_Last (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Values) = Predecessor (Ctx, F_Values)'Old + and Valid_Next (Ctx, F_Values) = Valid_Next (Ctx, F_Values)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Values); + Last : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Values) + RFLX_Types.Bit_Length (Length) * RFLX_Types.Byte'Size - 1; + begin + pragma Assert (Last mod RFLX_Types.Byte'Size = 0); + Reset_Dependent_Fields (Ctx, F_Values); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => Last); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Values) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Values).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Values)) := (State => S_Invalid, Predecessor => F_Values); + end Initialize_Values_Private; + + procedure Initialize_Values (Ctx : in out Context) is + begin + Initialize_Values_Private (Ctx, RFLX_Types.To_Length (Field_Size (Ctx, F_Values))); + end Initialize_Values; + + procedure Set_Data (Ctx : in out Context; Data : RFLX_Types.Bytes) is + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (Field_First (Ctx, F_Data)); + Buffer_Last : constant RFLX_Types.Index := Buffer_First + Data'Length - 1; + begin + Initialize_Data_Private (Ctx, Data'Length); + pragma Assert (Buffer_Last = RFLX_Types.To_Index (Field_Last (Ctx, F_Data))); + Ctx.Buffer.all (Buffer_First .. Buffer_Last) := Data; + pragma Assert (Ctx.Buffer.all (RFLX_Types.To_Index (Field_First (Ctx, F_Data)) .. RFLX_Types.To_Index (Field_Last (Ctx, F_Data))) = Data); + end Set_Data; + + procedure Generic_Set_Data (Ctx : in out Context; Length : RFLX_Types.Length) is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Data); + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (First); + Buffer_Last : constant RFLX_Types.Index := RFLX_Types.To_Index (First + RFLX_Types.To_Bit_Length (Length) - 1); + begin + Process_Data (Ctx.Buffer.all (Buffer_First .. Buffer_Last)); + Initialize_Data_Private (Ctx, Length); + end Generic_Set_Data; + + procedure Switch_To_Option_Types (Ctx : in out Context; Seq_Ctx : out Universal.Option_Types.Context) is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Option_Types); + Last : constant RFLX_Types.Bit_Index := Field_Last (Ctx, F_Option_Types); + Buffer : RFLX_Types.Bytes_Ptr; + begin + if Invalid (Ctx, F_Option_Types) then + Reset_Dependent_Fields (Ctx, F_Option_Types); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => RFLX_Types.Bit_Length'Max (Ctx.Written_Last, Last)); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Option_Types) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Option_Types).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Option_Types)) := (State => S_Invalid, Predecessor => F_Option_Types); + end if; + Take_Buffer (Ctx, Buffer); + pragma Warnings (Off, "unused assignment to ""Buffer"""); + Universal.Option_Types.Initialize (Seq_Ctx, Buffer, First, Last); + pragma Warnings (On, "unused assignment to ""Buffer"""); + end Switch_To_Option_Types; + + procedure Switch_To_Options (Ctx : in out Context; Seq_Ctx : out Universal.Options.Context) is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Options); + Last : constant RFLX_Types.Bit_Index := Field_Last (Ctx, F_Options); + Buffer : RFLX_Types.Bytes_Ptr; + begin + if Invalid (Ctx, F_Options) then + Reset_Dependent_Fields (Ctx, F_Options); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => RFLX_Types.Bit_Length'Max (Ctx.Written_Last, Last)); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Options) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Options).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Options)) := (State => S_Invalid, Predecessor => F_Options); + end if; + Take_Buffer (Ctx, Buffer); + pragma Warnings (Off, "unused assignment to ""Buffer"""); + Universal.Options.Initialize (Seq_Ctx, Buffer, First, Last); + pragma Warnings (On, "unused assignment to ""Buffer"""); + end Switch_To_Options; + + procedure Switch_To_Values (Ctx : in out Context; Seq_Ctx : out Universal.Values.Context) is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Values); + Last : constant RFLX_Types.Bit_Index := Field_Last (Ctx, F_Values); + Buffer : RFLX_Types.Bytes_Ptr; + begin + if Invalid (Ctx, F_Values) then + Reset_Dependent_Fields (Ctx, F_Values); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => RFLX_Types.Bit_Length'Max (Ctx.Written_Last, Last)); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Values) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Values).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Values)) := (State => S_Invalid, Predecessor => F_Values); + end if; + Take_Buffer (Ctx, Buffer); + pragma Warnings (Off, "unused assignment to ""Buffer"""); + Universal.Values.Initialize (Seq_Ctx, Buffer, First, Last); + pragma Warnings (On, "unused assignment to ""Buffer"""); + end Switch_To_Values; + + procedure Update_Option_Types (Ctx : in out Context; Seq_Ctx : in out Universal.Option_Types.Context) is + Valid_Sequence : constant Boolean := Universal.Option_Types.Valid (Seq_Ctx); + Buffer : RFLX_Types.Bytes_Ptr; + begin + Universal.Option_Types.Take_Buffer (Seq_Ctx, Buffer); + Ctx.Buffer := Buffer; + if Valid_Sequence then + Ctx.Cursors (F_Option_Types) := (State => S_Valid, First => Ctx.Cursors (F_Option_Types).First, Last => Ctx.Cursors (F_Option_Types).Last, Value => Ctx.Cursors (F_Option_Types).Value, Predecessor => Ctx.Cursors (F_Option_Types).Predecessor); + end if; + end Update_Option_Types; + + procedure Update_Options (Ctx : in out Context; Seq_Ctx : in out Universal.Options.Context) is + Valid_Sequence : constant Boolean := Universal.Options.Valid (Seq_Ctx); + Buffer : RFLX_Types.Bytes_Ptr; + begin + Universal.Options.Take_Buffer (Seq_Ctx, Buffer); + Ctx.Buffer := Buffer; + if Valid_Sequence then + Ctx.Cursors (F_Options) := (State => S_Valid, First => Ctx.Cursors (F_Options).First, Last => Ctx.Cursors (F_Options).Last, Value => Ctx.Cursors (F_Options).Value, Predecessor => Ctx.Cursors (F_Options).Predecessor); + end if; + end Update_Options; + + procedure Update_Values (Ctx : in out Context; Seq_Ctx : in out Universal.Values.Context) is + Valid_Sequence : constant Boolean := Universal.Values.Valid (Seq_Ctx); + Buffer : RFLX_Types.Bytes_Ptr; + begin + Universal.Values.Take_Buffer (Seq_Ctx, Buffer); + Ctx.Buffer := Buffer; + if Valid_Sequence then + Ctx.Cursors (F_Values) := (State => S_Valid, First => Ctx.Cursors (F_Values).First, Last => Ctx.Cursors (F_Values).Last, Value => Ctx.Cursors (F_Values).Value, Predecessor => Ctx.Cursors (F_Values).Predecessor); + end if; + end Update_Values; + +end RFLX.Universal.Message; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.ads new file mode 100644 index 0000000000..8cfcb38430 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-message.ads @@ -0,0 +1,1614 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +with RFLX.RFLX_Types; +with RFLX.Universal.Option_Types; +with RFLX.Universal.Options; +with RFLX.Universal.Values; + +package RFLX.Universal.Message with + SPARK_Mode, + Annotate => + (GNATprove, Terminating) +is + + pragma Warnings (Off, "use clause for type ""U64"" * has no effect"); + + pragma Warnings (Off, """U64"" is already use-visible through previous use_type_clause"); + + pragma Warnings (Off, """LENGTH"" is already use-visible through previous use_type_clause"); + + use type RFLX_Types.Bytes; + + use type RFLX_Types.Bytes_Ptr; + + use type RFLX_Types.Length; + + use type RFLX_Types.Index; + + use type RFLX_Types.Bit_Index; + + use type RFLX_Types.U64; + + use type RFLX_Types.Offset; + + pragma Warnings (On, """LENGTH"" is already use-visible through previous use_type_clause"); + + pragma Warnings (On, """U64"" is already use-visible through previous use_type_clause"); + + pragma Warnings (On, "use clause for type ""U64"" * has no effect"); + + pragma Unevaluated_Use_Of_Old (Allow); + + type Virtual_Field is (F_Initial, F_Message_Type, F_Length, F_Data, F_Option_Types, F_Options, F_Value, F_Values, F_Final); + + subtype Field is Virtual_Field range F_Message_Type .. F_Values; + + type Field_Cursor is private with + Default_Initial_Condition => + False; + + type Field_Cursors is private with + Default_Initial_Condition => + False; + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is private with + Default_Initial_Condition => + RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last < RFLX_Types.Bit_Index'Last + and First rem RFLX_Types.Byte'Size = 1 + and Last rem RFLX_Types.Byte'Size = 0; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; Written_Last : RFLX_Types.Bit_Length := 0) with + Pre => + not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last + and then (Written_Last = 0 + or (Written_Last >= RFLX_Types.To_First_Bit_Index (Buffer'First) - 1 + and Written_Last <= RFLX_Types.To_Last_Bit_Index (Buffer'Last))) + and then Written_Last mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Buffer = null + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Ctx.Last = RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last) + and Initialized (Ctx), + Depends => + (Ctx => (Buffer, Written_Last), Buffer => null); + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length := 0) with + Pre => + not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last + and then RFLX_Types.To_Index (First) >= Buffer'First + and then RFLX_Types.To_Index (Last) <= Buffer'Last + and then First <= Last + 1 + and then Last < RFLX_Types.Bit_Index'Last + and then First rem RFLX_Types.Byte'Size = 1 + and then Last rem RFLX_Types.Byte'Size = 0 + and then (Written_Last = 0 + or (Written_Last >= First - 1 + and Written_Last <= Last)) + and then Written_Last rem RFLX_Types.Byte'Size = 0, + Post => + Buffer = null + and Has_Buffer (Ctx) + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = First + and Ctx.Last = Last + and Initialized (Ctx), + Depends => + (Ctx => (Buffer, First, Last, Written_Last), Buffer => null); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Initialized (Ctx : Context) return Boolean with + Ghost, + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + procedure Reset (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and Has_Buffer (Ctx), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Ctx.Last = RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last) + and Initialized (Ctx); + + procedure Reset (Ctx : in out Context; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) with + Pre => + not Ctx'Constrained + and Has_Buffer (Ctx) + and RFLX_Types.To_Index (First) >= Ctx.Buffer_First + and RFLX_Types.To_Index (Last) <= Ctx.Buffer_Last + and First <= Last + 1 + and Last < RFLX_Types.Bit_Length'Last + and First rem RFLX_Types.Byte'Size = 1 + and Last rem RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = First + and Ctx.Last = Last + and Initialized (Ctx); + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) with + Pre => + Has_Buffer (Ctx), + Post => + not Has_Buffer (Ctx) + and Buffer /= null + and Ctx.Buffer_First = Buffer'First + and Ctx.Buffer_Last = Buffer'Last + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Context_Cursors (Ctx) = Context_Cursors (Ctx)'Old, + Depends => + (Ctx => Ctx, Buffer => Ctx); + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx) + and then Byte_Size (Ctx) = Buffer'Length; + + function Read (Ctx : Context) return RFLX_Types.Bytes with + Ghost, + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx); + + pragma Warnings (Off, "formal parameter ""*"" is not referenced"); + + function Always_Valid (Buffer : RFLX_Types.Bytes) return Boolean is + (True); + + pragma Warnings (On, "formal parameter ""*"" is not referenced"); + + generic + with procedure Read (Buffer : RFLX_Types.Bytes); + with function Pre (Buffer : RFLX_Types.Bytes) return Boolean is Always_Valid; + procedure Generic_Read (Ctx : Context) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx) + and then Pre (Read (Ctx)); + + pragma Warnings (Off, "formal parameter ""*"" is not referenced"); + + function Always_Valid (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is + (True); + + pragma Warnings (On, "formal parameter ""*"" is not referenced"); + + generic + with procedure Write (Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length); + with function Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is Always_Valid; + procedure Generic_Write (Ctx : in out Context; Offset : RFLX_Types.Length := 0) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Offset < Buffer_Length (Ctx) + and then Pre (Buffer_Length (Ctx), Offset), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Initialized (Ctx); + + function Has_Buffer (Ctx : Context) return Boolean; + + function Buffer_Length (Ctx : Context) return RFLX_Types.Length with + Pre => + Has_Buffer (Ctx); + + function Size (Ctx : Context) return RFLX_Types.Bit_Length with + Post => + Size'Result rem RFLX_Types.Byte'Size = 0; + + function Byte_Size (Ctx : Context) return RFLX_Types.Length; + + function Message_Last (Ctx : Context) return RFLX_Types.Bit_Length with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx); + + function Written_Last (Ctx : Context) return RFLX_Types.Bit_Length; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx) + and then Data'Length = Byte_Size (Ctx); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Value (Fld : Field; Val : RFLX_Types.U64) return Boolean with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Path_Condition (Ctx : Context; Fld : Field) return Boolean with + Pre => + Valid_Predecessor (Ctx, Fld), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Field_Condition (Ctx : Context; Fld : Field; Val : RFLX_Types.U64) return Boolean with + Pre => + Has_Buffer (Ctx) + and Valid_Predecessor (Ctx, Fld) + and Valid_Value (Fld, Val), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + function Field_Size (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length with + Pre => + Valid_Next (Ctx, Fld), + Post => + (case Fld is + when F_Data | F_Option_Types | F_Options | F_Values => + Field_Size'Result rem RFLX_Types.Byte'Size = 0, + when others => + True); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Field_First (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Index with + Pre => + Valid_Next (Ctx, Fld), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + function Field_Last (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length with + Pre => + Valid_Next (Ctx, Fld) + and then Available_Space (Ctx, Fld) >= Field_Size (Ctx, Fld), + Post => + (case Fld is + when F_Data | F_Option_Types | F_Options | F_Values => + Field_Last'Result rem RFLX_Types.Byte'Size = 0, + when others => + True); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Predecessor (Ctx : Context; Fld : Virtual_Field) return Virtual_Field with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Predecessor (Ctx : Context; Fld : Virtual_Field) return Boolean with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + function Valid_Next (Ctx : Context; Fld : Field) return Boolean; + + function Available_Space (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length with + Pre => + Valid_Next (Ctx, Fld); + + function Equal (Ctx : Context; Fld : Field; Data : RFLX_Types.Bytes) return Boolean with + Pre => + Has_Buffer (Ctx) + and Valid_Next (Ctx, Fld); + + procedure Verify (Ctx : in out Context; Fld : Field) with + Pre => + Has_Buffer (Ctx), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old; + + procedure Verify_Message (Ctx : in out Context) with + Pre => + Has_Buffer (Ctx), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old; + + function Present (Ctx : Context; Fld : Field) return Boolean; + + function Structural_Valid (Ctx : Context; Fld : Field) return Boolean; + + function Valid (Ctx : Context; Fld : Field) return Boolean with + Post => + (if Valid'Result then Structural_Valid (Ctx, Fld) and Present (Ctx, Fld)); + + function Incomplete (Ctx : Context; Fld : Field) return Boolean; + + function Invalid (Ctx : Context; Fld : Field) return Boolean; + + function Structural_Valid_Message (Ctx : Context) return Boolean with + Pre => + Has_Buffer (Ctx); + + function Valid_Message (Ctx : Context) return Boolean with + Pre => + Has_Buffer (Ctx); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Incomplete_Message (Ctx : Context) return Boolean with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "precondition is always False"); + + function Get_Message_Type (Ctx : Context) return RFLX.Universal.Message_Type with + Pre => + Valid (Ctx, F_Message_Type); + + function Get_Length (Ctx : Context) return RFLX.Universal.Length with + Pre => + Valid (Ctx, F_Length); + + function Get_Value (Ctx : Context) return RFLX.Universal.Value with + Pre => + Valid (Ctx, F_Value); + + pragma Warnings (On, "precondition is always False"); + + function Get_Data (Ctx : Context) return RFLX_Types.Bytes with + Ghost, + Pre => + Has_Buffer (Ctx) + and then Structural_Valid (Ctx, F_Data) + and then Valid_Next (Ctx, F_Data), + Post => + Get_Data'Result'Length = RFLX_Types.To_Length (Field_Size (Ctx, F_Data)); + + procedure Get_Data (Ctx : Context; Data : out RFLX_Types.Bytes) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid (Ctx, F_Data) + and then Valid_Next (Ctx, F_Data) + and then Data'Length = RFLX_Types.To_Length (Field_Size (Ctx, F_Data)), + Post => + Equal (Ctx, F_Data, Data); + + generic + with procedure Process_Data (Data : RFLX_Types.Bytes); + procedure Generic_Get_Data (Ctx : Context) with + Pre => + Has_Buffer (Ctx) + and Present (Ctx, F_Data); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Length (Ctx : Context; Fld : Field; Length : RFLX_Types.Length) return Boolean with + Pre => + Valid_Next (Ctx, Fld), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "aspect ""*"" not enforced on inlined subprogram ""*"""); + + procedure Set_Message_Type (Ctx : in out Context; Val : RFLX.Universal.Message_Type) with + Inline_Always, + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Message_Type) + and then RFLX.Universal.Valid_Message_Type (To_U64 (Val)) + and then Field_Condition (Ctx, F_Message_Type, To_U64 (Val)) + and then Available_Space (Ctx, F_Message_Type) >= Field_Size (Ctx, F_Message_Type), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, F_Message_Type) + and Get_Message_Type (Ctx) = Val + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Message_Type)) + and Invalid (Ctx, F_Length) + and Invalid (Ctx, F_Data) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Predecessor (Ctx, F_Data) = F_Message_Type + and Valid_Next (Ctx, F_Data)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Predecessor (Ctx, F_Length) = F_Message_Type + and Valid_Next (Ctx, F_Length)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + Predecessor (Ctx, F_Options) = F_Message_Type + and Valid_Next (Ctx, F_Options)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Message_Type) = Predecessor (Ctx, F_Message_Type)'Old + and Valid_Next (Ctx, F_Message_Type) = Valid_Next (Ctx, F_Message_Type)'Old; + + procedure Set_Length (Ctx : in out Context; Val : RFLX.Universal.Length) with + Inline_Always, + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Length) + and then RFLX.Universal.Valid_Length (To_U64 (Val)) + and then Field_Condition (Ctx, F_Length, To_U64 (Val)) + and then Available_Space (Ctx, F_Length) >= Field_Size (Ctx, F_Length), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, F_Length) + and Get_Length (Ctx) = Val + and Invalid (Ctx, F_Data) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)) + then + Predecessor (Ctx, F_Data) = F_Length + and Valid_Next (Ctx, F_Data)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)) + then + Predecessor (Ctx, F_Option_Types) = F_Length + and Valid_Next (Ctx, F_Option_Types)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)) + then + Predecessor (Ctx, F_Options) = F_Length + and Valid_Next (Ctx, F_Options)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Get_Length (Ctx)) = Universal.Value'Size / 8 + then + Predecessor (Ctx, F_Value) = F_Length + and Valid_Next (Ctx, F_Value)) + and (if + RFLX_Types.U64 (To_U64 (Get_Message_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)) + then + Predecessor (Ctx, F_Values) = F_Length + and Valid_Next (Ctx, F_Values)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Length) = Predecessor (Ctx, F_Length)'Old + and Valid_Next (Ctx, F_Length) = Valid_Next (Ctx, F_Length)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and (for all F in Field range F_Message_Type .. F_Message_Type => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)); + + procedure Set_Value (Ctx : in out Context; Val : RFLX.Universal.Value) with + Inline_Always, + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Value) + and then RFLX.Universal.Valid_Value (To_U64 (Val)) + and then Field_Condition (Ctx, F_Value, To_U64 (Val)) + and then Available_Space (Ctx, F_Value) >= Field_Size (Ctx, F_Value), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, F_Value) + and Get_Value (Ctx) = Val + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Value)) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Value) = Predecessor (Ctx, F_Value)'Old + and Valid_Next (Ctx, F_Value) = Valid_Next (Ctx, F_Value)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + and (for all F in Field range F_Message_Type .. F_Options => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)); + + pragma Warnings (On, "aspect ""*"" not enforced on inlined subprogram ""*"""); + + procedure Set_Data_Empty (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Field_Condition (Ctx, F_Data, 0) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old; + + procedure Set_Option_Types_Empty (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Option_Types) + and then Field_Condition (Ctx, F_Option_Types, 0) + and then Available_Space (Ctx, F_Option_Types) >= Field_Size (Ctx, F_Option_Types) + and then Field_First (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Option_Types) = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Option_Types) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Option_Types)) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Option_Types) = Predecessor (Ctx, F_Option_Types)'Old + and Valid_Next (Ctx, F_Option_Types) = Valid_Next (Ctx, F_Option_Types)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + procedure Set_Options_Empty (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Options) + and then Field_Condition (Ctx, F_Options, 0) + and then Available_Space (Ctx, F_Options) >= Field_Size (Ctx, F_Options) + and then Field_First (Ctx, F_Options) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Options) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Options) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Options) = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Options) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Options)) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Options) = Predecessor (Ctx, F_Options)'Old + and Valid_Next (Ctx, F_Options) = Valid_Next (Ctx, F_Options)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old; + + procedure Set_Values_Empty (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Values) + and then Field_Condition (Ctx, F_Values, 0) + and then Available_Space (Ctx, F_Values) >= Field_Size (Ctx, F_Values) + and then Field_First (Ctx, F_Values) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Values) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Values) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Values) = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Values) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Values)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Values) = Predecessor (Ctx, F_Values)'Old + and Valid_Next (Ctx, F_Values) = Valid_Next (Ctx, F_Values)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + procedure Set_Option_Types (Ctx : in out Context; Seq_Ctx : Universal.Option_Types.Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Option_Types) + and then Field_Condition (Ctx, F_Option_Types, 0) + and then Available_Space (Ctx, F_Option_Types) >= Field_Size (Ctx, F_Option_Types) + and then Field_First (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Option_Types, Universal.Option_Types.Byte_Size (Seq_Ctx)) + and then Universal.Option_Types.Has_Buffer (Seq_Ctx) + and then Universal.Option_Types.Valid (Seq_Ctx), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Option_Types) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Option_Types)) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Option_Types) = Predecessor (Ctx, F_Option_Types)'Old + and Valid_Next (Ctx, F_Option_Types) = Valid_Next (Ctx, F_Option_Types)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + and (if Field_Size (Ctx, F_Option_Types) > 0 then Present (Ctx, F_Option_Types)); + + procedure Set_Options (Ctx : in out Context; Seq_Ctx : Universal.Options.Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Options) + and then Field_Condition (Ctx, F_Options, 0) + and then Available_Space (Ctx, F_Options) >= Field_Size (Ctx, F_Options) + and then Field_First (Ctx, F_Options) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Options) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Options) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Options, Universal.Options.Byte_Size (Seq_Ctx)) + and then Universal.Options.Has_Buffer (Seq_Ctx) + and then Universal.Options.Valid (Seq_Ctx), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Options) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Options)) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Options) = Predecessor (Ctx, F_Options)'Old + and Valid_Next (Ctx, F_Options) = Valid_Next (Ctx, F_Options)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and (if Field_Size (Ctx, F_Options) > 0 then Present (Ctx, F_Options)); + + procedure Set_Values (Ctx : in out Context; Seq_Ctx : Universal.Values.Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Values) + and then Field_Condition (Ctx, F_Values, 0) + and then Available_Space (Ctx, F_Values) >= Field_Size (Ctx, F_Values) + and then Field_First (Ctx, F_Values) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Values) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Values) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Values, Universal.Values.Byte_Size (Seq_Ctx)) + and then Universal.Values.Has_Buffer (Seq_Ctx) + and then Universal.Values.Valid (Seq_Ctx), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Values) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Values)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Values) = Predecessor (Ctx, F_Values)'Old + and Valid_Next (Ctx, F_Values) = Valid_Next (Ctx, F_Values)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + and (if Field_Size (Ctx, F_Values) > 0 then Present (Ctx, F_Values)); + + procedure Initialize_Data (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Valid_Length (Ctx, F_Data, Length) + and then Available_Space (Ctx, F_Data) >= RFLX_Types.To_Bit_Length (Length) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and Field_Size (Ctx, F_Data) = RFLX_Types.To_Bit_Length (Length) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old; + + procedure Initialize_Option_Types (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Option_Types) + and then Available_Space (Ctx, F_Option_Types) >= Field_Size (Ctx, F_Option_Types) + and then Field_First (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Option_Types) mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Option_Types) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Option_Types)) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Option_Types) = Predecessor (Ctx, F_Option_Types)'Old + and Valid_Next (Ctx, F_Option_Types) = Valid_Next (Ctx, F_Option_Types)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + procedure Initialize_Options (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Options) + and then Valid_Length (Ctx, F_Options, Length) + and then Available_Space (Ctx, F_Options) >= RFLX_Types.To_Bit_Length (Length) + and then Field_First (Ctx, F_Options) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Options) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Options) mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Options) + and Field_Size (Ctx, F_Options) = RFLX_Types.To_Bit_Length (Length) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Options)) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Options) = Predecessor (Ctx, F_Options)'Old + and Valid_Next (Ctx, F_Options) = Valid_Next (Ctx, F_Options)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old; + + procedure Initialize_Values (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Values) + and then Available_Space (Ctx, F_Values) >= Field_Size (Ctx, F_Values) + and then Field_First (Ctx, F_Values) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Values) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Values) mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Values) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Values)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Values) = Predecessor (Ctx, F_Values)'Old + and Valid_Next (Ctx, F_Values) = Valid_Next (Ctx, F_Values)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + procedure Set_Data (Ctx : in out Context; Data : RFLX_Types.Bytes) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Data, Data'Length) + and then Available_Space (Ctx, F_Data) >= Data'Length * RFLX_Types.Byte'Size + and then Field_Condition (Ctx, F_Data, 0), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old + and Equal (Ctx, F_Data, Data); + + generic + with procedure Process_Data (Data : out RFLX_Types.Bytes); + with function Process_Data_Pre (Length : RFLX_Types.Length) return Boolean; + procedure Generic_Set_Data (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Data, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Data)) >= Length + and then Process_Data_Pre (Length), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Invalid (Ctx, F_Option_Types) + and Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Message_Type (Ctx) = Get_Message_Type (Ctx)'Old; + + procedure Switch_To_Option_Types (Ctx : in out Context; Seq_Ctx : out Universal.Option_Types.Context) with + Pre => + not Ctx'Constrained + and then not Seq_Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Option_Types) + and then Field_Size (Ctx, F_Option_Types) > 0 + and then Field_First (Ctx, F_Option_Types) rem RFLX_Types.Byte'Size = 1 + and then Field_Condition (Ctx, F_Option_Types, 0) + and then Available_Space (Ctx, F_Option_Types) >= Field_Size (Ctx, F_Option_Types), + Post => + not Has_Buffer (Ctx) + and Universal.Option_Types.Has_Buffer (Seq_Ctx) + and Ctx.Buffer_First = Seq_Ctx.Buffer_First + and Ctx.Buffer_Last = Seq_Ctx.Buffer_Last + and Seq_Ctx.First = Field_First (Ctx, F_Option_Types) + and Seq_Ctx.Last = Field_Last (Ctx, F_Option_Types) + and Universal.Option_Types.Valid (Seq_Ctx) + and Universal.Option_Types.Sequence_Last (Seq_Ctx) = Seq_Ctx.First - 1 + and Present (Ctx, F_Option_Types) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Option_Types) = Predecessor (Ctx, F_Option_Types)'Old + and Path_Condition (Ctx, F_Option_Types) = Path_Condition (Ctx, F_Option_Types)'Old + and Field_Last (Ctx, F_Option_Types) = Field_Last (Ctx, F_Option_Types)'Old + and (for all F in Field range F_Message_Type .. F_Data => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)), + Contract_Cases => + (Structural_Valid (Ctx, F_Option_Types) => + (for all F in Field range F_Options .. F_Values => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)), + others => + Invalid (Ctx, F_Options) + and Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values)); + + procedure Switch_To_Options (Ctx : in out Context; Seq_Ctx : out Universal.Options.Context) with + Pre => + not Ctx'Constrained + and then not Seq_Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Options) + and then Field_Size (Ctx, F_Options) > 0 + and then Field_First (Ctx, F_Options) rem RFLX_Types.Byte'Size = 1 + and then Field_Condition (Ctx, F_Options, 0) + and then Available_Space (Ctx, F_Options) >= Field_Size (Ctx, F_Options), + Post => + not Has_Buffer (Ctx) + and Universal.Options.Has_Buffer (Seq_Ctx) + and Ctx.Buffer_First = Seq_Ctx.Buffer_First + and Ctx.Buffer_Last = Seq_Ctx.Buffer_Last + and Seq_Ctx.First = Field_First (Ctx, F_Options) + and Seq_Ctx.Last = Field_Last (Ctx, F_Options) + and Universal.Options.Valid (Seq_Ctx) + and Universal.Options.Sequence_Last (Seq_Ctx) = Seq_Ctx.First - 1 + and Present (Ctx, F_Options) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Options) = Predecessor (Ctx, F_Options)'Old + and Path_Condition (Ctx, F_Options) = Path_Condition (Ctx, F_Options)'Old + and Field_Last (Ctx, F_Options) = Field_Last (Ctx, F_Options)'Old + and (for all F in Field range F_Message_Type .. F_Option_Types => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)), + Contract_Cases => + (Structural_Valid (Ctx, F_Options) => + (for all F in Field range F_Value .. F_Values => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)), + others => + Invalid (Ctx, F_Value) + and Invalid (Ctx, F_Values)); + + procedure Switch_To_Values (Ctx : in out Context; Seq_Ctx : out Universal.Values.Context) with + Pre => + not Ctx'Constrained + and then not Seq_Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Values) + and then Field_Size (Ctx, F_Values) > 0 + and then Field_First (Ctx, F_Values) rem RFLX_Types.Byte'Size = 1 + and then Field_Condition (Ctx, F_Values, 0) + and then Available_Space (Ctx, F_Values) >= Field_Size (Ctx, F_Values), + Post => + not Has_Buffer (Ctx) + and Universal.Values.Has_Buffer (Seq_Ctx) + and Ctx.Buffer_First = Seq_Ctx.Buffer_First + and Ctx.Buffer_Last = Seq_Ctx.Buffer_Last + and Seq_Ctx.First = Field_First (Ctx, F_Values) + and Seq_Ctx.Last = Field_Last (Ctx, F_Values) + and Universal.Values.Valid (Seq_Ctx) + and Universal.Values.Sequence_Last (Seq_Ctx) = Seq_Ctx.First - 1 + and Present (Ctx, F_Values) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Values) = Predecessor (Ctx, F_Values)'Old + and Path_Condition (Ctx, F_Values) = Path_Condition (Ctx, F_Values)'Old + and Field_Last (Ctx, F_Values) = Field_Last (Ctx, F_Values)'Old + and (for all F in Field range F_Message_Type .. F_Value => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)), + Contract_Cases => + (Structural_Valid (Ctx, F_Values) => + True, + others => + True); + + function Complete_Option_Types (Ctx : Context; Seq_Ctx : Universal.Option_Types.Context) return Boolean with + Pre => + Valid_Next (Ctx, F_Option_Types); + + function Complete_Options (Ctx : Context; Seq_Ctx : Universal.Options.Context) return Boolean with + Pre => + Valid_Next (Ctx, F_Options); + + function Complete_Values (Ctx : Context; Seq_Ctx : Universal.Values.Context) return Boolean with + Pre => + Valid_Next (Ctx, F_Values); + + procedure Update_Option_Types (Ctx : in out Context; Seq_Ctx : in out Universal.Option_Types.Context) with + Pre => + Present (Ctx, F_Option_Types) + and then Complete_Option_Types (Ctx, Seq_Ctx) + and then not Has_Buffer (Ctx) + and then Universal.Option_Types.Has_Buffer (Seq_Ctx) + and then Ctx.Buffer_First = Seq_Ctx.Buffer_First + and then Ctx.Buffer_Last = Seq_Ctx.Buffer_Last + and then Seq_Ctx.First = Field_First (Ctx, F_Option_Types) + and then Seq_Ctx.Last = Field_Last (Ctx, F_Option_Types), + Post => + Present (Ctx, F_Option_Types) + and Has_Buffer (Ctx) + and not Universal.Option_Types.Has_Buffer (Seq_Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Seq_Ctx.First = Seq_Ctx.First'Old + and Seq_Ctx.Last = Seq_Ctx.Last'Old + and Field_First (Ctx, F_Option_Types) = Field_First (Ctx, F_Option_Types)'Old + and Field_Size (Ctx, F_Option_Types) = Field_Size (Ctx, F_Option_Types)'Old + and Context_Cursor (Ctx, F_Message_Type) = Context_Cursor (Ctx, F_Message_Type)'Old + and Context_Cursor (Ctx, F_Length) = Context_Cursor (Ctx, F_Length)'Old + and Context_Cursor (Ctx, F_Data) = Context_Cursor (Ctx, F_Data)'Old + and Context_Cursor (Ctx, F_Options) = Context_Cursor (Ctx, F_Options)'Old + and Context_Cursor (Ctx, F_Value) = Context_Cursor (Ctx, F_Value)'Old + and Context_Cursor (Ctx, F_Values) = Context_Cursor (Ctx, F_Values)'Old, + Depends => + (Ctx => (Ctx, Seq_Ctx), Seq_Ctx => Seq_Ctx); + + procedure Update_Options (Ctx : in out Context; Seq_Ctx : in out Universal.Options.Context) with + Pre => + Present (Ctx, F_Options) + and then Complete_Options (Ctx, Seq_Ctx) + and then not Has_Buffer (Ctx) + and then Universal.Options.Has_Buffer (Seq_Ctx) + and then Ctx.Buffer_First = Seq_Ctx.Buffer_First + and then Ctx.Buffer_Last = Seq_Ctx.Buffer_Last + and then Seq_Ctx.First = Field_First (Ctx, F_Options) + and then Seq_Ctx.Last = Field_Last (Ctx, F_Options), + Post => + Present (Ctx, F_Options) + and Has_Buffer (Ctx) + and not Universal.Options.Has_Buffer (Seq_Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Seq_Ctx.First = Seq_Ctx.First'Old + and Seq_Ctx.Last = Seq_Ctx.Last'Old + and Field_First (Ctx, F_Options) = Field_First (Ctx, F_Options)'Old + and Field_Size (Ctx, F_Options) = Field_Size (Ctx, F_Options)'Old + and Context_Cursor (Ctx, F_Message_Type) = Context_Cursor (Ctx, F_Message_Type)'Old + and Context_Cursor (Ctx, F_Length) = Context_Cursor (Ctx, F_Length)'Old + and Context_Cursor (Ctx, F_Data) = Context_Cursor (Ctx, F_Data)'Old + and Context_Cursor (Ctx, F_Option_Types) = Context_Cursor (Ctx, F_Option_Types)'Old + and Context_Cursor (Ctx, F_Value) = Context_Cursor (Ctx, F_Value)'Old + and Context_Cursor (Ctx, F_Values) = Context_Cursor (Ctx, F_Values)'Old, + Depends => + (Ctx => (Ctx, Seq_Ctx), Seq_Ctx => Seq_Ctx); + + procedure Update_Values (Ctx : in out Context; Seq_Ctx : in out Universal.Values.Context) with + Pre => + Present (Ctx, F_Values) + and then Complete_Values (Ctx, Seq_Ctx) + and then not Has_Buffer (Ctx) + and then Universal.Values.Has_Buffer (Seq_Ctx) + and then Ctx.Buffer_First = Seq_Ctx.Buffer_First + and then Ctx.Buffer_Last = Seq_Ctx.Buffer_Last + and then Seq_Ctx.First = Field_First (Ctx, F_Values) + and then Seq_Ctx.Last = Field_Last (Ctx, F_Values), + Post => + Present (Ctx, F_Values) + and Has_Buffer (Ctx) + and not Universal.Values.Has_Buffer (Seq_Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Seq_Ctx.First = Seq_Ctx.First'Old + and Seq_Ctx.Last = Seq_Ctx.Last'Old + and Field_First (Ctx, F_Values) = Field_First (Ctx, F_Values)'Old + and Field_Size (Ctx, F_Values) = Field_Size (Ctx, F_Values)'Old + and Context_Cursor (Ctx, F_Message_Type) = Context_Cursor (Ctx, F_Message_Type)'Old + and Context_Cursor (Ctx, F_Length) = Context_Cursor (Ctx, F_Length)'Old + and Context_Cursor (Ctx, F_Data) = Context_Cursor (Ctx, F_Data)'Old + and Context_Cursor (Ctx, F_Option_Types) = Context_Cursor (Ctx, F_Option_Types)'Old + and Context_Cursor (Ctx, F_Options) = Context_Cursor (Ctx, F_Options)'Old + and Context_Cursor (Ctx, F_Value) = Context_Cursor (Ctx, F_Value)'Old, + Depends => + (Ctx => (Ctx, Seq_Ctx), Seq_Ctx => Seq_Ctx); + + function Context_Cursor (Ctx : Context; Fld : Field) return Field_Cursor with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + + function Context_Cursors (Ctx : Context) return Field_Cursors with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + + function Context_Cursors_Index (Cursors : Field_Cursors; Fld : Field) return Field_Cursor with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + +private + + type Cursor_State is (S_Valid, S_Structural_Valid, S_Invalid, S_Incomplete); + + type Field_Cursor (State : Cursor_State := S_Invalid) is + record + Predecessor : Virtual_Field := F_Final; + case State is + when S_Valid | S_Structural_Valid => + First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; + Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First; + Value : RFLX_Types.U64 := 0; + when S_Invalid | S_Incomplete => + null; + end case; + end record; + + type Field_Cursors is array (Virtual_Field) of Field_Cursor; + + function Structural_Valid (Cursor : Field_Cursor) return Boolean is + (Cursor.State = S_Valid + or Cursor.State = S_Structural_Valid); + + function Valid (Cursor : Field_Cursor) return Boolean is + (Cursor.State = S_Valid); + + function Invalid (Cursor : Field_Cursor) return Boolean is + (Cursor.State = S_Invalid + or Cursor.State = S_Incomplete); + + pragma Warnings (Off, """Buffer"" is not modified, could be of access constant type"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Context (Buffer_First, Buffer_Last : RFLX_Types.Index; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Verified_Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length; Buffer : RFLX_Types.Bytes_Ptr; Cursors : Field_Cursors) return Boolean is + ((if Buffer /= null then Buffer'First = Buffer_First and Buffer'Last = Buffer_Last) + and then (RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last < RFLX_Types.Bit_Index'Last + and First rem RFLX_Types.Byte'Size = 1 + and Last rem RFLX_Types.Byte'Size = 0) + and then First - 1 <= Verified_Last + and then First - 1 <= Written_Last + and then Verified_Last <= Written_Last + and then Written_Last <= Last + and then First rem RFLX_Types.Byte'Size = 1 + and then Last rem RFLX_Types.Byte'Size = 0 + and then Verified_Last rem RFLX_Types.Byte'Size = 0 + and then Written_Last rem RFLX_Types.Byte'Size = 0 + and then (for all F in Field => + (if + Structural_Valid (Cursors (F)) + then + Cursors (F).First >= First + and Cursors (F).Last <= Verified_Last + and Cursors (F).First <= Cursors (F).Last + 1 + and Valid_Value (F, Cursors (F).Value))) + and then ((if + Structural_Valid (Cursors (F_Length)) + then + (Valid (Cursors (F_Message_Type)) + and then Cursors (F_Length).Predecessor = F_Message_Type + and then (RFLX_Types.U64 (Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data))))) + and then (if + Structural_Valid (Cursors (F_Data)) + then + (Valid (Cursors (F_Length)) + and then Cursors (F_Data).Predecessor = F_Length + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data))) + or (Valid (Cursors (F_Message_Type)) + and then Cursors (F_Data).Predecessor = F_Message_Type + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)))) + and then (if + Structural_Valid (Cursors (F_Option_Types)) + then + (Valid (Cursors (F_Length)) + and then Cursors (F_Option_Types).Predecessor = F_Length + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)))) + and then (if + Structural_Valid (Cursors (F_Options)) + then + (Valid (Cursors (F_Length)) + and then Cursors (F_Options).Predecessor = F_Length + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options))) + or (Valid (Cursors (F_Message_Type)) + and then Cursors (F_Options).Predecessor = F_Message_Type + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)))) + and then (if + Structural_Valid (Cursors (F_Value)) + then + (Valid (Cursors (F_Length)) + and then Cursors (F_Value).Predecessor = F_Length + and then (RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Cursors (F_Length).Value) = Universal.Value'Size / 8))) + and then (if + Structural_Valid (Cursors (F_Values)) + then + (Valid (Cursors (F_Length)) + and then Cursors (F_Values).Predecessor = F_Length + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values))))) + and then ((if Invalid (Cursors (F_Message_Type)) then Invalid (Cursors (F_Length))) + and then (if + Invalid (Cursors (F_Length)) + and then Invalid (Cursors (F_Message_Type)) + then + Invalid (Cursors (F_Data))) + and then (if Invalid (Cursors (F_Length)) then Invalid (Cursors (F_Option_Types))) + and then (if + Invalid (Cursors (F_Length)) + and then Invalid (Cursors (F_Message_Type)) + then + Invalid (Cursors (F_Options))) + and then (if Invalid (Cursors (F_Length)) then Invalid (Cursors (F_Value))) + and then (if Invalid (Cursors (F_Length)) then Invalid (Cursors (F_Values)))) + and then (if + Structural_Valid (Cursors (F_Message_Type)) + then + Cursors (F_Message_Type).Last - Cursors (F_Message_Type).First + 1 = 8 + and then Cursors (F_Message_Type).Predecessor = F_Initial + and then Cursors (F_Message_Type).First = First + and then (if + Structural_Valid (Cursors (F_Data)) + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Cursors (F_Data).Last - Cursors (F_Data).First + 1 = RFLX_Types.Bit_Length (Written_Last) - RFLX_Types.Bit_Length (Cursors (F_Message_Type).Last) + and then Cursors (F_Data).Predecessor = F_Message_Type + and then Cursors (F_Data).First = Cursors (F_Message_Type).Last + 1) + and then (if + Structural_Valid (Cursors (F_Length)) + and then (RFLX_Types.U64 (Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data))) + then + Cursors (F_Length).Last - Cursors (F_Length).First + 1 = 16 + and then Cursors (F_Length).Predecessor = F_Message_Type + and then Cursors (F_Length).First = Cursors (F_Message_Type).Last + 1 + and then (if + Structural_Valid (Cursors (F_Data)) + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)) + then + Cursors (F_Data).Last - Cursors (F_Data).First + 1 = RFLX_Types.Bit_Length (Cursors (F_Length).Value) * 8 + and then Cursors (F_Data).Predecessor = F_Length + and then Cursors (F_Data).First = Cursors (F_Length).Last + 1) + and then (if + Structural_Valid (Cursors (F_Option_Types)) + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)) + then + Cursors (F_Option_Types).Last - Cursors (F_Option_Types).First + 1 = RFLX_Types.Bit_Length (Cursors (F_Length).Value) * 8 + and then Cursors (F_Option_Types).Predecessor = F_Length + and then Cursors (F_Option_Types).First = Cursors (F_Length).Last + 1) + and then (if + Structural_Valid (Cursors (F_Options)) + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)) + then + Cursors (F_Options).Last - Cursors (F_Options).First + 1 = RFLX_Types.Bit_Length (Cursors (F_Length).Value) * 8 + and then Cursors (F_Options).Predecessor = F_Length + and then Cursors (F_Options).First = Cursors (F_Length).Last + 1) + and then (if + Structural_Valid (Cursors (F_Value)) + and then (RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Cursors (F_Length).Value) = Universal.Value'Size / 8) + then + Cursors (F_Value).Last - Cursors (F_Value).First + 1 = 8 + and then Cursors (F_Value).Predecessor = F_Length + and then Cursors (F_Value).First = Cursors (F_Length).Last + 1) + and then (if + Structural_Valid (Cursors (F_Values)) + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)) + then + Cursors (F_Values).Last - Cursors (F_Values).First + 1 = RFLX_Types.Bit_Length (Cursors (F_Length).Value) * 8 + and then Cursors (F_Values).Predecessor = F_Length + and then Cursors (F_Values).First = Cursors (F_Length).Last + 1)) + and then (if + Structural_Valid (Cursors (F_Options)) + and then RFLX_Types.U64 (Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + Cursors (F_Options).Last - Cursors (F_Options).First + 1 = RFLX_Types.Bit_Length (Written_Last) - RFLX_Types.Bit_Length (Cursors (F_Message_Type).Last) + and then Cursors (F_Options).Predecessor = F_Message_Type + and then Cursors (F_Options).First = Cursors (F_Message_Type).Last + 1))); + + pragma Warnings (On, """Buffer"" is not modified, could be of access constant type"); + + pragma Warnings (On, "postcondition does not mention function result"); + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is + record + Verified_Last : RFLX_Types.Bit_Length := First - 1; + Written_Last : RFLX_Types.Bit_Length := First - 1; + Buffer : RFLX_Types.Bytes_Ptr := null; + Cursors : Field_Cursors := (others => (State => S_Invalid, Predecessor => F_Final)); + end record with + Dynamic_Predicate => + Valid_Context (Context.Buffer_First, Context.Buffer_Last, Context.First, Context.Last, Context.Verified_Last, Context.Written_Last, Context.Buffer, Context.Cursors); + + function Initialized (Ctx : Context) return Boolean is + (Ctx.Verified_Last = Ctx.First - 1 + and then Valid_Next (Ctx, F_Message_Type) + and then Field_First (Ctx, F_Message_Type) rem RFLX_Types.Byte'Size = 1 + and then Available_Space (Ctx, F_Message_Type) = Ctx.Last - Ctx.First + 1 + and then (for all F in Field => + Invalid (Ctx, F))); + + function Has_Buffer (Ctx : Context) return Boolean is + (Ctx.Buffer /= null); + + function Buffer_Length (Ctx : Context) return RFLX_Types.Length is + (Ctx.Buffer'Length); + + function Size (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Verified_Last - Ctx.First + 1); + + function Byte_Size (Ctx : Context) return RFLX_Types.Length is + (RFLX_Types.To_Length (Size (Ctx))); + + function Message_Last (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Verified_Last); + + function Written_Last (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Written_Last); + + function Valid_Value (Fld : Field; Val : RFLX_Types.U64) return Boolean is + ((case Fld is + when F_Message_Type => + RFLX.Universal.Valid_Message_Type (Val), + when F_Length => + RFLX.Universal.Valid_Length (Val), + when F_Data | F_Option_Types | F_Options => + True, + when F_Value => + RFLX.Universal.Valid_Value (Val), + when F_Values => + True)); + + function Path_Condition (Ctx : Context; Fld : Field) return Boolean is + ((case Ctx.Cursors (Fld).Predecessor is + when F_Initial | F_Data | F_Option_Types | F_Options | F_Value | F_Values | F_Final => + True, + when F_Message_Type => + (case Fld is + when F_Data => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)), + when F_Length => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)), + when F_Options => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)), + when others => + False), + when F_Length => + (case Fld is + when F_Data => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)), + when F_Option_Types => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)), + when F_Options => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)), + when F_Value => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and RFLX_Types.U64 (Ctx.Cursors (F_Length).Value) = Universal.Value'Size / 8, + when F_Values => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)), + when others => + False))); + + function Field_Condition (Ctx : Context; Fld : Field; Val : RFLX_Types.U64) return Boolean is + ((case Fld is + when F_Message_Type => + Val = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + or Val = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + or (Val /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + and Val /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null)) + and Val /= RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Data))) + or Val = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Unconstrained_Options)), + when F_Length => + RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Data)) + or RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Option_Types)) + or RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Options)) + or (RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Value)) + and Val = Universal.Value'Size / 8) + or RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Values)), + when F_Data | F_Option_Types | F_Options | F_Value | F_Values => + True)); + + function Field_Size (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length is + ((case Fld is + when F_Message_Type => + 8, + when F_Length => + 16, + when F_Data => + (if + Ctx.Cursors (Fld).Predecessor = F_Length + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Data)) + then + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8 + elsif + Ctx.Cursors (Fld).Predecessor = F_Message_Type + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + RFLX_Types.Bit_Length (Ctx.Written_Last) - RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Last) + else + RFLX_Types.Unreachable), + when F_Option_Types => + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8, + when F_Options => + (if + Ctx.Cursors (Fld).Predecessor = F_Length + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Options)) + then + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8 + elsif + Ctx.Cursors (Fld).Predecessor = F_Message_Type + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + RFLX_Types.Bit_Length (Ctx.Written_Last) - RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Last) + else + RFLX_Types.Unreachable), + when F_Value => + 8, + when F_Values => + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8)); + + function Field_First (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Index is + ((if Fld = F_Message_Type then Ctx.First else Ctx.Cursors (Ctx.Cursors (Fld).Predecessor).Last + 1)); + + function Field_Last (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length is + (Field_First (Ctx, Fld) + Field_Size (Ctx, Fld) - 1); + + function Predecessor (Ctx : Context; Fld : Virtual_Field) return Virtual_Field is + ((case Fld is + when F_Initial => + F_Initial, + when others => + Ctx.Cursors (Fld).Predecessor)); + + function Valid_Predecessor (Ctx : Context; Fld : Virtual_Field) return Boolean is + ((case Fld is + when F_Initial => + True, + when F_Message_Type => + Ctx.Cursors (Fld).Predecessor = F_Initial, + when F_Length => + (Valid (Ctx.Cursors (F_Message_Type)) + and Ctx.Cursors (Fld).Predecessor = F_Message_Type), + when F_Data => + (Valid (Ctx.Cursors (F_Length)) + and Ctx.Cursors (Fld).Predecessor = F_Length) + or (Valid (Ctx.Cursors (F_Message_Type)) + and Ctx.Cursors (Fld).Predecessor = F_Message_Type), + when F_Option_Types => + (Valid (Ctx.Cursors (F_Length)) + and Ctx.Cursors (Fld).Predecessor = F_Length), + when F_Options => + (Valid (Ctx.Cursors (F_Length)) + and Ctx.Cursors (Fld).Predecessor = F_Length) + or (Valid (Ctx.Cursors (F_Message_Type)) + and Ctx.Cursors (Fld).Predecessor = F_Message_Type), + when F_Value | F_Values => + (Valid (Ctx.Cursors (F_Length)) + and Ctx.Cursors (Fld).Predecessor = F_Length), + when F_Final => + (Structural_Valid (Ctx.Cursors (F_Data)) + and Ctx.Cursors (Fld).Predecessor = F_Data) + or (Valid (Ctx.Cursors (F_Message_Type)) + and Ctx.Cursors (Fld).Predecessor = F_Message_Type) + or (Structural_Valid (Ctx.Cursors (F_Option_Types)) + and Ctx.Cursors (Fld).Predecessor = F_Option_Types) + or (Structural_Valid (Ctx.Cursors (F_Options)) + and Ctx.Cursors (Fld).Predecessor = F_Options) + or (Valid (Ctx.Cursors (F_Value)) + and Ctx.Cursors (Fld).Predecessor = F_Value) + or (Structural_Valid (Ctx.Cursors (F_Values)) + and Ctx.Cursors (Fld).Predecessor = F_Values))); + + function Valid_Next (Ctx : Context; Fld : Field) return Boolean is + (Valid_Predecessor (Ctx, Fld) + and then Path_Condition (Ctx, Fld)); + + function Available_Space (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length is + (Ctx.Last - Field_First (Ctx, Fld) + 1); + + function Present (Ctx : Context; Fld : Field) return Boolean is + (Structural_Valid (Ctx.Cursors (Fld)) + and then Ctx.Cursors (Fld).First < Ctx.Cursors (Fld).Last + 1); + + function Structural_Valid (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Valid + or Ctx.Cursors (Fld).State = S_Structural_Valid); + + function Valid (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Valid + and then Ctx.Cursors (Fld).First < Ctx.Cursors (Fld).Last + 1); + + function Incomplete (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Incomplete); + + function Invalid (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Invalid + or Ctx.Cursors (Fld).State = S_Incomplete); + + function Structural_Valid_Message (Ctx : Context) return Boolean is + (Structural_Valid (Ctx, F_Data) + or (Valid (Ctx, F_Message_Type) + and then RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null))) + or Structural_Valid (Ctx, F_Option_Types) + or Structural_Valid (Ctx, F_Options) + or Valid (Ctx, F_Value) + or Structural_Valid (Ctx, F_Values)); + + function Valid_Message (Ctx : Context) return Boolean is + (Valid (Ctx, F_Data) + or (Valid (Ctx, F_Message_Type) + and then RFLX_Types.U64 (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.MT_Null))) + or Valid (Ctx, F_Option_Types) + or Valid (Ctx, F_Options) + or Valid (Ctx, F_Value) + or Valid (Ctx, F_Values)); + + function Incomplete_Message (Ctx : Context) return Boolean is + ((for some F in Field => + Incomplete (Ctx, F))); + + function Get_Message_Type (Ctx : Context) return RFLX.Universal.Message_Type is + (To_Actual (Ctx.Cursors (F_Message_Type).Value)); + + function Get_Length (Ctx : Context) return RFLX.Universal.Length is + (To_Actual (Ctx.Cursors (F_Length).Value)); + + function Get_Value (Ctx : Context) return RFLX.Universal.Value is + (To_Actual (Ctx.Cursors (F_Value).Value)); + + function Valid_Size (Ctx : Context; Fld : Field; Size : RFLX_Types.Bit_Length) return Boolean is + ((if + Fld = F_Data + and then Ctx.Cursors (Fld).Predecessor = F_Message_Type + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Unconstrained_Data)) + then + Size <= Available_Space (Ctx, Fld) + elsif + Fld = F_Options + and then Ctx.Cursors (Fld).Predecessor = F_Message_Type + and then RFLX_Types.Bit_Length (Ctx.Cursors (F_Message_Type).Value) = RFLX_Types.Bit_Length (To_U64 (RFLX.Universal.MT_Unconstrained_Options)) + then + Size <= Available_Space (Ctx, Fld) + else + Size = Field_Size (Ctx, Fld))) + with + Pre => + Valid_Next (Ctx, Fld); + + function Valid_Length (Ctx : Context; Fld : Field; Length : RFLX_Types.Length) return Boolean is + (Valid_Size (Ctx, Fld, RFLX_Types.To_Bit_Length (Length))); + + function Complete_Option_Types (Ctx : Context; Seq_Ctx : Universal.Option_Types.Context) return Boolean is + (Universal.Option_Types.Valid (Seq_Ctx) + and Universal.Option_Types.Size (Seq_Ctx) = Field_Size (Ctx, F_Option_Types)); + + function Complete_Options (Ctx : Context; Seq_Ctx : Universal.Options.Context) return Boolean is + (Universal.Options.Valid (Seq_Ctx) + and Universal.Options.Size (Seq_Ctx) = Field_Size (Ctx, F_Options)); + + function Complete_Values (Ctx : Context; Seq_Ctx : Universal.Values.Context) return Boolean is + (Universal.Values.Valid (Seq_Ctx) + and Universal.Values.Size (Seq_Ctx) = Field_Size (Ctx, F_Values)); + + function Context_Cursor (Ctx : Context; Fld : Field) return Field_Cursor is + (Ctx.Cursors (Fld)); + + function Context_Cursors (Ctx : Context) return Field_Cursors is + (Ctx.Cursors); + + function Context_Cursors_Index (Cursors : Field_Cursors; Fld : Field) return Field_Cursor is + (Cursors (Fld)); + +end RFLX.Universal.Message; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.adb b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.adb new file mode 100644 index 0000000000..a63c9a0343 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.adb @@ -0,0 +1,447 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); + +package body RFLX.Universal.Option with + SPARK_Mode +is + + pragma Unevaluated_Use_Of_Old (Allow); + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; Written_Last : RFLX_Types.Bit_Length := 0) is + begin + Initialize (Ctx, Buffer, RFLX_Types.To_First_Bit_Index (Buffer'First), RFLX_Types.To_Last_Bit_Index (Buffer'Last), Written_Last); + end Initialize; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length := 0) is + Buffer_First : constant RFLX_Types.Index := Buffer'First; + Buffer_Last : constant RFLX_Types.Index := Buffer'Last; + begin + Ctx := (Buffer_First, Buffer_Last, First, Last, First - 1, (if Written_Last = 0 then First - 1 else Written_Last), Buffer, (F_Option_Type => (State => S_Invalid, Predecessor => F_Initial), others => (State => S_Invalid, Predecessor => F_Final))); + Buffer := null; + end Initialize; + + procedure Reset (Ctx : in out Context) is + begin + Reset (Ctx, RFLX_Types.To_First_Bit_Index (Ctx.Buffer'First), RFLX_Types.To_Last_Bit_Index (Ctx.Buffer'Last)); + end Reset; + + procedure Reset (Ctx : in out Context; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) is + begin + Ctx := (Ctx.Buffer_First, Ctx.Buffer_Last, First, Last, First - 1, First - 1, Ctx.Buffer, (F_Option_Type => (State => S_Invalid, Predecessor => F_Initial), others => (State => S_Invalid, Predecessor => F_Final))); + end Reset; + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) is + begin + Buffer := Ctx.Buffer; + Ctx.Buffer := null; + end Take_Buffer; + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) is + begin + if Buffer'Length > 0 then + Buffer := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last)); + else + Buffer := Ctx.Buffer.all (1 .. 0); + end if; + end Copy; + + function Read (Ctx : Context) return RFLX_Types.Bytes is + (Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last))); + + procedure Generic_Read (Ctx : Context) is + begin + Read (Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last))); + end Generic_Read; + + procedure Generic_Write (Ctx : in out Context; Offset : RFLX_Types.Length := 0) is + Length : RFLX_Types.Length; + begin + Reset (Ctx, RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First), RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last)); + Write (Ctx.Buffer.all (Ctx.Buffer'First + RFLX_Types.Index (Offset + 1) - 1 .. Ctx.Buffer'Last), Length, Ctx.Buffer'Length, Offset); + pragma Assert (Length <= Ctx.Buffer.all'Length, "Length <= Buffer'Length is not ensured by postcondition of ""Write"""); + Ctx.Written_Last := RFLX_Types.Bit_Index'Max (Ctx.Written_Last, RFLX_Types.To_Last_Bit_Index (RFLX_Types.Length (Ctx.Buffer_First) + Offset + Length - 1)); + end Generic_Write; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) is + begin + Data := Ctx.Buffer.all (RFLX_Types.To_Index (Ctx.First) .. RFLX_Types.To_Index (Ctx.Verified_Last)); + end Data; + + pragma Warnings (Off, "precondition is always False"); + + function Successor (Ctx : Context; Fld : Field) return Virtual_Field is + ((case Fld is + when F_Option_Type => + (if + RFLX_Types.U64 (Ctx.Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Null)) + then + F_Final + elsif + RFLX_Types.U64 (Ctx.Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)) + then + F_Length + else + F_Initial), + when F_Length => + F_Data, + when F_Data => + F_Final)) + with + Pre => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, Fld) + and Valid_Predecessor (Ctx, Fld); + + pragma Warnings (On, "precondition is always False"); + + function Invalid_Successor (Ctx : Context; Fld : Field) return Boolean is + ((case Fld is + when F_Option_Type => + Invalid (Ctx.Cursors (F_Length)), + when F_Length => + Invalid (Ctx.Cursors (F_Data)), + when F_Data => + True)); + + function Sufficient_Buffer_Length (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Buffer /= null + and Field_First (Ctx, Fld) + Field_Size (Ctx, Fld) < RFLX_Types.Bit_Length'Last + and Ctx.First <= Field_First (Ctx, Fld) + and Field_First (Ctx, Fld) + Field_Size (Ctx, Fld) - 1 <= Ctx.Written_Last) + with + Pre => + Has_Buffer (Ctx) + and Valid_Next (Ctx, Fld); + + function Equal (Ctx : Context; Fld : Field; Data : RFLX_Types.Bytes) return Boolean is + (Sufficient_Buffer_Length (Ctx, Fld) + and then (case Fld is + when F_Data => + Ctx.Buffer.all (RFLX_Types.To_Index (Field_First (Ctx, Fld)) .. RFLX_Types.To_Index (Field_Last (Ctx, Fld))) = Data, + when others => + False)); + + procedure Reset_Dependent_Fields (Ctx : in out Context; Fld : Field) with + Pre => + Valid_Next (Ctx, Fld), + Post => + Valid_Next (Ctx, Fld) + and Invalid (Ctx.Cursors (Fld)) + and Invalid_Successor (Ctx, Fld) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Ctx.Cursors (Fld).Predecessor = Ctx.Cursors (Fld).Predecessor'Old + and Has_Buffer (Ctx) = Has_Buffer (Ctx)'Old + and Field_First (Ctx, Fld) = Field_First (Ctx, Fld)'Old + and Field_Size (Ctx, Fld) = Field_Size (Ctx, Fld)'Old + and (for all F in Field => + (if F < Fld then Ctx.Cursors (F) = Ctx.Cursors'Old (F) else Invalid (Ctx, F))) + is + First : constant RFLX_Types.Bit_Length := Field_First (Ctx, Fld) with + Ghost; + Size : constant RFLX_Types.Bit_Length := Field_Size (Ctx, Fld) with + Ghost; + begin + pragma Assert (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + for Fld_Loop in reverse Field'Succ (Fld) .. Field'Last loop + Ctx.Cursors (Fld_Loop) := (S_Invalid, F_Final); + pragma Loop_Invariant (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + pragma Loop_Invariant ((for all F in Field => + (if F < Fld_Loop then Ctx.Cursors (F) = Ctx.Cursors'Loop_Entry (F) else Invalid (Ctx, F)))); + end loop; + pragma Assert (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + Ctx.Cursors (Fld) := (S_Invalid, Ctx.Cursors (Fld).Predecessor); + pragma Assert (Field_First (Ctx, Fld) = First + and Field_Size (Ctx, Fld) = Size); + end Reset_Dependent_Fields; + + function Composite_Field (Fld : Field) return Boolean is + (Fld in F_Data); + + function Get (Ctx : Context; Fld : Field) return RFLX_Types.U64 with + Pre => + Has_Buffer (Ctx) + and then Valid_Next (Ctx, Fld) + and then Sufficient_Buffer_Length (Ctx, Fld) + and then not Composite_Field (Fld) + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, Fld); + Last : constant RFLX_Types.Bit_Index := Field_Last (Ctx, Fld); + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (First); + Buffer_Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Last); + Offset : constant RFLX_Types.Offset := RFLX_Types.Offset ((RFLX_Types.Byte'Size - Last mod RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size); + Size : constant Positive := (case Fld is + when F_Option_Type => + 8, + when F_Length => + 16, + when others => + Positive'Last); + Byte_Order : constant RFLX_Types.Byte_Order := RFLX_Types.High_Order_First; + begin + return RFLX_Types.Extract (Ctx.Buffer, Buffer_First, Buffer_Last, Offset, Size, Byte_Order); + end Get; + + procedure Verify (Ctx : in out Context; Fld : Field) is + Value : RFLX_Types.U64; + begin + if + Invalid (Ctx.Cursors (Fld)) + and then Valid_Predecessor (Ctx, Fld) + and then Path_Condition (Ctx, Fld) + then + if Sufficient_Buffer_Length (Ctx, Fld) then + Value := (if Composite_Field (Fld) then 0 else Get (Ctx, Fld)); + if + Valid_Value (Fld, Value) + and then Field_Condition (Ctx, Fld, Value) + then + pragma Assert ((if Fld = F_Data or Fld = F_Option_Type then Field_Last (Ctx, Fld) mod RFLX_Types.Byte'Size = 0)); + pragma Assert ((((Field_Last (Ctx, Fld) + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size = 0); + Ctx.Verified_Last := ((Field_Last (Ctx, Fld) + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size; + pragma Assert (Field_Last (Ctx, Fld) <= Ctx.Verified_Last); + if Composite_Field (Fld) then + Ctx.Cursors (Fld) := (State => S_Structural_Valid, First => Field_First (Ctx, Fld), Last => Field_Last (Ctx, Fld), Value => Value, Predecessor => Ctx.Cursors (Fld).Predecessor); + else + Ctx.Cursors (Fld) := (State => S_Valid, First => Field_First (Ctx, Fld), Last => Field_Last (Ctx, Fld), Value => Value, Predecessor => Ctx.Cursors (Fld).Predecessor); + end if; + Ctx.Cursors (Successor (Ctx, Fld)) := (State => S_Invalid, Predecessor => Fld); + else + Ctx.Cursors (Fld) := (State => S_Invalid, Predecessor => F_Final); + end if; + else + Ctx.Cursors (Fld) := (State => S_Incomplete, Predecessor => F_Final); + end if; + end if; + end Verify; + + procedure Verify_Message (Ctx : in out Context) is + begin + for F in Field loop + Verify (Ctx, F); + end loop; + end Verify_Message; + + function Get_Data (Ctx : Context) return RFLX_Types.Bytes is + First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).First); + Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).Last); + begin + return Ctx.Buffer.all (First .. Last); + end Get_Data; + + procedure Get_Data (Ctx : Context; Data : out RFLX_Types.Bytes) is + First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).First); + Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).Last); + begin + Data := (others => RFLX_Types.Byte'First); + Data (Data'First .. Data'First + (Last - First)) := Ctx.Buffer.all (First .. Last); + end Get_Data; + + procedure Generic_Get_Data (Ctx : Context) is + First : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).First); + Last : constant RFLX_Types.Index := RFLX_Types.To_Index (Ctx.Cursors (F_Data).Last); + begin + Process_Data (Ctx.Buffer.all (First .. Last)); + end Generic_Get_Data; + + procedure Set (Ctx : in out Context; Fld : Field; Val : RFLX_Types.U64; Size : RFLX_Types.Bit_Length; State_Valid : Boolean; Buffer_First : out RFLX_Types.Index; Buffer_Last : out RFLX_Types.Index; Offset : out RFLX_Types.Offset) with + Pre => + Has_Buffer (Ctx) + and then Valid_Next (Ctx, Fld) + and then Valid_Value (Fld, Val) + and then Valid_Size (Ctx, Fld, Size) + and then Size <= Available_Space (Ctx, Fld) + and then (if Composite_Field (Fld) then Size mod RFLX_Types.Byte'Size = 0 else State_Valid), + Post => + Valid_Next (Ctx, Fld) + and then Invalid_Successor (Ctx, Fld) + and then Buffer_First = RFLX_Types.To_Index (Field_First (Ctx, Fld)) + and then Buffer_Last = RFLX_Types.To_Index (Field_First (Ctx, Fld) + Size - 1) + and then Offset = RFLX_Types.Offset ((RFLX_Types.Byte'Size - (Field_First (Ctx, Fld) + Size - 1) mod RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size) + and then Ctx.Buffer_First = Ctx.Buffer_First'Old + and then Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and then Ctx.First = Ctx.First'Old + and then Ctx.Last = Ctx.Last'Old + and then Ctx.Buffer_First = Ctx.Buffer_First'Old + and then Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and then Ctx.First = Ctx.First'Old + and then Ctx.Last = Ctx.Last'Old + and then Has_Buffer (Ctx) = Has_Buffer (Ctx)'Old + and then Predecessor (Ctx, Fld) = Predecessor (Ctx, Fld)'Old + and then Field_First (Ctx, Fld) = Field_First (Ctx, Fld)'Old + and then Available_Space (Ctx, Fld) >= Field_Size (Ctx, Fld) + and then (if State_Valid and Size > 0 then Valid (Ctx, Fld) else Structural_Valid (Ctx, Fld)) + and then (case Fld is + when F_Option_Type => + Get_Option_Type (Ctx) = To_Actual (Val) + and (if + RFLX_Types.U64 (To_U64 (Get_Option_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)) + then + Predecessor (Ctx, F_Length) = F_Option_Type + and Valid_Next (Ctx, F_Length)) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Length => + Get_Length (Ctx) = To_Actual (Val) + and (Predecessor (Ctx, F_Data) = F_Length + and Valid_Next (Ctx, F_Data)), + when F_Data => + (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld))) + and then (for all F in Field => + (if F < Fld then Ctx.Cursors (F) = Ctx.Cursors'Old (F))) + is + First : RFLX_Types.Bit_Index; + Last : RFLX_Types.Bit_Length; + begin + Reset_Dependent_Fields (Ctx, Fld); + First := Field_First (Ctx, Fld); + Last := Field_First (Ctx, Fld) + Size - 1; + Offset := RFLX_Types.Offset ((RFLX_Types.Byte'Size - Last mod RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size); + Buffer_First := RFLX_Types.To_Index (First); + Buffer_Last := RFLX_Types.To_Index (Last); + pragma Assert ((((Last + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size) mod RFLX_Types.Byte'Size = 0); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => ((Last + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size, Written_Last => ((Last + RFLX_Types.Byte'Size - 1) / RFLX_Types.Byte'Size) * RFLX_Types.Byte'Size); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + pragma Assert (Size = (case Fld is + when F_Option_Type => + 8, + when F_Length => + 16, + when F_Data => + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8)); + if State_Valid then + Ctx.Cursors (Fld) := (State => S_Valid, First => First, Last => Last, Value => Val, Predecessor => Ctx.Cursors (Fld).Predecessor); + else + Ctx.Cursors (Fld) := (State => S_Structural_Valid, First => First, Last => Last, Value => Val, Predecessor => Ctx.Cursors (Fld).Predecessor); + end if; + Ctx.Cursors (Successor (Ctx, Fld)) := (State => S_Invalid, Predecessor => Fld); + end Set; + + procedure Set_Scalar (Ctx : in out Context; Fld : Field; Val : RFLX_Types.U64) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, Fld) + and then Valid_Value (Fld, Val) + and then Valid_Size (Ctx, Fld, Field_Size (Ctx, Fld)) + and then Available_Space (Ctx, Fld) >= Field_Size (Ctx, Fld) + and then Field_Size (Ctx, Fld) in 1 .. RFLX_Types.U64'Size + and then (if Field_Size (Ctx, Fld) < RFLX_Types.U64'Size then Val < 2**Natural (Field_Size (Ctx, Fld))), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, Fld) + and Invalid_Successor (Ctx, Fld) + and (case Fld is + when F_Option_Type => + Get_Option_Type (Ctx) = To_Actual (Val) + and (if + RFLX_Types.U64 (To_U64 (Get_Option_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)) + then + Predecessor (Ctx, F_Length) = F_Option_Type + and Valid_Next (Ctx, F_Length)) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld)), + when F_Length => + Get_Length (Ctx) = To_Actual (Val) + and (Predecessor (Ctx, F_Data) = F_Length + and Valid_Next (Ctx, F_Data)), + when F_Data => + (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, Fld))) + and (for all F in Field => + (if F < Fld then Ctx.Cursors (F) = Ctx.Cursors'Old (F))) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Has_Buffer (Ctx) = Has_Buffer (Ctx)'Old + and Predecessor (Ctx, Fld) = Predecessor (Ctx, Fld)'Old + and Field_First (Ctx, Fld) = Field_First (Ctx, Fld)'Old + is + Buffer_First, Buffer_Last : RFLX_Types.Index; + Offset : RFLX_Types.Offset; + Size : constant RFLX_Types.Bit_Length := Field_Size (Ctx, Fld); + begin + Set (Ctx, Fld, Val, Size, True, Buffer_First, Buffer_Last, Offset); + RFLX_Types.Insert (Val, Ctx.Buffer, Buffer_First, Buffer_Last, Offset, Positive (Size), RFLX_Types.High_Order_First); + end Set_Scalar; + + procedure Set_Option_Type (Ctx : in out Context; Val : RFLX.Universal.Option_Type_Enum) is + begin + Set_Scalar (Ctx, F_Option_Type, To_U64 (Val)); + end Set_Option_Type; + + procedure Set_Length (Ctx : in out Context; Val : RFLX.Universal.Length) is + begin + Set_Scalar (Ctx, F_Length, To_U64 (Val)); + end Set_Length; + + procedure Set_Data_Empty (Ctx : in out Context) is + Unused_Buffer_First, Unused_Buffer_Last : RFLX_Types.Index; + Unused_Offset : RFLX_Types.Offset; + begin + Set (Ctx, F_Data, 0, 0, True, Unused_Buffer_First, Unused_Buffer_Last, Unused_Offset); + end Set_Data_Empty; + + procedure Initialize_Data_Private (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Valid_Length (Ctx, F_Data, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Data)) >= Length + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and Field_Size (Ctx, F_Data) = RFLX_Types.To_Bit_Length (Length) + and Ctx.Verified_Last = Field_Last (Ctx, F_Data) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Option_Type (Ctx) = Get_Option_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Data); + Last : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Data) + RFLX_Types.Bit_Length (Length) * RFLX_Types.Byte'Size - 1; + begin + pragma Assert (Last mod RFLX_Types.Byte'Size = 0); + Reset_Dependent_Fields (Ctx, F_Data); + pragma Warnings (Off, "attribute Update is an obsolescent feature"); + Ctx := Ctx'Update (Verified_Last => Last, Written_Last => Last); + pragma Warnings (On, "attribute Update is an obsolescent feature"); + Ctx.Cursors (F_Data) := (State => S_Structural_Valid, First => First, Last => Last, Value => 0, Predecessor => Ctx.Cursors (F_Data).Predecessor); + Ctx.Cursors (Successor (Ctx, F_Data)) := (State => S_Invalid, Predecessor => F_Data); + end Initialize_Data_Private; + + procedure Initialize_Data (Ctx : in out Context) is + begin + Initialize_Data_Private (Ctx, RFLX_Types.To_Length (Field_Size (Ctx, F_Data))); + end Initialize_Data; + + procedure Set_Data (Ctx : in out Context; Data : RFLX_Types.Bytes) is + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (Field_First (Ctx, F_Data)); + Buffer_Last : constant RFLX_Types.Index := Buffer_First + Data'Length - 1; + begin + Initialize_Data_Private (Ctx, Data'Length); + pragma Assert (Buffer_Last = RFLX_Types.To_Index (Field_Last (Ctx, F_Data))); + Ctx.Buffer.all (Buffer_First .. Buffer_Last) := Data; + pragma Assert (Ctx.Buffer.all (RFLX_Types.To_Index (Field_First (Ctx, F_Data)) .. RFLX_Types.To_Index (Field_Last (Ctx, F_Data))) = Data); + end Set_Data; + + procedure Generic_Set_Data (Ctx : in out Context; Length : RFLX_Types.Length) is + First : constant RFLX_Types.Bit_Index := Field_First (Ctx, F_Data); + Buffer_First : constant RFLX_Types.Index := RFLX_Types.To_Index (First); + Buffer_Last : constant RFLX_Types.Index := RFLX_Types.To_Index (First + RFLX_Types.To_Bit_Length (Length) - 1); + begin + Process_Data (Ctx.Buffer.all (Buffer_First .. Buffer_Last)); + Initialize_Data_Private (Ctx, Length); + end Generic_Set_Data; + +end RFLX.Universal.Option; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.ads new file mode 100644 index 0000000000..f6dd3d473c --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option.ads @@ -0,0 +1,856 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +with RFLX.RFLX_Types; + +package RFLX.Universal.Option with + SPARK_Mode, + Annotate => + (GNATprove, Terminating) +is + + pragma Warnings (Off, "use clause for type ""U64"" * has no effect"); + + pragma Warnings (Off, """U64"" is already use-visible through previous use_type_clause"); + + pragma Warnings (Off, """LENGTH"" is already use-visible through previous use_type_clause"); + + use type RFLX_Types.Bytes; + + use type RFLX_Types.Bytes_Ptr; + + use type RFLX_Types.Length; + + use type RFLX_Types.Index; + + use type RFLX_Types.Bit_Index; + + use type RFLX_Types.U64; + + use type RFLX_Types.Offset; + + pragma Warnings (On, """LENGTH"" is already use-visible through previous use_type_clause"); + + pragma Warnings (On, """U64"" is already use-visible through previous use_type_clause"); + + pragma Warnings (On, "use clause for type ""U64"" * has no effect"); + + pragma Unevaluated_Use_Of_Old (Allow); + + type Virtual_Field is (F_Initial, F_Option_Type, F_Length, F_Data, F_Final); + + subtype Field is Virtual_Field range F_Option_Type .. F_Data; + + type Field_Cursor is private with + Default_Initial_Condition => + False; + + type Field_Cursors is private with + Default_Initial_Condition => + False; + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is private with + Default_Initial_Condition => + RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last < RFLX_Types.Bit_Index'Last + and First rem RFLX_Types.Byte'Size = 1 + and Last rem RFLX_Types.Byte'Size = 0; + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; Written_Last : RFLX_Types.Bit_Length := 0) with + Pre => + not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last + and then (Written_Last = 0 + or (Written_Last >= RFLX_Types.To_First_Bit_Index (Buffer'First) - 1 + and Written_Last <= RFLX_Types.To_Last_Bit_Index (Buffer'Last))) + and then Written_Last mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Buffer = null + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Ctx.Last = RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last) + and Initialized (Ctx), + Depends => + (Ctx => (Buffer, Written_Last), Buffer => null); + + procedure Initialize (Ctx : out Context; Buffer : in out RFLX_Types.Bytes_Ptr; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length := 0) with + Pre => + not Ctx'Constrained + and then Buffer /= null + and then Buffer'Length > 0 + and then Buffer'Last < RFLX_Types.Index'Last + and then RFLX_Types.To_Index (First) >= Buffer'First + and then RFLX_Types.To_Index (Last) <= Buffer'Last + and then First <= Last + 1 + and then Last < RFLX_Types.Bit_Index'Last + and then First rem RFLX_Types.Byte'Size = 1 + and then Last rem RFLX_Types.Byte'Size = 0 + and then (Written_Last = 0 + or (Written_Last >= First - 1 + and Written_Last <= Last)) + and then Written_Last rem RFLX_Types.Byte'Size = 0, + Post => + Buffer = null + and Has_Buffer (Ctx) + and Ctx.Buffer_First = Buffer'First'Old + and Ctx.Buffer_Last = Buffer'Last'Old + and Ctx.First = First + and Ctx.Last = Last + and Initialized (Ctx), + Depends => + (Ctx => (Buffer, First, Last, Written_Last), Buffer => null); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Initialized (Ctx : Context) return Boolean with + Ghost, + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + procedure Reset (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and Has_Buffer (Ctx), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Ctx.Last = RFLX_Types.To_Last_Bit_Index (Ctx.Buffer_Last) + and Initialized (Ctx); + + procedure Reset (Ctx : in out Context; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length) with + Pre => + not Ctx'Constrained + and Has_Buffer (Ctx) + and RFLX_Types.To_Index (First) >= Ctx.Buffer_First + and RFLX_Types.To_Index (Last) <= Ctx.Buffer_Last + and First <= Last + 1 + and Last < RFLX_Types.Bit_Length'Last + and First rem RFLX_Types.Byte'Size = 1 + and Last rem RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = First + and Ctx.Last = Last + and Initialized (Ctx); + + procedure Take_Buffer (Ctx : in out Context; Buffer : out RFLX_Types.Bytes_Ptr) with + Pre => + Has_Buffer (Ctx), + Post => + not Has_Buffer (Ctx) + and Buffer /= null + and Ctx.Buffer_First = Buffer'First + and Ctx.Buffer_Last = Buffer'Last + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Context_Cursors (Ctx) = Context_Cursors (Ctx)'Old, + Depends => + (Ctx => Ctx, Buffer => Ctx); + + procedure Copy (Ctx : Context; Buffer : out RFLX_Types.Bytes) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx) + and then Byte_Size (Ctx) = Buffer'Length; + + function Read (Ctx : Context) return RFLX_Types.Bytes with + Ghost, + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx); + + pragma Warnings (Off, "formal parameter ""*"" is not referenced"); + + function Always_Valid (Buffer : RFLX_Types.Bytes) return Boolean is + (True); + + pragma Warnings (On, "formal parameter ""*"" is not referenced"); + + generic + with procedure Read (Buffer : RFLX_Types.Bytes); + with function Pre (Buffer : RFLX_Types.Bytes) return Boolean is Always_Valid; + procedure Generic_Read (Ctx : Context) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx) + and then Pre (Read (Ctx)); + + pragma Warnings (Off, "formal parameter ""*"" is not referenced"); + + function Always_Valid (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is + (True); + + pragma Warnings (On, "formal parameter ""*"" is not referenced"); + + generic + with procedure Write (Buffer : out RFLX_Types.Bytes; Length : out RFLX_Types.Length; Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length); + with function Pre (Context_Buffer_Length : RFLX_Types.Length; Offset : RFLX_Types.Length) return Boolean is Always_Valid; + procedure Generic_Write (Ctx : in out Context; Offset : RFLX_Types.Length := 0) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Offset < Buffer_Length (Ctx) + and then Pre (Buffer_Length (Ctx), Offset), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = RFLX_Types.To_First_Bit_Index (Ctx.Buffer_First) + and Initialized (Ctx); + + function Has_Buffer (Ctx : Context) return Boolean; + + function Buffer_Length (Ctx : Context) return RFLX_Types.Length with + Pre => + Has_Buffer (Ctx); + + function Size (Ctx : Context) return RFLX_Types.Bit_Length with + Post => + Size'Result rem RFLX_Types.Byte'Size = 0; + + function Byte_Size (Ctx : Context) return RFLX_Types.Length; + + function Message_Last (Ctx : Context) return RFLX_Types.Bit_Length with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx); + + function Written_Last (Ctx : Context) return RFLX_Types.Bit_Length; + + procedure Data (Ctx : Context; Data : out RFLX_Types.Bytes) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid_Message (Ctx) + and then Data'Length = Byte_Size (Ctx); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Value (Fld : Field; Val : RFLX_Types.U64) return Boolean with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Path_Condition (Ctx : Context; Fld : Field) return Boolean with + Pre => + Valid_Predecessor (Ctx, Fld), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Field_Condition (Ctx : Context; Fld : Field; Val : RFLX_Types.U64) return Boolean with + Pre => + Has_Buffer (Ctx) + and Valid_Predecessor (Ctx, Fld) + and Valid_Value (Fld, Val), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + function Field_Size (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length with + Pre => + Valid_Next (Ctx, Fld), + Post => + (case Fld is + when F_Data => + Field_Size'Result rem RFLX_Types.Byte'Size = 0, + when others => + True); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Field_First (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Index with + Pre => + Valid_Next (Ctx, Fld), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + function Field_Last (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length with + Pre => + Valid_Next (Ctx, Fld) + and then Available_Space (Ctx, Fld) >= Field_Size (Ctx, Fld), + Post => + (case Fld is + when F_Data => + Field_Last'Result rem RFLX_Types.Byte'Size = 0, + when others => + True); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Predecessor (Ctx : Context; Fld : Virtual_Field) return Virtual_Field with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Predecessor (Ctx : Context; Fld : Virtual_Field) return Boolean with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + function Valid_Next (Ctx : Context; Fld : Field) return Boolean; + + function Available_Space (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length with + Pre => + Valid_Next (Ctx, Fld); + + function Equal (Ctx : Context; Fld : Field; Data : RFLX_Types.Bytes) return Boolean with + Pre => + Has_Buffer (Ctx) + and Valid_Next (Ctx, Fld); + + procedure Verify (Ctx : in out Context; Fld : Field) with + Pre => + Has_Buffer (Ctx), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old; + + procedure Verify_Message (Ctx : in out Context) with + Pre => + Has_Buffer (Ctx), + Post => + Has_Buffer (Ctx) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old; + + function Present (Ctx : Context; Fld : Field) return Boolean; + + function Structural_Valid (Ctx : Context; Fld : Field) return Boolean; + + function Valid (Ctx : Context; Fld : Field) return Boolean with + Post => + (if Valid'Result then Structural_Valid (Ctx, Fld) and Present (Ctx, Fld)); + + function Incomplete (Ctx : Context; Fld : Field) return Boolean; + + function Invalid (Ctx : Context; Fld : Field) return Boolean; + + function Structural_Valid_Message (Ctx : Context) return Boolean with + Pre => + Has_Buffer (Ctx); + + function Valid_Message (Ctx : Context) return Boolean with + Pre => + Has_Buffer (Ctx); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Incomplete_Message (Ctx : Context) return Boolean with + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "precondition is always False"); + + function Get_Option_Type (Ctx : Context) return RFLX.Universal.Option_Type with + Pre => + Valid (Ctx, F_Option_Type); + + function Get_Length (Ctx : Context) return RFLX.Universal.Length with + Pre => + Valid (Ctx, F_Length); + + pragma Warnings (On, "precondition is always False"); + + function Get_Data (Ctx : Context) return RFLX_Types.Bytes with + Ghost, + Pre => + Has_Buffer (Ctx) + and then Structural_Valid (Ctx, F_Data) + and then Valid_Next (Ctx, F_Data), + Post => + Get_Data'Result'Length = RFLX_Types.To_Length (Field_Size (Ctx, F_Data)); + + procedure Get_Data (Ctx : Context; Data : out RFLX_Types.Bytes) with + Pre => + Has_Buffer (Ctx) + and then Structural_Valid (Ctx, F_Data) + and then Valid_Next (Ctx, F_Data) + and then Data'Length = RFLX_Types.To_Length (Field_Size (Ctx, F_Data)), + Post => + Equal (Ctx, F_Data, Data); + + generic + with procedure Process_Data (Data : RFLX_Types.Bytes); + procedure Generic_Get_Data (Ctx : Context) with + Pre => + Has_Buffer (Ctx) + and Present (Ctx, F_Data); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Length (Ctx : Context; Fld : Field; Length : RFLX_Types.Length) return Boolean with + Pre => + Valid_Next (Ctx, Fld), + Post => + True; + + pragma Warnings (On, "postcondition does not mention function result"); + + pragma Warnings (Off, "aspect ""*"" not enforced on inlined subprogram ""*"""); + + procedure Set_Option_Type (Ctx : in out Context; Val : RFLX.Universal.Option_Type_Enum) with + Inline_Always, + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Option_Type) + and then RFLX.Universal.Valid_Option_Type (To_U64 (Val)) + and then Field_Condition (Ctx, F_Option_Type, To_U64 (Val)) + and then Available_Space (Ctx, F_Option_Type) >= Field_Size (Ctx, F_Option_Type), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, F_Option_Type) + and Get_Option_Type (Ctx) = (True, Val) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Option_Type)) + and Invalid (Ctx, F_Length) + and Invalid (Ctx, F_Data) + and (if + RFLX_Types.U64 (To_U64 (Get_Option_Type (Ctx))) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)) + then + Predecessor (Ctx, F_Length) = F_Option_Type + and Valid_Next (Ctx, F_Length)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Option_Type) = Predecessor (Ctx, F_Option_Type)'Old + and Valid_Next (Ctx, F_Option_Type) = Valid_Next (Ctx, F_Option_Type)'Old; + + procedure Set_Length (Ctx : in out Context; Val : RFLX.Universal.Length) with + Inline_Always, + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Length) + and then RFLX.Universal.Valid_Length (To_U64 (Val)) + and then Field_Condition (Ctx, F_Length, To_U64 (Val)) + and then Available_Space (Ctx, F_Length) >= Field_Size (Ctx, F_Length), + Post => + Has_Buffer (Ctx) + and Valid (Ctx, F_Length) + and Get_Length (Ctx) = Val + and Invalid (Ctx, F_Data) + and (Predecessor (Ctx, F_Data) = F_Length + and Valid_Next (Ctx, F_Data)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Length) = Predecessor (Ctx, F_Length)'Old + and Valid_Next (Ctx, F_Length) = Valid_Next (Ctx, F_Length)'Old + and Get_Option_Type (Ctx) = Get_Option_Type (Ctx)'Old + and (for all F in Field range F_Option_Type .. F_Option_Type => + Context_Cursors_Index (Context_Cursors (Ctx), F) = Context_Cursors_Index (Context_Cursors (Ctx)'Old, F)); + + pragma Warnings (On, "aspect ""*"" not enforced on inlined subprogram ""*"""); + + procedure Set_Data_Empty (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Field_Condition (Ctx, F_Data, 0) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Option_Type (Ctx) = Get_Option_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + procedure Initialize_Data (Ctx : in out Context) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0, + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Option_Type (Ctx) = Get_Option_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + procedure Set_Data (Ctx : in out Context; Data : RFLX_Types.Bytes) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Data, Data'Length) + and then Available_Space (Ctx, F_Data) >= Data'Length * RFLX_Types.Byte'Size + and then Field_Condition (Ctx, F_Data, 0), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Option_Type (Ctx) = Get_Option_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old + and Equal (Ctx, F_Data, Data); + + generic + with procedure Process_Data (Data : out RFLX_Types.Bytes); + with function Process_Data_Pre (Length : RFLX_Types.Length) return Boolean; + procedure Generic_Set_Data (Ctx : in out Context; Length : RFLX_Types.Length) with + Pre => + not Ctx'Constrained + and then Has_Buffer (Ctx) + and then Valid_Next (Ctx, F_Data) + and then Available_Space (Ctx, F_Data) >= Field_Size (Ctx, F_Data) + and then Field_First (Ctx, F_Data) mod RFLX_Types.Byte'Size = 1 + and then Field_Last (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Field_Size (Ctx, F_Data) mod RFLX_Types.Byte'Size = 0 + and then Valid_Length (Ctx, F_Data, Length) + and then RFLX_Types.To_Length (Available_Space (Ctx, F_Data)) >= Length + and then Process_Data_Pre (Length), + Post => + Has_Buffer (Ctx) + and Structural_Valid (Ctx, F_Data) + and (if Structural_Valid_Message (Ctx) then Message_Last (Ctx) = Field_Last (Ctx, F_Data)) + and Ctx.Buffer_First = Ctx.Buffer_First'Old + and Ctx.Buffer_Last = Ctx.Buffer_Last'Old + and Ctx.First = Ctx.First'Old + and Ctx.Last = Ctx.Last'Old + and Predecessor (Ctx, F_Data) = Predecessor (Ctx, F_Data)'Old + and Valid_Next (Ctx, F_Data) = Valid_Next (Ctx, F_Data)'Old + and Get_Option_Type (Ctx) = Get_Option_Type (Ctx)'Old + and Get_Length (Ctx) = Get_Length (Ctx)'Old; + + function Context_Cursor (Ctx : Context; Fld : Field) return Field_Cursor with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + + function Context_Cursors (Ctx : Context) return Field_Cursors with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + + function Context_Cursors_Index (Cursors : Field_Cursors; Fld : Field) return Field_Cursor with + Annotate => + (GNATprove, Inline_For_Proof), + Ghost; + +private + + type Cursor_State is (S_Valid, S_Structural_Valid, S_Invalid, S_Incomplete); + + type Field_Cursor (State : Cursor_State := S_Invalid) is + record + Predecessor : Virtual_Field := F_Final; + case State is + when S_Valid | S_Structural_Valid => + First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; + Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First; + Value : RFLX_Types.U64 := 0; + when S_Invalid | S_Incomplete => + null; + end case; + end record; + + type Field_Cursors is array (Virtual_Field) of Field_Cursor; + + function Structural_Valid (Cursor : Field_Cursor) return Boolean is + (Cursor.State = S_Valid + or Cursor.State = S_Structural_Valid); + + function Valid (Cursor : Field_Cursor) return Boolean is + (Cursor.State = S_Valid); + + function Invalid (Cursor : Field_Cursor) return Boolean is + (Cursor.State = S_Invalid + or Cursor.State = S_Incomplete); + + pragma Warnings (Off, """Buffer"" is not modified, could be of access constant type"); + + pragma Warnings (Off, "postcondition does not mention function result"); + + function Valid_Context (Buffer_First, Buffer_Last : RFLX_Types.Index; First : RFLX_Types.Bit_Index; Last : RFLX_Types.Bit_Length; Verified_Last : RFLX_Types.Bit_Length; Written_Last : RFLX_Types.Bit_Length; Buffer : RFLX_Types.Bytes_Ptr; Cursors : Field_Cursors) return Boolean is + ((if Buffer /= null then Buffer'First = Buffer_First and Buffer'Last = Buffer_Last) + and then (RFLX_Types.To_Index (First) >= Buffer_First + and RFLX_Types.To_Index (Last) <= Buffer_Last + and Buffer_Last < RFLX_Types.Index'Last + and First <= Last + 1 + and Last < RFLX_Types.Bit_Index'Last + and First rem RFLX_Types.Byte'Size = 1 + and Last rem RFLX_Types.Byte'Size = 0) + and then First - 1 <= Verified_Last + and then First - 1 <= Written_Last + and then Verified_Last <= Written_Last + and then Written_Last <= Last + and then First rem RFLX_Types.Byte'Size = 1 + and then Last rem RFLX_Types.Byte'Size = 0 + and then Verified_Last rem RFLX_Types.Byte'Size = 0 + and then Written_Last rem RFLX_Types.Byte'Size = 0 + and then (for all F in Field => + (if + Structural_Valid (Cursors (F)) + then + Cursors (F).First >= First + and Cursors (F).Last <= Verified_Last + and Cursors (F).First <= Cursors (F).Last + 1 + and Valid_Value (F, Cursors (F).Value))) + and then ((if + Structural_Valid (Cursors (F_Length)) + then + (Valid (Cursors (F_Option_Type)) + and then Cursors (F_Length).Predecessor = F_Option_Type + and then RFLX_Types.U64 (Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)))) + and then (if + Structural_Valid (Cursors (F_Data)) + then + (Valid (Cursors (F_Length)) + and then Cursors (F_Data).Predecessor = F_Length))) + and then ((if Invalid (Cursors (F_Option_Type)) then Invalid (Cursors (F_Length))) + and then (if Invalid (Cursors (F_Length)) then Invalid (Cursors (F_Data)))) + and then (if + Structural_Valid (Cursors (F_Option_Type)) + then + Cursors (F_Option_Type).Last - Cursors (F_Option_Type).First + 1 = 8 + and then Cursors (F_Option_Type).Predecessor = F_Initial + and then Cursors (F_Option_Type).First = First + and then (if + Structural_Valid (Cursors (F_Length)) + and then RFLX_Types.U64 (Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)) + then + Cursors (F_Length).Last - Cursors (F_Length).First + 1 = 16 + and then Cursors (F_Length).Predecessor = F_Option_Type + and then Cursors (F_Length).First = Cursors (F_Option_Type).Last + 1 + and then (if + Structural_Valid (Cursors (F_Data)) + then + Cursors (F_Data).Last - Cursors (F_Data).First + 1 = RFLX_Types.Bit_Length (Cursors (F_Length).Value) * 8 + and then Cursors (F_Data).Predecessor = F_Length + and then Cursors (F_Data).First = Cursors (F_Length).Last + 1)))); + + pragma Warnings (On, """Buffer"" is not modified, could be of access constant type"); + + pragma Warnings (On, "postcondition does not mention function result"); + + type Context (Buffer_First, Buffer_Last : RFLX_Types.Index := RFLX_Types.Index'First; First : RFLX_Types.Bit_Index := RFLX_Types.Bit_Index'First; Last : RFLX_Types.Bit_Length := RFLX_Types.Bit_Length'First) is + record + Verified_Last : RFLX_Types.Bit_Length := First - 1; + Written_Last : RFLX_Types.Bit_Length := First - 1; + Buffer : RFLX_Types.Bytes_Ptr := null; + Cursors : Field_Cursors := (others => (State => S_Invalid, Predecessor => F_Final)); + end record with + Dynamic_Predicate => + Valid_Context (Context.Buffer_First, Context.Buffer_Last, Context.First, Context.Last, Context.Verified_Last, Context.Written_Last, Context.Buffer, Context.Cursors); + + function Initialized (Ctx : Context) return Boolean is + (Ctx.Verified_Last = Ctx.First - 1 + and then Valid_Next (Ctx, F_Option_Type) + and then Field_First (Ctx, F_Option_Type) rem RFLX_Types.Byte'Size = 1 + and then Available_Space (Ctx, F_Option_Type) = Ctx.Last - Ctx.First + 1 + and then (for all F in Field => + Invalid (Ctx, F))); + + function Has_Buffer (Ctx : Context) return Boolean is + (Ctx.Buffer /= null); + + function Buffer_Length (Ctx : Context) return RFLX_Types.Length is + (Ctx.Buffer'Length); + + function Size (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Verified_Last - Ctx.First + 1); + + function Byte_Size (Ctx : Context) return RFLX_Types.Length is + (RFLX_Types.To_Length (Size (Ctx))); + + function Message_Last (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Verified_Last); + + function Written_Last (Ctx : Context) return RFLX_Types.Bit_Length is + (Ctx.Written_Last); + + function Valid_Value (Fld : Field; Val : RFLX_Types.U64) return Boolean is + ((case Fld is + when F_Option_Type => + RFLX.Universal.Valid_Option_Type (Val), + when F_Length => + RFLX.Universal.Valid_Length (Val), + when F_Data => + True)); + + function Path_Condition (Ctx : Context; Fld : Field) return Boolean is + ((case Ctx.Cursors (Fld).Predecessor is + when F_Initial | F_Length | F_Data | F_Final => + True, + when F_Option_Type => + RFLX_Types.U64 (Ctx.Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)))); + + function Field_Condition (Ctx : Context; Fld : Field; Val : RFLX_Types.U64) return Boolean is + ((case Fld is + when F_Option_Type => + Val = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Null)) + or Val = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Data)), + when F_Length | F_Data => + True)); + + function Field_Size (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length is + ((case Fld is + when F_Option_Type => + 8, + when F_Length => + 16, + when F_Data => + RFLX_Types.Bit_Length (Ctx.Cursors (F_Length).Value) * 8)); + + function Field_First (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Index is + ((if Fld = F_Option_Type then Ctx.First else Ctx.Cursors (Ctx.Cursors (Fld).Predecessor).Last + 1)); + + function Field_Last (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length is + (Field_First (Ctx, Fld) + Field_Size (Ctx, Fld) - 1); + + function Predecessor (Ctx : Context; Fld : Virtual_Field) return Virtual_Field is + ((case Fld is + when F_Initial => + F_Initial, + when others => + Ctx.Cursors (Fld).Predecessor)); + + function Valid_Predecessor (Ctx : Context; Fld : Virtual_Field) return Boolean is + ((case Fld is + when F_Initial => + True, + when F_Option_Type => + Ctx.Cursors (Fld).Predecessor = F_Initial, + when F_Length => + (Valid (Ctx.Cursors (F_Option_Type)) + and Ctx.Cursors (Fld).Predecessor = F_Option_Type), + when F_Data => + (Valid (Ctx.Cursors (F_Length)) + and Ctx.Cursors (Fld).Predecessor = F_Length), + when F_Final => + (Structural_Valid (Ctx.Cursors (F_Data)) + and Ctx.Cursors (Fld).Predecessor = F_Data) + or (Valid (Ctx.Cursors (F_Option_Type)) + and Ctx.Cursors (Fld).Predecessor = F_Option_Type))); + + function Valid_Next (Ctx : Context; Fld : Field) return Boolean is + (Valid_Predecessor (Ctx, Fld) + and then Path_Condition (Ctx, Fld)); + + function Available_Space (Ctx : Context; Fld : Field) return RFLX_Types.Bit_Length is + (Ctx.Last - Field_First (Ctx, Fld) + 1); + + function Present (Ctx : Context; Fld : Field) return Boolean is + (Structural_Valid (Ctx.Cursors (Fld)) + and then Ctx.Cursors (Fld).First < Ctx.Cursors (Fld).Last + 1); + + function Structural_Valid (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Valid + or Ctx.Cursors (Fld).State = S_Structural_Valid); + + function Valid (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Valid + and then Ctx.Cursors (Fld).First < Ctx.Cursors (Fld).Last + 1); + + function Incomplete (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Incomplete); + + function Invalid (Ctx : Context; Fld : Field) return Boolean is + (Ctx.Cursors (Fld).State = S_Invalid + or Ctx.Cursors (Fld).State = S_Incomplete); + + function Structural_Valid_Message (Ctx : Context) return Boolean is + (Structural_Valid (Ctx, F_Data) + or (Valid (Ctx, F_Option_Type) + and then RFLX_Types.U64 (Ctx.Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Null)))); + + function Valid_Message (Ctx : Context) return Boolean is + (Valid (Ctx, F_Data) + or (Valid (Ctx, F_Option_Type) + and then RFLX_Types.U64 (Ctx.Cursors (F_Option_Type).Value) = RFLX_Types.U64 (To_U64 (RFLX.Universal.OT_Null)))); + + function Incomplete_Message (Ctx : Context) return Boolean is + ((for some F in Field => + Incomplete (Ctx, F))); + + function Get_Option_Type (Ctx : Context) return RFLX.Universal.Option_Type is + (To_Actual (Ctx.Cursors (F_Option_Type).Value)); + + function Get_Length (Ctx : Context) return RFLX.Universal.Length is + (To_Actual (Ctx.Cursors (F_Length).Value)); + + function Valid_Size (Ctx : Context; Fld : Field; Size : RFLX_Types.Bit_Length) return Boolean is + (Size = Field_Size (Ctx, Fld)) + with + Pre => + Valid_Next (Ctx, Fld); + + function Valid_Length (Ctx : Context; Fld : Field; Length : RFLX_Types.Length) return Boolean is + (Valid_Size (Ctx, Fld, RFLX_Types.To_Bit_Length (Length))); + + function Context_Cursor (Ctx : Context; Fld : Field) return Field_Cursor is + (Ctx.Cursors (Fld)); + + function Context_Cursors (Ctx : Context) return Field_Cursors is + (Ctx.Cursors); + + function Context_Cursors_Index (Cursors : Field_Cursors; Fld : Field) return Field_Cursor is + (Cursors (Fld)); + +end RFLX.Universal.Option; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option_types.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option_types.ads new file mode 100644 index 0000000000..9abd0d617e --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-option_types.ads @@ -0,0 +1,9 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +pragma SPARK_Mode; +with RFLX.RFLX_Scalar_Sequence; +pragma Warnings (Off, "unit ""*RFLX_Types"" is not referenced"); +with RFLX.RFLX_Types; +pragma Warnings (On, "unit ""*RFLX_Types"" is not referenced"); + +package RFLX.Universal.Option_Types is new RFLX.RFLX_Scalar_Sequence (RFLX.Universal.Option_Type, 8, RFLX.Universal.Valid_Option_Type, RFLX.Universal.To_Actual, RFLX.Universal.To_U64); diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-options.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-options.ads new file mode 100644 index 0000000000..1cf9f37dba --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-options.ads @@ -0,0 +1,10 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +pragma SPARK_Mode; +with RFLX.RFLX_Message_Sequence; +with RFLX.Universal.Option; +pragma Warnings (Off, "unit ""*RFLX_Types"" is not referenced"); +with RFLX.RFLX_Types; +pragma Warnings (On, "unit ""*RFLX_Types"" is not referenced"); + +package RFLX.Universal.Options is new RFLX.RFLX_Message_Sequence (RFLX.Universal.Option.Context, RFLX.Universal.Option.Initialize, RFLX.Universal.Option.Take_Buffer, RFLX.Universal.Option.Copy, RFLX.Universal.Option.Has_Buffer, RFLX.Universal.Option.Size, RFLX.Universal.Option.Message_Last, RFLX.Universal.Option.Initialized, RFLX.Universal.Option.Structural_Valid_Message); diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal-values.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-values.ads new file mode 100644 index 0000000000..6ca12ccbc5 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal-values.ads @@ -0,0 +1,9 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +pragma SPARK_Mode; +with RFLX.RFLX_Scalar_Sequence; +pragma Warnings (Off, "unit ""*RFLX_Types"" is not referenced"); +with RFLX.RFLX_Types; +pragma Warnings (On, "unit ""*RFLX_Types"" is not referenced"); + +package RFLX.Universal.Values is new RFLX.RFLX_Scalar_Sequence (RFLX.Universal.Value, 8, RFLX.Universal.Valid_Value, RFLX.Universal.To_Actual, RFLX.Universal.To_U64); diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx-universal.ads b/tests/integration/session_setting_of_message_fields/generated/rflx-universal.ads new file mode 100644 index 0000000000..be71d38c36 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx-universal.ads @@ -0,0 +1,144 @@ +pragma Style_Checks ("N3aAbcdefhiIklnOprStux"); +pragma Warnings (Off, "redundant conversion"); +with RFLX.RFLX_Types; + +package RFLX.Universal with + SPARK_Mode +is + + type Message_Type is (MT_Null, MT_Data, MT_Value, MT_Values, MT_Option_Types, MT_Options, MT_Unconstrained_Data, MT_Unconstrained_Options) with + Size => + 8; + for Message_Type use (MT_Null => 0, MT_Data => 1, MT_Value => 2, MT_Values => 3, MT_Option_Types => 4, MT_Options => 5, MT_Unconstrained_Data => 6, MT_Unconstrained_Options => 7); + + use type RFLX.RFLX_Types.U64; + + function Valid_Message_Type (Val : RFLX.RFLX_Types.U64) return Boolean is + (Val in 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7); + + function To_U64 (Enum : RFLX.Universal.Message_Type) return RFLX.RFLX_Types.U64 is + ((case Enum is + when MT_Null => + 0, + when MT_Data => + 1, + when MT_Value => + 2, + when MT_Values => + 3, + when MT_Option_Types => + 4, + when MT_Options => + 5, + when MT_Unconstrained_Data => + 6, + when MT_Unconstrained_Options => + 7)); + + pragma Warnings (Off, "unreachable branch"); + + function To_Actual (Val : RFLX.RFLX_Types.U64) return RFLX.Universal.Message_Type is + ((case Val is + when 0 => + MT_Null, + when 1 => + MT_Data, + when 2 => + MT_Value, + when 3 => + MT_Values, + when 4 => + MT_Option_Types, + when 5 => + MT_Options, + when 6 => + MT_Unconstrained_Data, + when 7 => + MT_Unconstrained_Options, + when others => + RFLX.Universal.Message_Type'Last)) + with + Pre => + Valid_Message_Type (Val); + + pragma Warnings (On, "unreachable branch"); + + type Length is range 0 .. 2**16 - 1 with + Size => + 16; + + function Valid_Length (Val : RFLX.RFLX_Types.U64) return Boolean is + (Val <= 65535); + + function To_U64 (Val : RFLX.Universal.Length) return RFLX.RFLX_Types.U64 is + (RFLX.RFLX_Types.U64 (Val)); + + function To_Actual (Val : RFLX.RFLX_Types.U64) return RFLX.Universal.Length is + (RFLX.Universal.Length (Val)) + with + Pre => + Valid_Length (Val); + + type Value is mod 256 with + Size => + 8; + + function Valid_Value (Val : RFLX.RFLX_Types.U64) return Boolean is + (Val <= 255); + + function To_U64 (Val : RFLX.Universal.Value) return RFLX.RFLX_Types.U64 is + (RFLX.RFLX_Types.U64 (Val)); + + function To_Actual (Val : RFLX.RFLX_Types.U64) return RFLX.Universal.Value is + (RFLX.Universal.Value (Val)) + with + Pre => + Valid_Value (Val); + + type Option_Type_Enum is (OT_Null, OT_Data) with + Size => + 8; + for Option_Type_Enum use (OT_Null => 0, OT_Data => 1); + + type Option_Type (Known : Boolean := False) is + record + case Known is + when True => + Enum : Option_Type_Enum; + when False => + Raw : RFLX_Types.U64; + end case; + end record; + + function Valid_Option_Type (Val : RFLX.RFLX_Types.U64) return Boolean is + (Val < 2**8); + + function Valid_Option_Type (Val : Option_Type) return Boolean is + ((if Val.Known then True else Valid_Option_Type (Val.Raw) and Val.Raw not in 0 | 1)); + + function To_U64 (Enum : RFLX.Universal.Option_Type_Enum) return RFLX.RFLX_Types.U64 is + ((case Enum is + when OT_Null => + 0, + when OT_Data => + 1)); + + function To_Actual (Enum : Option_Type_Enum) return RFLX.Universal.Option_Type is + ((True, Enum)); + + function To_Actual (Val : RFLX.RFLX_Types.U64) return RFLX.Universal.Option_Type is + ((case Val is + when 0 => + (True, OT_Null), + when 1 => + (True, OT_Data), + when others => + (False, Val))) + with + Pre => + Valid_Option_Type (Val); + + function To_U64 (Val : RFLX.Universal.Option_Type) return RFLX.RFLX_Types.U64 is + ((if Val.Known then To_U64 (Val.Enum) else Val.Raw)); + +end RFLX.Universal; diff --git a/tests/integration/session_setting_of_message_fields/generated/rflx.ads b/tests/integration/session_setting_of_message_fields/generated/rflx.ads new file mode 100644 index 0000000000..06c81f9402 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/generated/rflx.ads @@ -0,0 +1,3 @@ +package RFLX is + +end RFLX; \ No newline at end of file diff --git a/tests/integration/session_setting_of_message_fields/test.rflx b/tests/integration/session_setting_of_message_fields/test.rflx new file mode 100644 index 0000000000..9ee991ec10 --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/test.rflx @@ -0,0 +1,48 @@ +with Universal; + +package Test is + + generic + Channel : Channel with Readable, Writable; -- §S-P-C-RW + session Session with + Initial => Start, + Final => Terminated + is + Message : Universal::Message; -- §S-D-V-T-M, §S-D-V-E-N + begin + state Start is + begin + Channel'Read (Message); -- §S-S-A-RD-V + transition + goto Process + if Message'Valid = True -- §S-S-T-VAT, §S-E-AT-V-V, §S-S-T-L + and Message.Message_Type = Universal::MT_Data -- §S-S-T-S, §S-E-S-V, §S-S-T-L + and Message.Length = 1 -- §S-S-T-S, §S-E-S-V, §S-S-T-L + goto Terminated -- §S-S-T-N + end Start; + + state Process is + begin + -- §S-S-A-MFA-L + Message.Message_Type := Universal::MT_Data; + -- §S-S-A-MFA-L + Message.Length := 1; + -- §S-S-A-MFA-A + Message.Data := [2]; + transition + goto Reply -- §S-S-T-N + exception + goto Terminated -- §S-S-E + end Process; + + state Reply is + begin + Channel'Write (Message); -- §S-S-A-WR-V + transition + goto Terminated -- §S-S-T-N + end Reply; + + state Terminated is null state; -- §S-S-N + end Session; + +end Test; diff --git a/tests/integration/session_setting_of_message_fields/universal.rflx b/tests/integration/session_setting_of_message_fields/universal.rflx new file mode 120000 index 0000000000..ed94aaa6ac --- /dev/null +++ b/tests/integration/session_setting_of_message_fields/universal.rflx @@ -0,0 +1 @@ +../messages/universal.rflx \ No newline at end of file diff --git a/tests/integration/session_simple/generated/rflx-test-session.adb b/tests/integration/session_simple/generated/rflx-test-session.adb index 1d65df7e1b..75a3c527f6 100644 --- a/tests/integration/session_simple/generated/rflx-test-session.adb +++ b/tests/integration/session_simple/generated/rflx-test-session.adb @@ -59,10 +59,46 @@ is -- tests/integration/session_simple/test.rflx:27:10 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))); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Data); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, 1); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Data) then + 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 + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); 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 fe282a9e18..8f010b277b 100644 --- a/tests/integration/session_variable_initialization/generated/rflx-test-session.adb +++ b/tests/integration/session_variable_initialization/generated/rflx-test-session.adb @@ -62,9 +62,45 @@ is -- tests/integration/session_variable_initialization/test.rflx:29:10 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); + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (Ctx.P.Message_Ctx, Universal.MT_Value); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (Ctx.P.Message_Ctx, Universal.Length (Universal.Value'Size / 8)); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + if Universal.Message.Valid_Next (Ctx.P.Message_Ctx, Universal.Message.F_Value) then + if Universal.Message.Available_Space (Ctx.P.Message_Ctx, Universal.Message.F_Value) >= Universal.Message.Field_Size (Ctx.P.Message_Ctx, Universal.Message.F_Value) then + Universal.Message.Set_Value (Ctx.P.Message_Ctx, Ctx.P.Global); + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; + else + Ctx.P.Next_State := S_Terminated; + pragma Assert (Process_Invariant); + goto Finalize_Process; + end if; else Ctx.P.Next_State := S_Terminated; pragma Assert (Process_Invariant); diff --git a/tests/unit/generator_test.py b/tests/unit/generator_test.py index 02f9ebbf19..1832fd03ca 100644 --- a/tests/unit/generator_test.py +++ b/tests/unit/generator_test.py @@ -1016,8 +1016,8 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - # pylint: disable = line-too-long - """ + "" # ISSUE: PyCQA/pylint#3368 + + """\ -- :1:1 declare A : Universal.Message_Type; @@ -1038,34 +1038,74 @@ def variables(self) -> Sequence[expr.Variable]: Universal.Option.Initialize (C_Ctx, C_Buffer); if RFLX_Types.To_First_Bit_Index (C_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (C_Ctx.Buffer_First) + 1 >= 8 then Universal.Option.Reset (C_Ctx, RFLX_Types.To_First_Bit_Index (C_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (C_Ctx.Buffer_First) + 8 - 1); - Universal.Option.Set_Option_Type (C_Ctx, Universal.OT_Null); + if Universal.Option.Valid_Next (C_Ctx, Universal.Option.F_Option_Type) then + if Universal.Option.Available_Space (C_Ctx, Universal.Option.F_Option_Type) >= Universal.Option.Field_Size (C_Ctx, Universal.Option.F_Option_Type) then + Universal.Option.Set_Option_Type (C_Ctx, Universal.OT_Null); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""C_Ctx"" to set field ""Option_Type"" to ""Universal::OT_Null""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Option_Type"" to ""Universal::OT_Null"" although ""Option_Type"" is not valid next field"); + RFLX_Exception := True; + end if; else Ada.Text_IO.Put_Line ("Error: insufficient space in message ""C_Ctx""\"); RFLX_Exception := True; end if; if RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_First) + 1 >= RFLX_Types.Bit_Length (B) * 8 + 24 then Universal.Message.Reset (X_Ctx, RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_First) + (RFLX_Types.Bit_Length (B) * 8 + 24) - 1); - Universal.Message.Set_Message_Type (X_Ctx, A); - Universal.Message.Set_Length (X_Ctx, B); - if Universal.Message.Valid_Length (X_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (Universal.Option.Size (C_Ctx))) then - declare - function RFLX_Process_Data_Pre (Length : RFLX_Types.Length) return Boolean is - (Universal.Option.Has_Buffer (C_Ctx) - and then Universal.Option.Structural_Valid_Message (C_Ctx) - and then Length = Universal.Option.Byte_Size (C_Ctx)); - procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes) with - Pre => - RFLX_Process_Data_Pre (Data'Length) - is - begin - Universal.Option.Data (C_Ctx, 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 (X_Ctx, Universal.Option.Byte_Size (C_Ctx)); - end; + if Universal.Message.Valid_Next (X_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (X_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (X_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (X_Ctx, A); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx"" to set field ""Message_Type"" to ""A""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Message_Type"" to ""A"" although ""Message_Type"" is not valid next field"); + RFLX_Exception := True; + end if; + if Universal.Message.Valid_Next (X_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (X_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (X_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (X_Ctx, B); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx"" to set field ""Length"" to ""B""\"); + RFLX_Exception := True; + end if; else - Ada.Text_IO.Put_Line ("Error: invalid message field size for ""C'Opaque""\"); + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Length"" to ""B"" although ""Length"" is not valid next field"); + RFLX_Exception := True; + end if; + if Universal.Message.Valid_Next (X_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (X_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (X_Ctx, Universal.Message.F_Data) then + if Universal.Message.Valid_Length (X_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (Universal.Option.Size (C_Ctx))) then + declare + function RFLX_Process_Data_Pre (Length : RFLX_Types.Length) return Boolean is + (Universal.Option.Has_Buffer (C_Ctx) + and then Universal.Option.Structural_Valid_Message (C_Ctx) + and then Length = Universal.Option.Byte_Size (C_Ctx)); + procedure RFLX_Process_Data (Data : out RFLX_Types.Bytes) with + Pre => + RFLX_Process_Data_Pre (Data'Length) + is + begin + Universal.Option.Data (C_Ctx, 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 (X_Ctx, Universal.Option.Byte_Size (C_Ctx)); + end; + else + Ada.Text_IO.Put_Line ("Error: invalid message field size for ""C'Opaque""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx"" to set field ""Data"" to ""C'Opaque""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Data"" to ""C'Opaque"" although ""Data"" is not valid next field"); RFLX_Exception := True; end if; else @@ -1088,11 +1128,8 @@ def variables(self) -> Sequence[expr.Variable]: Ctx.P.Next_State := S_E; pragma Finalization; goto Finalize_S; -end if; -"""[ - 1:-1 - ], - # pylint: enable = line-too-long +end if;\ +""", ), ( # ISSUE: Componolit/RecordFlux#1069 @@ -1126,7 +1163,7 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - """ + """\ -- :1:1 declare A : Universal.Message_Type; @@ -1162,10 +1199,8 @@ def variables(self) -> Sequence[expr.Variable]: Ctx.P.Next_State := S_E; pragma Finalization; goto Finalize_S; -end if; -"""[ - 1:-1 - ], +end if;\ +""", ), ( # ISSUE: Componolit/RecordFlux#1069 @@ -1223,8 +1258,8 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - # pylint: disable = line-too-long - """ + "" # ISSUE: PyCQA/pylint#3368 + + """\ -- :1:1 declare A_Ctx : Universal.Message.Context; @@ -1237,12 +1272,42 @@ def variables(self) -> Sequence[expr.Variable]: Universal.Message.Initialize (A_Ctx, A_Buffer); if RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_First) + 1 >= 40 then Universal.Message.Reset (A_Ctx, RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_First) + 40 - 1); - Universal.Message.Set_Message_Type (A_Ctx, Universal.MT_Data); - Universal.Message.Set_Length (A_Ctx, Universal.Length (2)); - if Universal.Message.Valid_Length (A_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then - Universal.Message.Set_Data (A_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + if Universal.Message.Valid_Next (A_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (A_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (A_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (A_Ctx, Universal.MT_Data); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""A_Ctx"" to set field ""Message_Type"" to ""Universal::MT_Data""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Message_Type"" to ""Universal::MT_Data"" although ""Message_Type"" is not valid next field"); + RFLX_Exception := True; + end if; + if Universal.Message.Valid_Next (A_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (A_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (A_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (A_Ctx, Universal.Length (2)); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""A_Ctx"" to set field ""Length"" to ""2""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Length"" to ""2"" although ""Length"" is not valid next field"); + RFLX_Exception := True; + end if; + if Universal.Message.Valid_Next (A_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (A_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (A_Ctx, Universal.Message.F_Data) then + if Universal.Message.Valid_Length (A_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (2 * RFLX_Types.Byte'Size)) then + Universal.Message.Set_Data (A_Ctx, (RFLX_Types.Byte'Val (3), RFLX_Types.Byte'Val (4))); + else + Ada.Text_IO.Put_Line ("Error: invalid message field size for ""[3, 4]""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""A_Ctx"" to set field ""Data"" to ""[3, 4]""\"); + RFLX_Exception := True; + end if; else - Ada.Text_IO.Put_Line ("Error: invalid message field size for ""[3, 4]""\"); + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Data"" to ""[3, 4]"" although ""Data"" is not valid next field"); RFLX_Exception := True; end if; else @@ -1265,11 +1330,8 @@ def variables(self) -> Sequence[expr.Variable]: Ctx.P.Next_State := S_E; pragma Finalization; goto Finalize_S; -end if; -"""[ - 1:-1 - ] - # pylint: enable = line-too-long +end if;\ +""", ), ( # ISSUE: Componolit/RecordFlux#1069 @@ -1308,8 +1370,8 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - # pylint: disable = line-too-long - """ + "" # ISSUE: PyCQA/pylint#3368 + + """\ -- :1:1 declare A_Ctx : Universal.Message.Context; @@ -1322,7 +1384,17 @@ def variables(self) -> Sequence[expr.Variable]: Universal.Message.Initialize (A_Ctx, A_Buffer); if RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_First) + 1 >= 8 then Universal.Message.Reset (A_Ctx, RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (A_Ctx.Buffer_First) + 8 - 1); - Universal.Message.Set_Message_Type (A_Ctx, Universal.MT_Null); + if Universal.Message.Valid_Next (A_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (A_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (A_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (A_Ctx, Universal.MT_Null); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""A_Ctx"" to set field ""Message_Type"" to ""Universal::MT_Null""\"); + RFLX_Exception := True; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Message_Type"" to ""Universal::MT_Null"" although ""Message_Type"" is not valid next field"); + RFLX_Exception := True; + end if; else Ada.Text_IO.Put_Line ("Error: insufficient space in message ""A_Ctx""\"); RFLX_Exception := True; @@ -1342,11 +1414,8 @@ def variables(self) -> Sequence[expr.Variable]: Ctx.P.Next_State := S_E; pragma Finalization; goto Finalize_S; -end if; -"""[ - 1:-1 - ] - # pylint: enable = line-too-long +end if;\ +""", ), # ISSUE: Componolit/RecordFlux#577 # Copying of sequences is not yet supported. @@ -1447,17 +1516,59 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - # pylint: disable = line-too-long - """ + "" # ISSUE: PyCQA/pylint#3368 + + """\ -- :1:1 if RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_Last) - RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_First) + 1 >= 24 then Universal.Message.Reset (X_Ctx, RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_First), RFLX_Types.To_First_Bit_Index (X_Ctx.Buffer_First) + 24 - 1); - Universal.Message.Set_Message_Type (X_Ctx, Universal.MT_Data); - Universal.Message.Set_Length (X_Ctx, Universal.Length (0)); - if Universal.Message.Valid_Length (X_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (0 * RFLX_Types.Byte'Size)) then - Universal.Message.Set_Data_Empty (X_Ctx); + if Universal.Message.Valid_Next (X_Ctx, Universal.Message.F_Message_Type) then + if Universal.Message.Available_Space (X_Ctx, Universal.Message.F_Message_Type) >= Universal.Message.Field_Size (X_Ctx, Universal.Message.F_Message_Type) then + Universal.Message.Set_Message_Type (X_Ctx, Universal.MT_Data); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx"" to set field ""Message_Type"" to ""Universal::MT_Data""\"); + Ctx.P.Next_State := S_E; + pragma Finalization; + goto Finalize_S; + end if; else - Ada.Text_IO.Put_Line ("Error: invalid message field size for ""[]""\"); + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Message_Type"" to ""Universal::MT_Data"" although ""Message_Type"" is not valid next field"); + Ctx.P.Next_State := S_E; + pragma Finalization; + goto Finalize_S; + end if; + if Universal.Message.Valid_Next (X_Ctx, Universal.Message.F_Length) then + if Universal.Message.Available_Space (X_Ctx, Universal.Message.F_Length) >= Universal.Message.Field_Size (X_Ctx, Universal.Message.F_Length) then + Universal.Message.Set_Length (X_Ctx, Universal.Length (0)); + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx"" to set field ""Length"" to ""0""\"); + Ctx.P.Next_State := S_E; + pragma Finalization; + goto Finalize_S; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Length"" to ""0"" although ""Length"" is not valid next field"); + Ctx.P.Next_State := S_E; + pragma Finalization; + goto Finalize_S; + end if; + if Universal.Message.Valid_Next (X_Ctx, Universal.Message.F_Data) then + if Universal.Message.Available_Space (X_Ctx, Universal.Message.F_Data) >= Universal.Message.Field_Size (X_Ctx, Universal.Message.F_Data) then + if Universal.Message.Valid_Length (X_Ctx, Universal.Message.F_Data, RFLX_Types.To_Length (0 * RFLX_Types.Byte'Size)) then + Universal.Message.Set_Data_Empty (X_Ctx); + else + Ada.Text_IO.Put_Line ("Error: invalid message field size for ""[]""\"); + Ctx.P.Next_State := S_E; + pragma Finalization; + goto Finalize_S; + end if; + else + Ada.Text_IO.Put_Line ("Error: insufficient space in message ""X_Ctx"" to set field ""Data"" to ""[]""\"); + Ctx.P.Next_State := S_E; + pragma Finalization; + goto Finalize_S; + end if; + else + Ada.Text_IO.Put_Line ("Error: trying to set message field ""Data"" to ""[]"" although ""Data"" is not valid next field"); Ctx.P.Next_State := S_E; pragma Finalization; goto Finalize_S; @@ -1467,11 +1578,8 @@ def variables(self) -> Sequence[expr.Variable]: Ctx.P.Next_State := S_E; pragma Finalization; goto Finalize_S; -end if; -"""[ - 1:-1 - ] - # pylint: enable = line-too-long +end if;\ +""", ), ( stmt.Assignment( @@ -1488,17 +1596,15 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - """ + """\ -- :1:1 declare A : Universal.Message.Structure; begin Universal.Message.To_Structure (A_Ctx, A); F (Ctx, A, X); -end; -"""[ - 1:-1 - ], +end;\ +""", ), ( stmt.Assignment( @@ -1515,7 +1621,7 @@ def variables(self) -> Sequence[expr.Variable]: ), location=Location(start=(1, 1)), ), - """ + """\ -- :1:1 declare X : Universal.Option.Structure; @@ -1538,10 +1644,8 @@ def variables(self) -> Sequence[expr.Variable]: pragma Finalization; goto Finalize_S; end if; -end; -"""[ - 1:-1 - ], +end;\ +""", ), ( stmt.Assignment( @@ -1804,7 +1908,7 @@ def test_session_state_action_error( ), ), RecordFluxError, - r"Last with type universal integer \(undefined\) in message aggregate" + r"Last with type universal integer \(undefined\) as value of message field" r" not yet supported", ), ( diff --git a/tests/unit/specification/grammar_test.py b/tests/unit/specification/grammar_test.py index 69a38343bb..da898c77b4 100644 --- a/tests/unit/specification/grammar_test.py +++ b/tests/unit/specification/grammar_test.py @@ -655,6 +655,16 @@ def test_assignment_statement(string: str, expected: stmt.Statement) -> None: assert actual.location +@pytest.mark.parametrize( + "string,expected", + [("A.B := C", stmt.MessageFieldAssignment("A", "B", expr.Variable("C")))], +) +def test_message_field_assignment_statement(string: str, expected: stmt.Statement) -> None: + actual = parse_statement(string) + assert actual == expected + assert actual.location + + @pytest.mark.parametrize( "string,expected", [