Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
P
PolyORB-HI-Ada
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
TASTE
PolyORB-HI-Ada
Commits
f0a3e164
Commit
f0a3e164
authored
Aug 23, 2014
by
yoogx
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
* Code reorganization for GNATProve GPL2014
parent
22b47903
Changes
10
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
98 additions
and
275 deletions
+98
-275
examples/aadlv2/producer_consumer/producer_consumer.adb
examples/aadlv2/producer_consumer/producer_consumer.adb
+8
-2
src/Makefile.am
src/Makefile.am
+1
-1
src/native.adc
src/native.adc
+2
-3
src/polyorb_hi-messages.ads
src/polyorb_hi-messages.ads
+3
-2
src/polyorb_hi-null_task.adb
src/polyorb_hi-null_task.adb
+5
-6
src/polyorb_hi-null_task.ads
src/polyorb_hi-null_task.ads
+14
-0
src/polyorb_hi-thread_interrogators.adb
src/polyorb_hi-thread_interrogators.adb
+48
-227
src/polyorb_hi-time_marshallers.ads
src/polyorb_hi-time_marshallers.ads
+13
-2
src/polyorb_hi-unprotected_queue.adb
src/polyorb_hi-unprotected_queue.adb
+4
-7
src/polyorb_hi-unprotected_queue.ads
src/polyorb_hi-unprotected_queue.ads
+0
-25
No files found.
examples/aadlv2/producer_consumer/producer_consumer.adb
View file @
f0a3e164
...
@@ -6,7 +6,7 @@
...
@@ -6,7 +6,7 @@
-- --
-- --
-- B o d y --
-- 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 --
-- 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 --
-- under terms of the GNU General Public License as published by the Free --
...
@@ -26,7 +26,8 @@
...
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- 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
...
@@ -61,6 +62,11 @@ package body Producer_Consumer is
procedure
Produce_Spg
(
Data_Source
:
out
Alpha_Type
)
is
procedure
Produce_Spg
(
Data_Source
:
out
Alpha_Type
)
is
begin
begin
Data_Source
:=
The_Data
;
Data_Source
:=
The_Data
;
if
The_Data
>
1000
then
The_Data
:=
1
;
end
if
;
The_Data
:=
The_Data
+
1
;
The_Data
:=
The_Data
+
1
;
Put_Line
(
Normal
,
Get_Node
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 \
...
@@ -16,6 +16,7 @@ ADA_SPECS_WITH_BODY = $(srcdir)/polyorb_hi-aperiodic_task.ads \
$(srcdir)
/polyorb_hi-suspenders.ads
\
$(srcdir)
/polyorb_hi-suspenders.ads
\
$(srcdir)
/polyorb_hi-thread_interrogators.ads
\
$(srcdir)
/polyorb_hi-thread_interrogators.ads
\
$(srcdir)
/polyorb_hi-scheduler.ads
\
$(srcdir)
/polyorb_hi-scheduler.ads
\
$(srcdir)
/polyorb_hi-time_marshallers.ads
\
$(srcdir)
/polyorb_hi-unprotected_queue.ads
\
$(srcdir)
/polyorb_hi-unprotected_queue.ads
\
$(srcdir)
/polyorb_hi-utils.ads
$(srcdir)
/polyorb_hi-utils.ads
...
@@ -25,7 +26,6 @@ ADA_SPECS = $(ADA_SPECS_WITH_BODY) $(srcdir)/polyorb_hi.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-output_low_level.ads
\
$(srcdir)
/polyorb_hi-port_type_marshallers.ads
\
$(srcdir)
/polyorb_hi-port_type_marshallers.ads
\
$(srcdir)
/polyorb_hi-streams.ads
\
$(srcdir)
/polyorb_hi-streams.ads
\
$(srcdir)
/polyorb_hi-time_marshallers.ads
\
$(srcdir)
/polyorb_hi-transport_low_level.ads
$(srcdir)
/polyorb_hi-transport_low_level.ads
ADA_BODIES
=
$(ADA_SPECS_WITH_BODY:.ads=.adb)
\
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
-- 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,8 +118,9 @@ private
...
@@ -118,8 +118,9 @@ private
end
record
;
end
record
;
function
Valid
(
Message
:
Message_Type
)
return
Boolean
is
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
.
Last
<=
Message
.
Content
'
Last
);
and
then
Message
.
First
<
Message
.
Last
and
then
Message
.
Last
<=
Message
.
Content
'
Last
);
function
Payload
(
M
:
Message_Type
)
return
Stream_Element_Array
is
function
Payload
(
M
:
Message_Type
)
return
Stream_Element_Array
is
(
M
.
Content
(
M
.
First
..
M
.
Last
));
(
M
.
Content
(
M
.
First
..
M
.
Last
));
...
...
src/polyorb_hi-null_task.adb
View file @
f0a3e164
...
@@ -31,19 +31,14 @@
...
@@ -31,19 +31,14 @@
-- --
-- --
------------------------------------------------------------------------------
------------------------------------------------------------------------------
with
Ada
.
Synchronous_Task_Control
;
with
PolyORB_HI
.
Output
;
with
PolyORB_HI
.
Output
;
with
PolyORB_HI
.
Suspenders
;
package
body
PolyORB_HI
.
Null_Task
is
package
body
PolyORB_HI
.
Null_Task
is
use
PolyORB_HI
.
Errors
;
use
PolyORB_HI
.
Errors
;
use
PolyORB_HI
.
Output
;
use
PolyORB_HI
.
Output
;
use
PolyORB_HI_Generated
.
Deployment
;
use
PolyORB_HI_Generated
.
Deployment
;
use
PolyORB_HI
.
Suspenders
;
use
Ada
.
Real_Time
;
use
Ada
.
Real_Time
;
use
Ada
.
Synchronous_Task_Control
;
-------------------
-------------------
-- The_Null_Task --
-- The_Null_Task --
...
@@ -51,11 +46,15 @@ package body PolyORB_HI.Null_Task is
...
@@ -51,11 +46,15 @@ package body PolyORB_HI.Null_Task is
procedure
The_Null_Task
is
procedure
The_Null_Task
is
Error
:
Error_Kind
;
Error
:
Error_Kind
;
Initialized
:
Boolean
:=
True
;
begin
begin
-- Run the initialize entrypoint (if any)
-- Run the initialize entrypoint (if any)
Activate_Entrypoint
;
if
not
Initialized
then
Activate_Entrypoint
;
Initialized
:=
True
;
end
if
;
-- Wait for the network initialization to be finished
-- Wait for the network initialization to be finished
...
...
src/polyorb_hi-null_task.ads
View file @
f0a3e164
...
@@ -31,6 +31,13 @@
...
@@ -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
System
;
with
Ada
.
Real_Time
;
with
Ada
.
Real_Time
;
with
PolyORB_HI_Generated
.
Deployment
;
with
PolyORB_HI_Generated
.
Deployment
;
...
@@ -65,6 +72,13 @@ generic
...
@@ -65,6 +72,13 @@ generic
-- detected.
-- detected.
package
PolyORB_HI
.
Null_Task
is
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
;
procedure
The_Null_Task
;
...
...
src/polyorb_hi-thread_interrogators.adb
View file @
f0a3e164
...
@@ -59,7 +59,6 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -59,7 +59,6 @@ package body PolyORB_HI.Thread_Interrogators is
Integer_Array
,
Integer_Array
,
Port_Kind_Array
,
Port_Kind_Array
,
Port_Image_Array
,
Port_Image_Array
,
Address_Array
,
Overflow_Protocol_Array
,
Overflow_Protocol_Array
,
Thread_Interface_Type
,
Thread_Interface_Type
,
Current_Entity
,
Current_Entity
,
...
@@ -70,238 +69,50 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -70,238 +69,50 @@ package body PolyORB_HI.Thread_Interrogators is
Thread_Fifo_Offsets
,
Thread_Fifo_Offsets
,
Thread_Overflow_Protocols
,
Thread_Overflow_Protocols
,
Urgencies
,
Urgencies
,
Global_Data_Queue_Size
,
Global_Data_Queue_Size
);
N_Destinations
,
Destinations
,
Marshall
,
Next_Deadline
);
use
UQ
;
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 --
-- Send_Output --
-----------------
-----------------
function
Send_Output
(
Port
:
Port_Type
)
return
Error_Kind
is
function
Send_Output
(
Port
:
Port_Type
)
return
Error_Kind
is
type
Port_Type_Array
is
array
(
Positive
)
type
Port_Type_Array
is
array
(
Positive
)
of
PolyORB_HI_Generated
.
Deployment
.
Port_Type
;
of
PolyORB_HI_Generated
.
Deployment
.
Port_Type
;
type
Port_Type_Array_Access
is
access
Port_Type_Array
;
type
Port_Type_Array_Access
is
access
Port_Type_Array
;
function
To_Pointer
is
new
Ada
.
Unchecked_Conversion
function
To_Pointer
is
new
Ada
.
Unchecked_Conversion
(
System
.
Address
,
Port_Type_Array_Access
);
(
System
.
Address
,
Port_Type_Array_Access
);
Dst
:
constant
Port_Type_Array_Access
:=
Dst
:
constant
Port_Type_Array_Access
:=
To_Pointer
(
Destinations
(
Port
));
To_Pointer
(
Destinations
(
Port
));
N_Dst
:
Integer
renames
N_Destinations
(
Port
);
N_Dst
:
Integer
renames
N_Destinations
(
Port
);
P_Kind
:
Port_Kind
renames
Thread_Port_Kinds
(
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
Value
:
constant
Thread_Interface_Type
:=
Stream_To_Interface
(
Global_Queue
.
Read_Out
(
Port
).
Payload
);
(
UQ
.
Read_Out
(
Port
).
Payload
);
Error
:
Error_Kind
:=
Error_None
;
Error
:
Error_Kind
:=
Error_None
;
begin
begin
pragma
Debug
(
Put_Line
(
Verbose
,
pragma
Debug
(
Put_Line
(
Verbose
,
CE
CE
+
": Send_Output: port "
+
": Send_Output: port "
+
Thread_Port_Images
(
Port
)));
+
Thread_Port_Images
(
Port
)));
-- If no valid value is to be sent, quit
-- 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
,
pragma
Debug
(
Put_Line
(
Verbose
,
CE
CE
+
": Send_Output: Invalid value in port "
+
": Send_Output: Invalid value in port "
+
Thread_Port_Images
(
Port
)));
+
Thread_Port_Images
(
Port
)));
null
;
null
;
else
else
-- Mark the port value as invalid to impede future sendings
-- 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
-- Begin the sending to all destinations
...
@@ -315,7 +126,7 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -315,7 +126,7 @@ package body PolyORB_HI.Thread_Interrogators is
if
not
Is_Event
(
P_Kind
)
then
if
not
Is_Event
(
P_Kind
)
then
Time_Marshallers
.
Marshall
Time_Marshallers
.
Marshall
(
Global_Queue
.
Get_Time_Stamp
(
Port
),
(
UQ
.
Get_Time_Stamp
(
Port
),
Message
);
Message
);
end
if
;
end
if
;
...
@@ -327,10 +138,10 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -327,10 +138,10 @@ package body PolyORB_HI.Thread_Interrogators is
(
Put_Line
(
Put_Line
(
Verbose
,
(
Verbose
,
CE
CE
+
": Send_Output: to port "
+
": Send_Output: to port "
+
PolyORB_HI_Generated
.
Deployment
.
Port_Image
(
Dst
(
To
))
+
PolyORB_HI_Generated
.
Deployment
.
Port_Image
(
Dst
(
To
))
+
" of "
+
" of "
+
Entity_Image
(
Port_Table
(
Dst
(
To
)))));
+
Entity_Image
(
Port_Table
(
Dst
(
To
)))));
Error
:=
Protocols
.
Send
(
Current_Entity
,
Error
:=
Protocols
.
Send
(
Current_Entity
,
Port_Table
(
Dst
(
To
)),
Port_Table
(
Dst
(
To
)),
...
@@ -345,9 +156,9 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -345,9 +156,9 @@ package body PolyORB_HI.Thread_Interrogators is
pragma
Debug
(
Put_Line
(
Verbose
,
pragma
Debug
(
Put_Line
(
Verbose
,
CE
CE
+
": Send_Output: port "
+
": Send_Output: port "
+
Thread_Port_Images
(
Port
)
+
Thread_Port_Images
(
Port
)
+
". End."
));
+
". End."
));
end
if
;
end
if
;
return
Error
;
return
Error
;
...
@@ -361,7 +172,7 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -361,7 +172,7 @@ package body PolyORB_HI.Thread_Interrogators is
begin
begin
pragma
Debug
(
Put_Line
(
Verbose
,
CE
+
": Put_Value"
));
pragma
Debug
(
Put_Line
(
Verbose
,
CE
+
": Put_Value"
));
Global_Queue
.
Store_Out
UQ
.
Store_Out
((
Current_Entity
,
Interface_To_Stream
(
Thread_Interface
)),
((
Current_Entity
,
Interface_To_Stream
(
Thread_Interface
)),
Next_Deadline
);
Next_Deadline
);
end
Put_Value
;
end
Put_Value
;
...
@@ -373,7 +184,7 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -373,7 +184,7 @@ package body PolyORB_HI.Thread_Interrogators is
procedure
Receive_Input
(
Port
:
Port_Type
)
is
procedure
Receive_Input
(
Port
:
Port_Type
)
is
pragma
Unreferenced
(
Port
);
pragma
Unreferenced
(
Port
);
begin
begin
raise
Program_Error
with
CE
+
": Receive_Input: Not implemented yet"
;
null
;
-- XXX Cannot raise an exception here
end
Receive_Input
;
end
Receive_Input
;
---------------
---------------
...
@@ -381,7 +192,7 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -381,7 +192,7 @@ package body PolyORB_HI.Thread_Interrogators is
---------------
---------------
function
Get_Value
(
Port
:
Port_Type
)
return
Thread_Interface_Type
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
);
T_Port
:
constant
Thread_Interface_Type
:=
Stream_To_Interface
(
Stream
);
begin
begin
pragma
Debug
(
Put_Line
pragma
Debug
(
Put_Line
...
@@ -398,7 +209,7 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -398,7 +209,7 @@ package body PolyORB_HI.Thread_Interrogators is
----------------
----------------
function
Get_Sender
(
Port
:
Port_Type
)
return
Entity_Type
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
begin
pragma
Debug
(
Put_Line
pragma
Debug
(
Put_Line
(
Verbose
,
(
Verbose
,
...
@@ -415,7 +226,7 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -415,7 +226,7 @@ package body PolyORB_HI.Thread_Interrogators is
---------------
---------------
function
Get_Count
(
Port
:
Port_Type
)
return
Integer
is
function
Get_Count
(
Port
:
Port_Type
)
return
Integer
is
Count
:
constant
Integer
:=
Global_Queue
.
Count
(
Port
);
Count
:
constant
Integer
:=
UQ
.
Count
(
Port
);
begin
begin
pragma
Debug
(
Put_Line
(
Verbose
,
pragma
Debug
(
Put_Line
(
Verbose
,
CE
CE
...
@@ -433,13 +244,14 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -433,13 +244,14 @@ package body PolyORB_HI.Thread_Interrogators is
procedure
Next_Value
(
Port
:
Port_Type
)
is
procedure
Next_Value
(
Port
:
Port_Type
)
is
P
:
Port_Stream_Entry
;
P
:
Port_Stream_Entry
;
Not_Empty
:
Boolean
;
begin
begin
pragma
Debug
(
Put_Line
(
Verbose
,
pragma
Debug
(
Put_Line
(
Verbose
,
CE
CE
+
": Next_Value for port "
+
": Next_Value for port "
+
Thread_Port_Images
(
Port
)));
+
Thread_Port_Images
(
Port
)));
Global_Queue
.
Dequeue
(
Port
,
P
);
UQ
.
Dequeue
(
Port
,
P
,
Not_Empty
);
end
Next_Value
;
end
Next_Value
;
------------------------------
------------------------------
...
@@ -447,10 +259,14 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -447,10 +259,14 @@ package body PolyORB_HI.Thread_Interrogators is
------------------------------
------------------------------
procedure
Wait_For_Incoming_Events
(
Port
:
out
Port_Type
)
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
begin
pragma
Debug
(
Put_Line
(
Verbose
,
CE
+
": Wait_For_Incoming_Events"
));
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
pragma
Debug
(
Put_Line
(
Verbose
,
(
Verbose
,
...
@@ -465,8 +281,11 @@ package body PolyORB_HI.Thread_Interrogators is
...
@@ -465,8 +281,11 @@ package body PolyORB_HI.Thread_Interrogators is
--------------------