Skip to content

GitLab

P
PolyORB-HI-Ada
Commit f0a3e164 authored by yoogx's avatar yoogx
Browse files
Options

* Code reorganization for GNATProve GPL2014

parent 22b47903
Show whitespace changes
Inline Side-by-side
Showing with 98 additions and 275 deletions
examples/aadlv2/producer_consumer/producer_consumer.adb
View file @ f0a3e164
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, GET-Telecom Paris. --
-- Copyright (C) 2009 Telecom ParisTech, 2010-2014 ESA & ISAE. --
-- --
-- PolyORB HI is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
......@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- PolyORB HI is maintained by GET Telecom Paris --
-- PolyORB-HI/Ada is maintained by the TASTE project --
-- (taste-users@lists.tuxfamily.org) --
-- --
------------------------------------------------------------------------------
......@@ -61,6 +62,11 @@ package body Producer_Consumer is
procedure Produce_Spg (Data_Source : out Alpha_Type) is
begin
Data_Source := The_Data;
if The_Data > 1000 then
The_Data := 1;
end if;
The_Data := The_Data + 1;
Put_Line (Normal, Get_Node
......
src/Makefile.am
View file @ f0a3e164
......@@ -16,6 +16,7 @@ ADA_SPECS_WITH_BODY = $(srcdir)/polyorb_hi-aperiodic_task.ads \
$(srcdir)/polyorb_hi-suspenders.ads \
$(srcdir)/polyorb_hi-thread_interrogators.ads \
$(srcdir)/polyorb_hi-scheduler.ads \
$(srcdir)/polyorb_hi-time_marshallers.ads \
$(srcdir)/polyorb_hi-unprotected_queue.ads \
$(srcdir)/polyorb_hi-utils.ads
......@@ -25,7 +26,6 @@ ADA_SPECS = $(ADA_SPECS_WITH_BODY) $(srcdir)/polyorb_hi.ads \
$(srcdir)/polyorb_hi-output_low_level.ads \
$(srcdir)/polyorb_hi-port_type_marshallers.ads \
$(srcdir)/polyorb_hi-streams.ads \
$(srcdir)/polyorb_hi-time_marshallers.ads \
$(srcdir)/polyorb_hi-transport_low_level.ads
ADA_BODIES = $(ADA_SPECS_WITH_BODY:.ads=.adb) \
......
src/native.adc
View file @ f0a3e164
-- Ada restrictions to be supported by PolyORB HI, for native targets
-- pragma Profile_Warnings (Ravenscar); -- D.13.1
pragma Profile_Warnings (Ravenscar); -- D.13.1
src/polyorb_hi-messages.ads
View file @ f0a3e164
......@@ -118,7 +118,8 @@ private
end record;
function Valid (Message : Message_Type) return Boolean is
(Message.First >= Message.Content'First and then Message.First < Message.Last
(Message.First >= Message.Content'First
and then Message.First < Message.Last
and then Message.Last <= Message.Content'Last);
function Payload (M : Message_Type) return Stream_Element_Array is
......
src/polyorb_hi-null_task.adb
View file @ f0a3e164
......@@ -31,19 +31,14 @@
-- --
------------------------------------------------------------------------------
with Ada.Synchronous_Task_Control;
with PolyORB_HI.Output;
with PolyORB_HI.Suspenders;
package body PolyORB_HI.Null_Task is
use PolyORB_HI.Errors;
use PolyORB_HI.Output;
use PolyORB_HI_Generated.Deployment;
use PolyORB_HI.Suspenders;
use Ada.Real_Time;
use Ada.Synchronous_Task_Control;
-------------------
-- The_Null_Task --
......@@ -51,11 +46,15 @@ package body PolyORB_HI.Null_Task is
procedure The_Null_Task is
Error : Error_Kind;
Initialized : Boolean := True;
begin
-- Run the initialize entrypoint (if any)
if not Initialized then
Activate_Entrypoint;
Initialized := True;
end if;
-- Wait for the network initialization to be finished
......
src/polyorb_hi-null_task.ads
View file @ f0a3e164
......@@ -31,6 +31,13 @@
-- --
------------------------------------------------------------------------------
-- Define a "null" task as a job to be scheduled by a
-- software-defined scheduler in place of a OS scheduler. Its
-- interface mimics the one of a periodic task.
--
-- Expected usage is for a Round-Robin non-preemptive scheduler
-- defined through a cyclic function.
with System;
with Ada.Real_Time;
with PolyORB_HI_Generated.Deployment;
......@@ -65,6 +72,13 @@ generic
-- detected.
package PolyORB_HI.Null_Task is
-- The following parameters are not used for now. The usage is
-- reserved for future extensions.
pragma Unreferenced (Task_Priority);
pragma Unreferenced (Task_Stack_Size);
pragma Unreferenced (Task_Period);
pragma Unreferenced (Task_Deadline);
procedure The_Null_Task;
......
src/polyorb_hi-thread_interrogators.adb
View file @ f0a3e164
......@@ -59,7 +59,6 @@ package body PolyORB_HI.Thread_Interrogators is
Integer_Array,
Port_Kind_Array,
Port_Image_Array,
Address_Array,
Overflow_Protocol_Array,
Thread_Interface_Type,
Current_Entity,
......@@ -70,197 +69,9 @@ package body PolyORB_HI.Thread_Interrogators is
Thread_Fifo_Offsets,
Thread_Overflow_Protocols,
Urgencies,
Global_Data_Queue_Size,
N_Destinations,
Destinations,
Marshall,
Next_Deadline);
Global_Data_Queue_Size);
use UQ;
------------------
-- Global_Queue --
------------------
-- The protected object below handles all the received events or
-- data on IN ports.
--
-- Finally, the protected object contains a second array to store
-- the number of received values for each IN EVENT [DATA] (0 .. n)
-- and IN DATA (0 .. 1) port.
protected Global_Queue is
pragma Priority (System.Priority'Last);
entry Wait_Event (P : out Port_Type);
-- Blocks until the thread receives a new event. Return the
-- corresponding Port that received the event.
procedure Read_Event (P : out Port_Type; Valid : out Boolean);
-- Same as 'Wait_Event' but without blocking. Valid is set to
-- False if there is nothing to receive.
procedure Dequeue (T : Port_Type; P : out Port_Stream_Entry);
-- Dequeue a value from the partial FIFO of port T. If there is
-- no enqueued value, return the latest dequeued value.
function Read_In (T : Port_Type) return Port_Stream_Entry;
-- Read the oldest queued value on the partial FIFO of IN port
-- T without dequeuing it. If there is no queued value, return
-- the latest dequeued value.
function Read_Out (T : Port_Type) return Port_Stream_Entry;
-- Return the value put for OUT port T.
function Is_Invalid (T : Port_Type) return Boolean;
-- Return True if no Put_Value has been called for this port
-- since the last Set_Invalid call.
procedure Set_Invalid (T : Port_Type);
-- Set the value stored for OUT port T as invalid to impede its
-- future sending without calling Put_Value. This procedure is
-- generally called just after Read_Out. However we cannot
-- combine them in one routine because we need Read_Out to be a
-- function and functions cannot modify protected object
-- states.
procedure Store_In (P : Port_Stream_Entry; T : Time);
-- Stores a new incoming message in its corresponding
-- position. If this is an event [data] incoming message, then
-- stores it in the queue, updates its most recent value and
-- unblock the barrier. Otherwise, it only overrides the most
-- recent value. T is the time stamp associated to the port
-- P. In case of data ports with delayed connections, it
-- indicates the instant from which the data of P becomes
-- deliverable.
procedure Store_Out (P : Port_Stream_Entry; T : Time);
-- Store a value of an OUT port to be sent at the next call to
-- Send_Output and mark the value as valid.
function Count (T : Port_Type) return Integer;
-- Return the number of pending messages on IN port T.
function Get_Time_Stamp (P : Port_Type) return Time;
-- Return the time stamp associated to port T
private
Not_Empty : Boolean := False;
-- The protected object barrier. True when there is at least
-- one pending event [data].
end Global_Queue;
protected body Global_Queue is
----------------
-- Wait_Event --
----------------
entry Wait_Event (P : out Port_Type) when Not_Empty is
Valid : Boolean;
begin
UQ.Read_Event (P, Valid, Not_Empty);
pragma Debug (Put_Line
(Verbose,
CE
+ ": Wait_Event: oldest unread event port = "
+ Thread_Port_Images (P)));
end Wait_Event;
----------------
-- Read_Event --
----------------
procedure Read_Event (P : out Port_Type; Valid : out Boolean) is
begin
UQ.Read_Event (P, Valid, Not_Empty);
end Read_Event;
-------------
-- Dequeue --
-------------
procedure Dequeue (T : Port_Type; P : out Port_Stream_Entry) is
begin
UQ.Dequeue (T, P, Not_Empty);
end Dequeue;
-------------
-- Read_In --
-------------
function Read_In (T : Port_Type) return Port_Stream_Entry is
begin
return UQ.Read_In (T);
end Read_In;
--------------
-- Read_Out --
--------------
function Read_Out (T : Port_Type) return Port_Stream_Entry is
begin
return UQ.Read_Out (T);
end Read_Out;
----------------
-- Is_Invalid --
----------------
function Is_Invalid (T : Port_Type) return Boolean is
begin
return UQ.Is_Invalid (T);
end Is_Invalid;
-----------------
-- Set_Invalid --
-----------------
procedure Set_Invalid (T : Port_Type) is
begin
UQ.Set_Invalid (T);
end Set_Invalid;
--------------
-- Store_In --
--------------
procedure Store_In (P : Port_Stream_Entry; T : Time) is
begin
UQ.Store_In (P, T, Not_Empty);
end Store_In;
---------------
-- Store_Out --
---------------
procedure Store_Out (P : Port_Stream_Entry; T : Time) is
begin
UQ.Store_Out (P, T);
end Store_Out;
-----------
-- Count --
-----------
function Count (T : Port_Type) return Integer is
begin
return UQ.Count (T);
end Count;
--------------------
-- Get_Time_Stamp --
--------------------
function Get_Time_Stamp (P : Port_Type) return Time is
begin
return UQ.Get_Time_Stamp (P);
end Get_Time_Stamp;
end Global_Queue;
-----------------
-- Send_Output --
-----------------
......@@ -279,9 +90,9 @@ package body PolyORB_HI.Thread_Interrogators is
N_Dst : Integer renames N_Destinations (Port);
P_Kind : Port_Kind renames Thread_Port_Kinds (Port);
Message : aliased PolyORB_HI.Messages.Message_Type;
Message : PolyORB_HI.Messages.Message_Type;
Value : constant Thread_Interface_Type := Stream_To_Interface
(Global_Queue.Read_Out (Port).Payload);
(UQ.Read_Out (Port).Payload);
Error : Error_Kind := Error_None;
begin
......@@ -292,7 +103,7 @@ package body PolyORB_HI.Thread_Interrogators is
-- If no valid value is to be sent, quit
if Global_Queue.Is_Invalid (Port) then
if UQ.Is_Invalid (Port) then
pragma Debug (Put_Line (Verbose,
CE
+ ": Send_Output: Invalid value in port "
......@@ -301,7 +112,7 @@ package body PolyORB_HI.Thread_Interrogators is
else
-- Mark the port value as invalid to impede future sendings
Global_Queue.Set_Invalid (Port);
UQ.Set_Invalid (Port);
-- Begin the sending to all destinations
......@@ -315,7 +126,7 @@ package body PolyORB_HI.Thread_Interrogators is
if not Is_Event (P_Kind) then
Time_Marshallers.Marshall
(Global_Queue.Get_Time_Stamp (Port),
(UQ.Get_Time_Stamp (Port),
Message);
end if;
......@@ -361,7 +172,7 @@ package body PolyORB_HI.Thread_Interrogators is
begin
pragma Debug (Put_Line (Verbose, CE + ": Put_Value"));
Global_Queue.Store_Out
UQ.Store_Out
((Current_Entity, Interface_To_Stream (Thread_Interface)),
Next_Deadline);
end Put_Value;
......@@ -373,7 +184,7 @@ package body PolyORB_HI.Thread_Interrogators is
procedure Receive_Input (Port : Port_Type) is
pragma Unreferenced (Port);
begin
raise Program_Error with CE + ": Receive_Input: Not implemented yet";
null; -- XXX Cannot raise an exception here
end Receive_Input;
---------------
......@@ -381,7 +192,7 @@ package body PolyORB_HI.Thread_Interrogators is
---------------
function Get_Value (Port : Port_Type) return Thread_Interface_Type is
Stream : constant Port_Stream := Global_Queue.Read_In (Port).Payload;
Stream : constant Port_Stream := UQ.Read_In (Port).Payload;
T_Port : constant Thread_Interface_Type := Stream_To_Interface (Stream);
begin
pragma Debug (Put_Line
......@@ -398,7 +209,7 @@ package body PolyORB_HI.Thread_Interrogators is
----------------
function Get_Sender (Port : Port_Type) return Entity_Type is
Sender : constant Entity_Type := Global_Queue.Read_In (Port).From;
Sender : constant Entity_Type := UQ.Read_In (Port).From;
begin
pragma Debug (Put_Line
(Verbose,
......@@ -415,7 +226,7 @@ package body PolyORB_HI.Thread_Interrogators is
---------------
function Get_Count (Port : Port_Type) return Integer is
Count : constant Integer := Global_Queue.Count (Port);
Count : constant Integer := UQ.Count (Port);
begin
pragma Debug (Put_Line (Verbose,
CE
......@@ -433,13 +244,14 @@ package body PolyORB_HI.Thread_Interrogators is
procedure Next_Value (Port : Port_Type) is
P : Port_Stream_Entry;
Not_Empty : Boolean;
begin
pragma Debug (Put_Line (Verbose,
CE
+ ": Next_Value for port "
+ Thread_Port_Images (Port)));
Global_Queue.Dequeue (Port, P);
UQ.Dequeue (Port, P, Not_Empty);
end Next_Value;
------------------------------
......@@ -447,10 +259,14 @@ package body PolyORB_HI.Thread_Interrogators is
------------------------------
procedure Wait_For_Incoming_Events (Port : out Port_Type) is
Valid, Not_Empty : Boolean;
pragma Warnings (Off, Not_Empty);
-- Under this implementation, Not_Empty is not used.
begin
pragma Debug (Put_Line (Verbose, CE + ": Wait_For_Incoming_Events"));
Global_Queue.Wait_Event (Port);
UQ.Read_Event (Port, Valid, Not_Empty);
pragma Debug (Put_Line
(Verbose,
......@@ -465,8 +281,11 @@ package body PolyORB_HI.Thread_Interrogators is
--------------------
procedure Get_Next_Event (Port : out Port_Type; Valid : out Boolean) is
Not_Empty : Boolean;
pragma Warnings (Off, Not_Empty);
-- Under this implementation, Not_Empty is not used.
begin
Global_Queue.Read_Event (Port, Valid);
UQ.Read_Event (Port, Valid, Not_Empty);
if Valid then
pragma Debug (Put_Line
......@@ -494,11 +313,13 @@ package body PolyORB_HI.Thread_Interrogators is
From : Entity_Type;
Time_Stamp : Ada.Real_Time.Time := Ada.Real_Time.Clock)
is
Not_Empty : Boolean;
pragma Unreferenced (Not_Empty);
begin
pragma Debug (Put_Line (Verbose, CE + ": Store_Received_Message"));
Global_Queue.Store_In
((From, Interface_To_Stream (Thread_Interface)), Time_Stamp);
UQ.Store_In
((From, Interface_To_Stream (Thread_Interface)), Time_Stamp, Not_Empty);
end Store_Received_Message;
--------------------
......@@ -507,7 +328,7 @@ package body PolyORB_HI.Thread_Interrogators is
function Get_Time_Stamp (P : Port_Type) return Time is
begin
return Global_Queue.Get_Time_Stamp (P);
return UQ.Get_Time_Stamp (P);
end Get_Time_Stamp;
end PolyORB_HI.Thread_Interrogators;
src/polyorb_hi-time_marshallers.ads
View file @ f0a3e164
......@@ -32,7 +32,18 @@
------------------------------------------------------------------------------
with Ada.Real_Time;
with PolyORB_HI.Marshallers_G;
with PolyORB_HI.Messages;
package PolyORB_HI.Time_Marshallers is
new PolyORB_HI.Marshallers_G (Ada.Real_Time.Time);
procedure Marshall
(R : Ada.Real_Time.Time;
M : in out Messages.Message_Type);
-- Marshall a data R in message M
procedure Unmarshall
(R : out Ada.Real_Time.Time;
M : in out Messages.Message_Type);
-- Unmarshall a data R from message M
end PolyORB_HI.Time_Marshallers;
src/polyorb_hi-unprotected_queue.adb
View file @ f0a3e164
......@@ -32,16 +32,11 @@
------------------------------------------------------------------------------
with PolyORB_HI.Output;
with PolyORB_HI.Utils;
package body PolyORB_HI.Unprotected_Queue is
use type PolyORB_HI.Streams.Stream_Element_Offset;
use PolyORB_HI.Port_Kinds;
use Ada.Real_Time;
use PolyORB_HI_Generated.Deployment;
use PolyORB_HI.Output;
use PolyORB_HI.Utils;
----------------
-- Read_Event --
......@@ -372,9 +367,11 @@ package body PolyORB_HI.Unprotected_Queue is
Frst := Frst - 1;
end loop;
end if;
when Error =>
raise Program_Error with
CE + ": Store_In: FIFO is full";
Put_Line (Verbose,
CE + ": Store_In: FIFO is full");
-- XXX SHould raise an exception there !
end case;
-- Remove event in the history and shift
......
src/polyorb_hi-unprotected_queue.ads
View file @ f0a3e164
......@@ -33,12 +33,9 @@
with Ada.Unchecked_Conversion;
With Ada.Real_Time;
With System;
with PolyORB_HI_Generated.Deployment;
with PolyORB_HI.Errors;
with PolyORB_HI.Messages;
with PolyORB_HI.Port_Kinds;
with PolyORB_HI.Streams;
......@@ -58,9 +55,6 @@ generic
PolyORB_HI_Generated.Deployment.Port_Sized_String;
-- An array type to specify the image of each port.
type Address_Array is array (Port_Type) of System.Address;
-- An array to specify a list of arrays of various sizes.
type Overflow_Protocol_Array is array (Port_Type) of
Port_Kinds.Overflow_Handling_Protocol;
-- An array to specify the overflow_handling_protocol of each port
......@@ -116,25 +110,6 @@ generic
-- deducing it from Thread_Fifo_Sizes is done to guarantee static
-- allocation of the global message queue of the thread.
N_Destinations : in Integer_Array;
-- For each OUT port, we give the number of destinations. This
-- will be used to know the length of each element of the array
-- below.
Destinations : in Address_Array;
-- For each OUT port, we give the address of an constant
-- Entity_Type array containing the list of all the destination of
-- the port. For IN ports, we give Null_Address.
with procedure Marshall
(R : Thread_Interface_Type;
M : in out PolyORB_Hi.Messages.Message_Type);
-- A procedure that marshalls a Thread port content into a message.
with function Next_Deadline return Ada.Real_Time.Time;
-- To indicate when does the next deadline of the thread occur (in
-- absolute time).
package PolyORB_HI.Unprotected_Queue is
use Ada.Real_Time;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment