|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 20048 (0x4e50)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─ ⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988. ALL RIGHTS RESERVED.
--
--
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988. ALL RIGHTS RESERVED.
--
--
with System;
with Unchecked_Conversion;
with Timer;
with Process_Ops;
with Message_Queues;
with Task_Serialization;
with Interprogram_Communications;
with Task_Map;
with Runtime_Error;
with System_Definitions;
package body Task_Management is
pragma Suppress_All;
use System_Definitions.Operators;
package Tt renames Tasking_Types;
package Mq renames Message_Queues;
package Err renames Runtime_Error.Values;
package Ipc renames Interprogram_Communications;
subtype Layer is Tt.Layer;
subtype Task_Control_Block is Tt.Task_Control_Block;
subtype List is Tt.List;
subtype Coldness_Value is Tt.Coldness_Value;
subtype Valid_Entry_Id is Tt.Valid_Entry_Id;
subtype Select_Branch_Table is Tt.Select_Branch_Table;
subtype Select_Branch_Table_Skin is Tt.Select_Branch_Table_Skin;
subtype Branch_Table_Link is Tt.Branch_Table_Link;
subtype Wait_List_Skin is Tt.Wait_List_Skin;
subtype Wait_List_Link is Tt.Wait_List_Link;
subtype Queue_Info is Tt.Queue_Info;
subtype Select_Form is Tt.Select_Form;
subtype Reply_Kind is Tt.Reply_Kind;
subtype Reply_Message is Tt.Reply_Message;
subtype Entry_Call_Message is Tt.Entry_Call_Message;
subtype Suspension_Reason is Tt.Suspension_Reason;
subtype Action is Tt.Action;
subtype Action_Set is Tt.Action_Set;
subtype Bounds_For_Stack is Tt.Bounds_For_Stack;
subtype Fork_Parameters is Tt.Fork_Parameters;
subtype Buffer_List is Tt.Buffer_List;
Warm : constant Coldness_Value := Tt.Warm;
Cold : constant Coldness_Value := Tt.Cold;
Cool : constant Coldness_Value := Tt.Cool;
Root : constant Coldness_Value := Tt.Root;
Abnormal : constant Action := Tt.Abnormal;
Selecting_Termination : constant Action := Tt.Selecting_Termination;
Non_Callable : constant Action := Tt.Non_Callable;
Exception_Pending : constant Action := Tt.Exception_Pending;
Activation_Done : constant Action := Tt.Activation_Done;
Parent_Or_Child_Ok_Tcb_Reclamation : constant Action :=
Tt.Parent_Or_Child_Ok_Tcb_Reclamation;
Not_Suspended : constant Suspension_Reason := Tt.Not_Suspended;
Not_Activated : constant Suspension_Reason := Tt.Not_Activated;
Child_Activating : constant Suspension_Reason := Tt.Child_Activating;
Awaiting_Dependent_Termination : constant Suspension_Reason :=
Tt.Awaiting_Dependent_Termination;
Calling_Entry : constant Suspension_Reason := Tt.Calling_Entry;
Awaiting_Entry_Call : constant Suspension_Reason := Tt.Awaiting_Entry_Call;
Delaying : constant Suspension_Reason := Tt.Delaying;
Terminated : constant Suspension_Reason := Tt.Terminated;
Awaiting_Tcb_Reclamation_Ok : constant Suspension_Reason :=
Tt.Awaiting_Tcb_Reclamation_Ok;
Awaiting_Abortee_Reply : constant Suspension_Reason :=
Tt.Awaiting_Abortee_Reply;
No_Reply : constant Reply_Kind := Tt.No_Reply;
Delay_Stmt_Done : constant Reply_Kind := Tt.Delay_Stmt_Done;
Call_Timed_Out : constant Reply_Kind := Tt.Call_Timed_Out;
Select_Timed_Out : constant Reply_Kind := Tt.Select_Timed_Out;
Activation_Group_Activated : constant Reply_Kind :=
Tt.Activation_Group_Activated;
Rendezvous_Done : constant Reply_Kind := Tt.Rendezvous_Done;
Dependents_Terminated : constant Reply_Kind := Tt.Dependents_Terminated;
Termination_Selected : constant Reply_Kind := Tt.Termination_Selected;
Task_Aborted : constant Reply_Kind := Tt.Task_Aborted;
Child_Tcb_Reclaimable : constant Reply_Kind := Tt.Child_Tcb_Reclaimable;
Abortion_Acknowledged : constant Reply_Kind := Tt.Abortion_Acknowledged;
Null_Entry_Id : constant Entry_Id := 0;
subtype Caller_Name is Tt.Caller_Name;
Null_Caller : constant Caller_Name := 0;
Null_Timer : constant Timer.Id := 0;
Null_Process_Id : constant Integer := -1;
function "=" (L, R : Layer_Id) return Boolean renames Tt."=";
function "=" (L, R : Task_Id) return Boolean renames Tt."=";
function "=" (L, R : Entry_Id) return Boolean renames Tt."=";
function "=" (L, R : Coldness_Value) return Boolean renames Tt."=";
function "=" (L, R : Select_Form) return Boolean renames Tt."=";
function "=" (L, R : Alternative_Number) return Boolean renames Tt."=";
function "=" (L, R : Reply_Kind) return Boolean renames Tt."=";
function "=" (L, R : Suspension_Reason) return Boolean renames Tt."=";
function "=" (L, R : Action) return Boolean renames Tt."=";
function "=" (L, R : Buffer_List) return Boolean renames Tt."=";
function "=" (L, R : Caller_Name) return Boolean renames Tt."=";
function "=" (L, R : Exceptions.Name) return Boolean renames Exceptions."=";
function "=" (L, R : Mq.Message_Id) return Boolean renames Mq."=";
function "=" (L, R : Timer.Id) return Boolean renames Timer."=";
function To_Task_Id is new Unchecked_Conversion (Caller_Name, Task_Id);
function To_Caller_Name is new Unchecked_Conversion (Task_Id, Caller_Name);
\f
Debug_Mode : Boolean renames Debug_Definitions.Debug_Task_Management;
Safety_Check : Boolean renames Debug_Definitions.Safety_Check;
function Convert (X : Integer) return System.Address
renames System_Definitions.Operators.To_Address;
function Convert (X : System.Address) return Integer
renames System_Definitions.Operators.To_Integer;
Reply_Queue_Index : constant Mq.Wait_List_Index := 0;
First_Entry_Index : constant Mq.Wait_List_Index :=
Mq.Wait_List_Index (Valid_Entry_Id'First);
Bits_Per_Byte : constant := 8;
Reply_Message_Size : constant Mq.Message_Size :=
Reply_Message'Size / Bits_Per_Byte;
Entry_Call_Message_Size : constant Mq.Message_Size :=
Entry_Call_Message'Size / Bits_Per_Byte;
Fork_Parameters_Size : constant Integer :=
Fork_Parameters'Size / Bits_Per_Byte;
Default_Task_Stack_Size : constant Integer := 8192;
Minimum_Os_Priority : constant := 4;
Os_Base_Priority : Integer;
pragma Import_Object (Os_Base_Priority, "__OS_BASE_PRIORITY");
Buffer_Free_List : Buffer_List := null;
pragma Import_Object (Buffer_Free_List, "__IPC_BUFFER_FREELIST");
Main_Code_Start : System_Address;
pragma Import_Object (Main_Code_Start, "__MAIN_CODE_START_VAR");
Main_Priority : Priority;
pragma Import_Object (Main_Priority, "__MAIN_PRIORITY_VAR");
Task_Code_Start : System.Address;
pragma Import_Object (Task_Code_Start, "__TASK_CODE_START_VAR");
Abort_Main_Program_Flag : Boolean;
pragma Import_Object (Abort_Main_Program_Flag, "__ABORT_MAIN_FLAG");
Root_Task : Task_Control_Block;
pragma Import_Object (Root_Task, "__ROOT_TCB");
Root_Task_Ptr : Task_Id;
pragma Import_Object (Root_Task_Ptr, "__ROOT_TASK_ID");
Dummy_Task : Task_Control_Block;
pragma Import_Object (Dummy_Task, "__DUMMY_TCB");
Root_Layer : Layer;
pragma Import_Object (Root_Layer, "__ROOT_LAYER");
Top_Layer : Layer;
pragma Import_Object (Top_Layer, "__TOP_LAYER");
package Debugging is
procedure Put_Message (Msg : String);
pragma Suppress (Elaboration_Check, Put_Message);
pragma Export_Procedure (Put_Message, "__TMD_PUT_MESSAGE");
-- procedure Put_Layer (Layer : Layer_Id);
-- pragma Suppress (Elaboration_Check, Put_Layer);
-- pragma Export_Procedure (Put_Layer, "__TMD_Put_Layer");
-- procedure Put_Tcb (The_Task : Task_Id);
-- pragma Suppress (Elaboration_Check, Put_Tcb);
-- pragma Export_Procedure (Put_Tcb, "__TMD_Put_Tcb");
-- procedure Put_Message_Queue (Id : Mq.Id);
-- pragma Suppress (Elaboration_Check, Put_Message_Queue);
-- pragma Export_Procedure (Put_Message_Queue, "__TMD_Put_Message_Queue");
-- procedure Put_Message_Id (Id : Mq.Message_Id);
-- pragma Suppress (Elaboration_Check, Put_Message_Id);
-- pragma Export_Procedure (Put_Message_Id, "__TMD_Put_Message_Id");
end Debugging;
package Storage_Manager is
function New_Task_Control_Block return Task_Id;
pragma Suppress (Elaboration_Check, New_Task_Control_Block);
pragma Export_Function (New_Task_Control_Block, "__TMSM_NEW_TCB");
procedure Free_Tcb (A_Tcb : in out Task_Id);
pragma Suppress (Elaboration_Check, Free_Tcb);
pragma Export_Procedure (Free_Tcb, "__TMSM_FREE_TCB");
function New_Queues (Entries : Entry_Number; Current_Task : Task_Id)
return Queue_Info;
pragma Suppress (Elaboration_Check, New_Queues);
pragma Export_Function (New_Queues, "__TMSM_NEW_QUEUES");
procedure Free_Queues (Queues : in out Queue_Info;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Free_Queues);
pragma Export_Procedure (Free_Queues, "__TMSM_FREE_QUEUES");
function New_Buffer_Item (With_Buffer : Integer;
Slot_Data : Integer;
Next_Item : Buffer_List) return Buffer_List;
pragma Suppress (Elaboration_Check, New_Buffer_Item);
pragma Export_Function (New_Buffer_Item, "__TMSM_NEW_BUFFER");
end Storage_Manager;
package Runtime_Exceptions is
procedure Raise_Runtime_Error (Caller : String;
Msg : String;
Error : Runtime_Error.Fatal_Error;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Raise_Runtime_Error);
pragma Export_Procedure (Raise_Runtime_Error, "__TMRE_RAISE_RUNTIME");
procedure Raise_Abnormal_Task_Error (Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Raise_Abnormal_Task_Error);
pragma Export_Procedure (Raise_Abnormal_Task_Error,
"__TMRE_RAISE_ABNORMAL");
procedure Raise_Force_Term_Error (Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Raise_Force_Term_Error);
pragma Export_Procedure (Raise_Force_Term_Error,
"__TMRE_RAISE_FORCE_TERM");
procedure Check_For_Abnormality (Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Check_For_Abnormality);
pragma Export_Procedure (Check_For_Abnormality,
"__TMRE_CHECK_ABNORMAL");
procedure Raise_Tasking_Error;
pragma Suppress (Elaboration_Check, Raise_Tasking_Error);
pragma Export_Procedure (Raise_Tasking_Error, "__TMRE_RAISE_TASKING");
procedure Raise_Storage_Error;
pragma Suppress (Elaboration_Check, Raise_Storage_Error);
pragma Export_Procedure (Raise_Storage_Error, "__TMRE_RAISE_STORAGE");
procedure Raise_Program_Error;
pragma Suppress (Elaboration_Check, Raise_Program_Error);
pragma Export_Procedure (Raise_Program_Error, "__TMRE_RAISE_PROGRAM");
procedure Check_For_Pending_Exception (Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Check_For_Pending_Exception);
pragma Export_Procedure (Check_For_Pending_Exception,
"__TMRE_CHECK_EXCEPTION");
procedure Raise_Exception;
pragma Suppress (Elaboration_Check, Raise_Exception);
pragma Export_Procedure (Raise_Exception, "__TMRE_RAISE_EXCEPTION");
end Runtime_Exceptions;
package Checking is
procedure Check_Message_Queue_Status (Status : Mq.Stratus;
Error : Runtime_Error.Fatal_Error;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Check_Message_Queue_Status);
pragma Export_Procedure (Check_Message_Queue_Status,
"__TMC_CHECK_MSGQ_STATUS");
procedure Check_Timer_Status (Status : Timer.Stratus;
Error : Runtime_Error.Fatal_Error;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Check_Timer_Status);
pragma Export_Procedure (Check_Timer_Status,
"__TMC_CHECK_TIMER_STATUS");
-- procedure Check_Process_Ops_Status (Status : Process_Ops.Status;
-- Error : Runtime_Error.Fatal_Error;
-- Current_Task : Task_Id);
-- pragma Suppress (Elaboration_Check, Check_Process_Ops_Status);
-- pragma Export_Procedure (Check_Process_Ops_Status,
-- "__TMC_Check_Proc_Ops_Status");
procedure Check_Reply (Received : Reply_Kind;
Expected : Reply_Kind;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Check_Reply);
pragma Export_Procedure (Check_Reply, "__TMC_CHECK_REPLY");
procedure Check_Task (The_Task : Task_Id;
Caller : String;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Check_Task);
pragma Export_Procedure (Check_Task, "__TMC_CHECK_TASK");
-- procedure Check_Layer (Layer : Layer_Id;
-- Caller : String;
-- Current_Task : Task_Id);
-- pragma Suppress (Elaboration_Check, Check_Layer);
-- pragma Export_Procedure (Check_Layer, "__TMC_Check_Layer");
end Checking;
package Message_Queue_Utilities is
procedure Send_Reply (To_Task : Task_Id;
Reply : Reply_Kind;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Send_Reply);
pragma Export_Procedure (Send_Reply, "__TMMQU_SEND_REPLY");
procedure Await_Reply (Suspension_State : Suspension_Reason;
Reply : out Reply_Kind;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Await_Reply);
pragma Export_Procedure (Await_Reply, "__TMMQU_AWAIT_REPLY");
-- function Retrieve_Reply
-- (Queue : Mq.Id; Current_Task : Task_Id) return Reply_Kind;
-- pragma Suppress (Elaboration_Check, Retrieve_Reply);
--
-- function Retrieve_Entry_Call_Message
-- (Queue : Mq.Id;
-- Empty_Queue_Ok : Boolean := False;
-- Current_Task : Task_Id) return Entry_Call_Message;
-- pragma Suppress (Elaboration_Check, Retrieve_Entry_Call_Message);
function Get_Associated_Data (For_Queue : Mq.Id; Current_Task : Task_Id)
return Mq.Associated_Data;
pragma Suppress (Elaboration_Check, Get_Associated_Data);
pragma Export_Function (Get_Associated_Data, "__TMMQU_GET_ASSOC_DATA");
procedure Purge_Reply_Queue (Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Purge_Reply_Queue);
pragma Export_Procedure (Purge_Reply_Queue, "__TMMQU_PURGE_REPLYQ");
-- procedure Assert_Empty_Reply_Queue
-- (Caller : String; Current_Task : Task_Id);
-- pragma Suppress (Elaboration_Check, Assert_Empty_Reply_Queue);
-- pragma Export_Procedure (Assert_Empty_Reply_Queue,
-- "__TMMQU_Assert_Empty_Reply_Q");
function Start_Timer (Time : Duration;
Reply : Reply_Kind;
Current_Task : Task_Id) return Timer.Id;
pragma Suppress (Elaboration_Check, Start_Timer);
pragma Export_Function (Start_Timer, "__TMMQU_START_TIMER");
procedure Cancel_Timer (Timer_Id : Timer.Id;
Purge_If_Expired : Boolean := False;
Current_Task : Task_Id);
pragma Suppress (Elaboration_Check, Cancel_Timer);
pragma Export_Procedure (Cancel_Timer, "__TMMQU_CANCEL_TIMER");
end Message_Queue_Utilities;
function Checksum (For_Tcb : Task_Id) return Integer;
pragma Suppress (Elaboration_Check, Checksum);
pragma Interface (Asm, Checksum);
pragma Import_Function (Checksum, "__TCB_CHECKSUM", Mechanism => Value);
function Get_Current_Task_And_Acquire_Lock
(The_Lock : Task_Serialization.Lock :=
Task_Serialization.Tasking_Lock) return Task_Id
renames Task_Serialization.Acquire_Lock;
procedure Reacquire_Lock (The_Lock : Task_Serialization.Lock :=
Task_Serialization.Tasking_Lock)
renames Task_Serialization.Reacquire_Lock;
procedure Release_Lock renames Task_Serialization.Release_Lock;
package body Debugging is separate;
package body Storage_Manager is separate;
package body Runtime_Exceptions is separate;
package body Checking is separate;
package body Message_Queue_Utilities is separate;
package body Creation_And_Activation is separate;
package body Termination_And_Abortion is separate;
package body Calling_And_Delaying is separate;
package body Accepting_And_Selecting is separate;
package body Attributes is separate;
package body Intra_Runtime is separate;
package body Ipc_Support is separate;
procedure Initialize is separate;
begin
Buffer_Free_List := null;
Initialize;
end Task_Management;
pragma Export_Elaboration_Procedure ("__TASK_MGMT_BODY_ELAB");
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);