|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 42695 (0xa6c7)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦7720abd71⟧
└─⟦this⟧
-- Copyright 1991 Verdix Corporation
with system; use system;
with unchecked_conversion;
with krn_defs;
package ada_krn_defs is
pragma suppress(ALL_CHECKS);
pragma suppress(EXCEPTION_TABLES);
pragma not_elaborated;
pragma local_access;
--------------------------------------------------------------------------
-- Ada kernel type definitions for VADS_MICRO/MC68020
--------------------------------------------------------------------------
-- Kernel's task id (OS DEPENDENT)
subtype krn_task_id is krn_defs.a_krn_tcb_t;
-- NO_KRN_TASK_ID: constant krn_task_id := null;
function NO_KRN_TASK_ID return krn_task_id;
pragma inline_only(NO_KRN_TASK_ID);
-- Kernel's program id (OS DEPENDENT)
subtype krn_program_id is krn_defs.a_krn_pcb_t;
-- NO_KRN_PROGRAM_ID: constant krn_program_id := null;
function NO_KRN_PROGRAM_ID return krn_program_id;
pragma inline_only(NO_KRN_PROGRAM_ID);
--------------------------------------------------------------------------
-- Interrupt types (OS DEPENDENT)
--------------------------------------------------------------------------
-- Interrupt Vector ID's.
subtype intr_vector_id_t is krn_defs.intr_vector_id_t;
-- Interrupt enable/disable status.
subtype intr_status_t is krn_defs.intr_status_t;
-- All interrupts disabled
DISABLE_INTR_STATUS: constant intr_status_t :=
krn_defs.DISABLE_INTR_STATUS;
-- All interrupts enabled
ENABLE_INTR_STATUS: constant intr_status_t :=
krn_defs.ENABLE_INTR_STATUS;
-- Value return for a bad intr_vector passed to the interrupt
-- service routines
BAD_INTR_VECTOR: constant address := krn_defs.BAD_INTR_VECTOR;
--------------------------------------------------------------------------
-- Interrupt entry types
--------------------------------------------------------------------------
-- This record type is used for interrupt entries
type intr_entry_t is record
intr_vector : intr_vector_id_t; -- this field is referenced by Ada rts
prio : priority; -- this field is referenced by Ada rts
end record;
type a_intr_entry_t is access intr_entry_t;
function to_a_intr_entry_t is
new unchecked_conversion(address, a_intr_entry_t);
function to_address is
new unchecked_conversion(a_intr_entry_t, address);
--------------------------------------------------------------------------
-- intr_entry_t: init subprograms
--------------------------------------------------------------------------
procedure intr_entry_init(
intr_entry : a_intr_entry_t;
intr_vector : intr_vector_id_t;
prio : priority := priority'last);
function intr_entry_init(
intr_entry : a_intr_entry_t;
intr_vector : intr_vector_id_t;
prio : priority := priority'last) return address;
function intr_entry_init(
-- does an implicit "intr_entry: a_intr_entry_t := new intr_entry_t;"
intr_vector : intr_vector_id_t;
prio : priority := priority'last) return address;
pragma inline_only(intr_entry_init);
--------------------------------------------------------------------------
-- Condition variable and mutex types
--------------------------------------------------------------------------
subtype cond_attr_t is krn_defs.cond_attr_t;
subtype a_cond_attr_t is krn_defs.a_cond_attr_t;
function to_a_cond_attr_t is
new unchecked_conversion(address, a_cond_attr_t);
function to_address is
new unchecked_conversion(a_cond_attr_t, address);
subtype cond_t is krn_defs.cond_t;
subtype a_cond_t is krn_defs.a_cond_t;
function to_a_cond_t is new unchecked_conversion(address, a_cond_t);
function to_address is new unchecked_conversion(a_cond_t, address);
subtype mutex_attr_t is krn_defs.mutex_attr_t;
subtype a_mutex_attr_t is krn_defs.a_mutex_attr_t;
function to_a_mutex_attr_t is
new unchecked_conversion(address, a_mutex_attr_t);
function to_address is
new unchecked_conversion(a_mutex_attr_t, address);
subtype intr_attr_t is krn_defs.intr_attr_t;
subtype a_intr_attr_t is krn_defs.a_intr_attr_t;
function to_a_intr_attr_t is new unchecked_conversion(address,
a_intr_attr_t);
function to_a_intr_attr_t is new unchecked_conversion(a_mutex_attr_t,
a_intr_attr_t);
function to_a_mutex_attr_t is
new unchecked_conversion(a_intr_attr_t, a_mutex_attr_t);
function to_address is
new unchecked_conversion(a_intr_attr_t, address);
subtype prio_ceiling_attr_t is krn_defs.prio_ceiling_attr_t;
subtype a_prio_ceiling_attr_t is krn_defs.a_prio_ceiling_attr_t;
function to_a_prio_ceiling_attr_t is new unchecked_conversion(address,
a_prio_ceiling_attr_t);
function to_a_prio_ceiling_attr_t is
new unchecked_conversion(a_mutex_attr_t, a_prio_ceiling_attr_t);
function to_a_mutex_attr_t is
new unchecked_conversion(a_prio_ceiling_attr_t, a_mutex_attr_t);
function to_address is
new unchecked_conversion(a_prio_ceiling_attr_t, address);
subtype mutex_t is krn_defs.mutex_t;
subtype a_mutex_t is krn_defs.a_mutex_t;
function to_a_mutex_t is new unchecked_conversion(address, a_mutex_t);
function to_address is new unchecked_conversion(a_mutex_t, address);
subtype intr_mutex_t is krn_defs.intr_mutex_t;
subtype a_intr_mutex_t is krn_defs.a_intr_mutex_t;
function to_a_intr_mutex_t is
new unchecked_conversion(a_mutex_t, a_intr_mutex_t);
function to_a_mutex_t is
new unchecked_conversion(a_intr_mutex_t, a_mutex_t);
function to_address is
new unchecked_conversion(a_intr_mutex_t, address);
--------------------------------------------------------------------------
-- cond_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_COND_ATTR return a_cond_attr_t;
pragma inline_only(DEFAULT_COND_ATTR);
procedure fifo_cond_attr_init(
attr : a_cond_attr_t);
function fifo_cond_attr_init(
attr : a_cond_attr_t) return a_cond_attr_t;
function fifo_cond_attr_init return a_cond_attr_t;
-- does an implicit "attr: a_cond_attr_t := new cond_attr_t;"
pragma inline_only(fifo_cond_attr_init);
procedure prio_cond_attr_init(
attr : a_cond_attr_t);
function prio_cond_attr_init(
attr : a_cond_attr_t) return a_cond_attr_t;
function prio_cond_attr_init return a_cond_attr_t;
-- does an implicit "attr: a_cond_attr_t := new cond_attr_t;"
pragma inline_only(prio_cond_attr_init);
--------------------------------------------------------------------------
-- mutex_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_MUTEX_ATTR return a_mutex_attr_t;
function DEFAULT_MUTEX_ATTR return address;
pragma inline_only(DEFAULT_MUTEX_ATTR);
function DEFAULT_INTR_ATTR return a_mutex_attr_t;
function DEFAULT_INTR_ATTR return address;
pragma inline_only(DEFAULT_INTR_ATTR);
procedure fifo_mutex_attr_init(
attr : a_mutex_attr_t);
function fifo_mutex_attr_init(
attr : a_mutex_attr_t) return a_mutex_attr_t;
function fifo_mutex_attr_init(
attr : a_mutex_attr_t) return address;
function fifo_mutex_attr_init return a_mutex_attr_t;
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
function fifo_mutex_attr_init return address;
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
pragma inline_only(fifo_mutex_attr_init);
procedure prio_mutex_attr_init(
attr : a_mutex_attr_t);
function prio_mutex_attr_init(
attr : a_mutex_attr_t) return a_mutex_attr_t;
function prio_mutex_attr_init(
attr : a_mutex_attr_t) return address;
function prio_mutex_attr_init return a_mutex_attr_t;
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
function prio_mutex_attr_init return address;
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
pragma inline_only(prio_mutex_attr_init);
procedure prio_inherit_mutex_attr_init(
attr : a_mutex_attr_t);
function prio_inherit_mutex_attr_init(
attr : a_mutex_attr_t) return a_mutex_attr_t;
function prio_inherit_mutex_attr_init(
attr : a_mutex_attr_t) return address;
function prio_inherit_mutex_attr_init return a_mutex_attr_t;
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
function prio_inherit_mutex_attr_init return address;
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
pragma inline_only(prio_inherit_mutex_attr_init);
-- If the archive linked by the application doesn't support
-- priority inheritance or if the CIFO
-- "pragma SET_PRIORITY_INHERITANCE_CRITERIA" isn't defined in
-- the main procedure, then, raises PROGRAM_ERROR exception.
--
-- The priority inheritance protocol is only supported in the CIFO
-- add-on product.
procedure prio_ceiling_mutex_attr_init(
attr : a_mutex_attr_t;
ceiling_prio : priority := priority'last);
function prio_ceiling_mutex_attr_init(
attr : a_mutex_attr_t;
ceiling_prio : priority := priority'last) return a_mutex_attr_t;
function prio_ceiling_mutex_attr_init(
attr : a_mutex_attr_t;
ceiling_prio : priority := priority'last) return address;
function prio_ceiling_mutex_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
ceiling_prio : priority := priority'last) return a_mutex_attr_t;
function prio_ceiling_mutex_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
ceiling_prio : priority := priority'last) return address;
pragma inline_only(prio_ceiling_mutex_attr_init);
-- If the archive linked by the application doesn't support
-- the priority ceiling protocol, then, raises PROGRAM_ERROR exception.
--
-- The priority ceiling protocol is only supported in the CIFO
-- add-on product.
procedure intr_attr_init(
attr : a_mutex_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS);
function intr_attr_init(
attr : a_mutex_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mutex_attr_t;
function intr_attr_init(
attr : a_mutex_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return address;
function intr_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mutex_attr_t;
function intr_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return address;
pragma inline_only(intr_attr_init);
--------------------------------------------------------------------------
-- Task attribute types
--------------------------------------------------------------------------
-- This record type is used for passing OS specific task information
-- at task create.
--
-- Note: the priority in the task_attr_t record takes precedence over
-- that specified by "pragma priority()".
--
-- The prio and cond_attr_address fields are referenced by the Ada rts.
--
-- The mutex_attr_address is the address of a mutex_attr_t record.
-- The cond_attr_address is the address of a cond_attr_t record. Setting
-- these fields to NO_ADDR selects the default values specified
-- by the DEFAULT_TASK_ATTRIBUTES parameter in v_usr_conf's
-- configuration_table.
--
-- The sporadic_attr_address is the address of a sporadic_attr_t
-- record. Setting sporadic_attr_address to NO_ADDR selects the
-- normal, non-sporadic task. A sporadic task is only supported
-- in the CIFO add-on product.
type task_attr_t is record
prio : priority;
sporadic_attr_address : address := NO_ADDR;
mutex_attr_address : address := NO_ADDR;
cond_attr_address : address := NO_ADDR;
end record;
type a_task_attr_t is access task_attr_t;
function to_a_task_attr_t is
new unchecked_conversion(address, a_task_attr_t);
function to_address is
new unchecked_conversion(a_task_attr_t, address);
-- Sporadic task attributes.
--
-- If the Ada task is to be sporadic, then,
-- the sporadic_attr_address field in the task_attr_t record
-- points to a sporadic_attr_t record.
--
-- Here's an overview of the fields in the sporadic_attr_t record:
--
-- If the available execution capacity is greater than
-- zero, then, the sporadic task's normal Ada priority is used; otherwise,
-- the priority specified by the low_prio field is used.
--
-- The replenish_period field specifies the sporadic task's
-- period. Its the amount of time to wait before the sporadic task's
-- consumed execution time is replenished.
--
-- The initial_budget field specifies the maximum execution time
-- in any sporadic task period. The available execution time is
-- initialized with the initial_budget. When this time is totally consumed,
-- the task's priority is lowered to low_prio until its replenished.
--
-- The last two fields, min_replenishment and replenishment_count,
-- control how replenishments may be combined so as to reduce the number
-- of replenishment timer events. If the previous replenishment amount
-- is less than min_replenishment, then, the current replenishment
-- amount is added to the previous replenishment amount and the time of
-- the previous replenishment is set to the time of the current
-- replenishment. If we already have replenishment_count replenishments,
-- then, the current replenishment amount is added to the previous
-- replenishment amount and the time of the previous
-- replenishment is set to the time of the current replenishment.
--
-- Note: sporadic tasks are only supported in the CIFO add-on product.
type sporadic_attr_t is record
low_prio : priority := priority'first;
replenish_period : duration := 10.0;
initial_budget : duration := 2.0;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
end record;
type a_sporadic_attr_t is access sporadic_attr_t;
function to_a_sporadic_attr_t is
new unchecked_conversion(address, a_sporadic_attr_t);
function to_address is
new unchecked_conversion(a_sporadic_attr_t, address);
--------------------------------------------------------------------------
-- task_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_TASK_ATTR return a_task_attr_t;
function DEFAULT_TASK_ATTR return address;
pragma inline_only(DEFAULT_TASK_ATTR);
procedure task_attr_init(
task_attr : a_task_attr_t;
prio : priority := priority'first;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null);
function task_attr_init(
task_attr : a_task_attr_t;
prio : priority := priority'first;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address;
function task_attr_init(
-- does an implicit "task_attr: a_task_attr_t := new task_attr_t;"
prio : priority := priority'first;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address;
procedure sporadic_task_attr_init(
task_attr : a_task_attr_t;
sporadic_attr : a_sporadic_attr_t;
prio : priority;
low_prio : priority;
replenish_period : duration;
initial_budget : duration;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null);
function sporadic_task_attr_init(
task_attr : a_task_attr_t;
sporadic_attr : a_sporadic_attr_t;
prio : priority;
low_prio : priority;
replenish_period : duration;
initial_budget : duration;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address;
function sporadic_task_attr_init(
-- does an implicit "task_attr: a_task_attr_t := new task_attr_t;"
-- does an implicit "sporadic_attr: a_sporadic_attr_t :=
-- new sporadic_attr_t;"
prio : priority;
low_prio : priority;
replenish_period : duration;
initial_budget : duration;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address;
pragma inline_only(sporadic_task_attr_init);
-- If the CIFO add-on product archive isn't linked by the application
-- program, then, raises the PROGRAM_ERROR exception.
--------------------------------------------------------------------------
-- Semaphore types
--------------------------------------------------------------------------
subtype semaphore_t is krn_defs.semaphore_t;
subtype a_semaphore_t is krn_defs.a_semaphore_t;
function to_a_semaphore_t is new unchecked_conversion(address,
a_semaphore_t);
function to_address is new unchecked_conversion(a_semaphore_t, address);
subtype semaphore_state_t is krn_defs.test_and_set_t;
SEMAPHORE_FULL : constant semaphore_state_t := krn_defs.TEST_AND_SET_FALSE;
SEMAPHORE_EMPTY : constant semaphore_state_t := krn_defs.TEST_AND_SET_TRUE;
subtype semaphore_attr_t is krn_defs.semaphore_attr_t;
subtype a_semaphore_attr_t is krn_defs.a_semaphore_attr_t;
function to_a_semaphore_attr_t is new unchecked_conversion(address,
a_semaphore_attr_t);
function to_address is new unchecked_conversion(a_semaphore_attr_t,
address);
--------------------------------------------------------------------------
-- semaphore_attr_t: DEFAULT subprogram
--------------------------------------------------------------------------
function DEFAULT_SEMAPHORE_ATTR return a_semaphore_attr_t;
pragma inline_only(DEFAULT_SEMAPHORE_ATTR);
--------------------------------------------------------------------------
-- Count semaphore types (VADS EXEC augmentation)
--------------------------------------------------------------------------
subtype count_semaphore_t is krn_defs.count_semaphore_t;
subtype a_count_semaphore_t is krn_defs.a_count_semaphore_t;
function to_a_count_semaphore_t is new unchecked_conversion(address,
a_count_semaphore_t);
function to_address is new unchecked_conversion(a_count_semaphore_t,
address);
subtype count_semaphore_attr_t is ada_krn_defs.mutex_attr_t;
subtype a_count_semaphore_attr_t is ada_krn_defs.a_mutex_attr_t;
subtype count_intr_attr_t is ada_krn_defs.intr_attr_t;
subtype a_count_intr_attr_t is ada_krn_defs.a_intr_attr_t;
function to_a_count_semaphore_attr_t is new unchecked_conversion(address,
a_count_semaphore_attr_t);
function to_a_count_intr_attr_t is new unchecked_conversion(address,
a_count_intr_attr_t);
function to_a_count_intr_attr_t is new unchecked_conversion(
a_count_semaphore_attr_t, a_count_intr_attr_t);
function to_a_count_semaphore_attr_t is
new unchecked_conversion(a_count_intr_attr_t, a_count_semaphore_attr_t);
--------------------------------------------------------------------------
-- count_semaphore_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_COUNT_SEMAPHORE_ATTR return a_count_semaphore_attr_t;
pragma inline_only(DEFAULT_COUNT_SEMAPHORE_ATTR);
function DEFAULT_COUNT_INTR_ATTR return a_count_semaphore_attr_t;
pragma inline_only(DEFAULT_COUNT_INTR_ATTR);
procedure count_intr_attr_init(
attr : a_count_semaphore_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS);
function count_intr_attr_init(
attr : a_count_semaphore_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_count_semaphore_attr_t;
function count_intr_attr_init(
-- does an implicit
-- "attr: a_count_semaphore_attr_t := new count_semaphore_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_count_semaphore_attr_t;
pragma inline_only(count_intr_attr_init);
--------------------------------------------------------------------------
-- Mailbox types (VADS EXEC augmentation)
--------------------------------------------------------------------------
subtype mailbox_t is krn_defs.mailbox_t;
subtype a_mailbox_t is krn_defs.a_mailbox_t;
function to_a_mailbox_t is new unchecked_conversion(address,
a_mailbox_t);
function to_address is new unchecked_conversion(a_mailbox_t,
address);
subtype mailbox_attr_t is ada_krn_defs.mutex_attr_t;
subtype a_mailbox_attr_t is ada_krn_defs.a_mutex_attr_t;
subtype mailbox_intr_attr_t is ada_krn_defs.intr_attr_t;
subtype a_mailbox_intr_attr_t is ada_krn_defs.a_intr_attr_t;
function to_a_mailbox_attr_t is new unchecked_conversion(address,
a_mailbox_attr_t);
function to_a_mailbox_intr_attr_t is new unchecked_conversion(address,
a_mailbox_intr_attr_t);
function to_a_mailbox_intr_attr_t is new unchecked_conversion(
a_mailbox_attr_t, a_mailbox_intr_attr_t);
function to_a_mailbox_attr_t is
new unchecked_conversion(a_mailbox_intr_attr_t, a_mailbox_attr_t);
--------------------------------------------------------------------------
-- mailbox_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_MAILBOX_ATTR return a_mailbox_attr_t;
pragma inline_only(DEFAULT_MAILBOX_ATTR);
function DEFAULT_MAILBOX_INTR_ATTR return a_mailbox_attr_t;
pragma inline_only(DEFAULT_MAILBOX_INTR_ATTR);
procedure mailbox_intr_attr_init(
attr : a_mailbox_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS);
function mailbox_intr_attr_init(
attr : a_mailbox_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mailbox_attr_t;
function mailbox_intr_attr_init(
-- does an implicit
-- "attr: a_mailbox_attr_t := new mailbox_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mailbox_attr_t;
pragma inline_only(mailbox_intr_attr_init);
--------------------------------------------------------------------------
-- Callout and task storage types (VADS EXEC augmentation)
--------------------------------------------------------------------------
-- The Ada RTS assumes callout_event_t is an enumeration type
-- supporting the following program exit events as a minimum:
-- type callout_event_t is (
-- EXIT_EVENT,
-- UNEXPECTED_EXIT_EVENT
-- );
-- Callout events
type callout_event_t is new krn_defs.callout_event_t;
-- Id for accessing user defined storage in the task control block
subtype task_storage_id is krn_defs.task_storage_id;
NO_TASK_STORAGE_ID: constant task_storage_id :=
krn_defs.NO_TASK_STORAGE_ID;
--------------------------------------------------------------------------
-- Name service status types (VADS EXEC augmentation)
--------------------------------------------------------------------------
-- Status returned by ada_krn_i.name_bind().
type name_bind_status_t is (
NAME_BIND_OK,
NAME_BIND_NOT_SUPPORTED,
NAME_BIND_BAD_ARG,
NAME_BIND_OUT_OF_MEMORY,
NAME_BIND_ALREADY_BOUND);
for name_bind_status_t'size use integer'size;
-- Status returned by ada_krn_i.name_resolve().
type name_resolve_status_t is (
NAME_RESOLVE_OK,
NAME_RESOLVE_NOT_SUPPORTED,
NAME_RESOLVE_BAD_ARG,
NAME_RESOLVE_TIMED_OUT,
NAME_RESOLVE_FAILED);
for name_resolve_status_t'size use integer'size;
end ada_krn_defs;
package body ada_krn_defs is
priority_inheritance_enabled: boolean;
pragma interface_name(priority_inheritance_enabled,
"__PRIORITY_INHERITANCE_ENABLED");
priority_ceiling_enabled: boolean;
pragma interface_name(priority_ceiling_enabled,
"__PRIORITY_CEILING_ENABLED");
sporadic_task_enabled: boolean;
pragma interface_name(sporadic_task_enabled, "__SPORADIC_TASK_ENABLED");
function NO_KRN_TASK_ID return krn_task_id is
begin
return null;
end;
function NO_KRN_PROGRAM_ID return krn_program_id is
begin
return null;
end;
--------------------------------------------------------------------------
-- intr_entry_t: init subprograms
--------------------------------------------------------------------------
procedure intr_entry_init(
intr_entry : a_intr_entry_t;
intr_vector : intr_vector_id_t;
prio : priority := priority'last)
is
begin
intr_entry.all := (
intr_vector => intr_vector,
prio => prio
);
end;
function intr_entry_init(
intr_entry : a_intr_entry_t;
intr_vector : intr_vector_id_t;
prio : priority := priority'last) return address
is
begin
intr_entry.all := (
intr_vector => intr_vector,
prio => prio
);
return to_address(intr_entry);
end;
function intr_entry_init(
-- does an implicit "intr_entry: a_intr_entry_t := new intr_entry_t;"
intr_vector : intr_vector_id_t;
prio : priority := priority'last) return address
is
intr_entry : a_intr_entry_t := new intr_entry_t'(
intr_vector => intr_vector,
prio => prio
);
begin
return to_address(intr_entry);
end;
--------------------------------------------------------------------------
-- cond_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_COND_ATTR return a_cond_attr_t is
begin
return null;
end;
procedure fifo_cond_attr_init(
attr : a_cond_attr_t)
is
begin
attr.all := (rec_type => krn_defs.R_FIFO_COND_ATTR);
end;
function fifo_cond_attr_init(
attr : a_cond_attr_t) return a_cond_attr_t
is
begin
attr.all := (rec_type => krn_defs.R_FIFO_COND_ATTR);
return attr;
end;
function fifo_cond_attr_init return a_cond_attr_t
-- does an implicit "attr: a_cond_attr_t := new cond_attr_t;"
is
attr : a_cond_attr_t := new cond_attr_t;
begin
attr.all := (rec_type => krn_defs.R_FIFO_COND_ATTR);
return attr;
end;
procedure prio_cond_attr_init(
attr : a_cond_attr_t)
is
begin
attr.all := (rec_type => krn_defs.R_PRIO_COND_ATTR);
end;
function prio_cond_attr_init(
attr : a_cond_attr_t) return a_cond_attr_t
is
begin
attr.all := (rec_type => krn_defs.R_PRIO_COND_ATTR);
return attr;
end;
function prio_cond_attr_init return a_cond_attr_t
-- does an implicit "attr: a_cond_attr_t := new cond_attr_t;"
is
attr : a_cond_attr_t := new cond_attr_t;
begin
attr.all := (rec_type => krn_defs.R_PRIO_COND_ATTR);
return attr;
end;
--------------------------------------------------------------------------
-- mutex_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_MUTEX_ATTR return a_mutex_attr_t is
begin
return null;
end;
function DEFAULT_MUTEX_ATTR return address is
begin
return NO_ADDR;
end;
function DEFAULT_INTR_ATTR return a_mutex_attr_t is
begin
return to_a_mutex_attr_t(memory_address(1));
end;
function DEFAULT_INTR_ATTR return address is
begin
return memory_address(1);
end;
procedure fifo_mutex_attr_init(
attr : a_mutex_attr_t)
is
begin
attr.rec_type := krn_defs.R_FIFO_MUTEX_ATTR;
end;
function fifo_mutex_attr_init(
attr : a_mutex_attr_t) return a_mutex_attr_t
is
begin
attr.rec_type := krn_defs.R_FIFO_MUTEX_ATTR;
return attr;
end;
function fifo_mutex_attr_init(
attr : a_mutex_attr_t) return address
is
begin
attr.rec_type := krn_defs.R_FIFO_MUTEX_ATTR;
return to_address(attr);
end;
function fifo_mutex_attr_init return a_mutex_attr_t
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
is
attr : a_mutex_attr_t := new mutex_attr_t;
begin
attr.rec_type := krn_defs.R_FIFO_MUTEX_ATTR;
return attr;
end;
function fifo_mutex_attr_init return address
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
is
attr : a_mutex_attr_t := new mutex_attr_t;
begin
attr.rec_type := krn_defs.R_FIFO_MUTEX_ATTR;
return to_address(attr);
end;
procedure prio_mutex_attr_init(
attr : a_mutex_attr_t)
is
begin
attr.rec_type := krn_defs.R_PRIO_MUTEX_ATTR;
end;
function prio_mutex_attr_init(
attr : a_mutex_attr_t) return a_mutex_attr_t
is
begin
attr.rec_type := krn_defs.R_PRIO_MUTEX_ATTR;
return attr;
end;
function prio_mutex_attr_init(
attr : a_mutex_attr_t) return address
is
begin
attr.rec_type := krn_defs.R_PRIO_MUTEX_ATTR;
return to_address(attr);
end;
function prio_mutex_attr_init return a_mutex_attr_t
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
is
attr : a_mutex_attr_t := new mutex_attr_t;
begin
attr.rec_type := krn_defs.R_PRIO_MUTEX_ATTR;
return attr;
end;
function prio_mutex_attr_init return address
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
is
attr : a_mutex_attr_t := new mutex_attr_t;
begin
attr.rec_type := krn_defs.R_PRIO_MUTEX_ATTR;
return to_address(attr);
end;
procedure prio_inherit_mutex_attr_init(
attr : a_mutex_attr_t)
is
begin
if not priority_inheritance_enabled then
raise PROGRAM_ERROR;
end if;
attr.rec_type := krn_defs.R_PRIO_INHERIT_MUTEX_ATTR;
end;
function prio_inherit_mutex_attr_init(
attr : a_mutex_attr_t) return a_mutex_attr_t
is
begin
if not priority_inheritance_enabled then
raise PROGRAM_ERROR;
end if;
attr.rec_type := krn_defs.R_PRIO_INHERIT_MUTEX_ATTR;
return attr;
end;
function prio_inherit_mutex_attr_init(
attr : a_mutex_attr_t) return address
is
begin
if not priority_inheritance_enabled then
raise PROGRAM_ERROR;
end if;
attr.rec_type := krn_defs.R_PRIO_INHERIT_MUTEX_ATTR;
return to_address(attr);
end;
function prio_inherit_mutex_attr_init return a_mutex_attr_t
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
is
attr: a_mutex_attr_t;
begin
if not priority_inheritance_enabled then
raise PROGRAM_ERROR;
end if;
attr := new mutex_attr_t;
attr.rec_type := krn_defs.R_PRIO_INHERIT_MUTEX_ATTR;
return attr;
end;
function prio_inherit_mutex_attr_init return address
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
is
attr: a_mutex_attr_t;
begin
if not priority_inheritance_enabled then
raise PROGRAM_ERROR;
end if;
attr := new mutex_attr_t;
attr.rec_type := krn_defs.R_PRIO_INHERIT_MUTEX_ATTR;
return to_address(attr);
end;
procedure prio_ceiling_mutex_attr_init(
attr : a_mutex_attr_t;
ceiling_prio : priority := priority'last)
is
begin
if not priority_ceiling_enabled then
raise PROGRAM_ERROR;
end if;
to_a_prio_ceiling_attr_t(attr).all := (
rec_type => krn_defs.R_PRIO_CEILING_MUTEX_ATTR,
ceiling_prio => ceiling_prio
);
end;
function prio_ceiling_mutex_attr_init(
attr : a_mutex_attr_t;
ceiling_prio : priority := priority'last) return a_mutex_attr_t
is
begin
if not priority_ceiling_enabled then
raise PROGRAM_ERROR;
end if;
to_a_prio_ceiling_attr_t(attr).all := (
rec_type => krn_defs.R_PRIO_CEILING_MUTEX_ATTR,
ceiling_prio => ceiling_prio
);
return attr;
end;
function prio_ceiling_mutex_attr_init(
attr : a_mutex_attr_t;
ceiling_prio : priority := priority'last) return address
is
begin
if not priority_ceiling_enabled then
raise PROGRAM_ERROR;
end if;
to_a_prio_ceiling_attr_t(attr).all := (
rec_type => krn_defs.R_PRIO_CEILING_MUTEX_ATTR,
ceiling_prio => ceiling_prio
);
return to_address(attr);
end;
function prio_ceiling_mutex_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
ceiling_prio : priority := priority'last) return a_mutex_attr_t
is
attr: a_mutex_attr_t;
begin
if not priority_ceiling_enabled then
raise PROGRAM_ERROR;
end if;
attr := new mutex_attr_t;
to_a_prio_ceiling_attr_t(attr).all := (
rec_type => krn_defs.R_PRIO_CEILING_MUTEX_ATTR,
ceiling_prio => ceiling_prio
);
return attr;
end;
function prio_ceiling_mutex_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
ceiling_prio : priority := priority'last) return address
is
attr: a_mutex_attr_t;
begin
if not priority_ceiling_enabled then
raise PROGRAM_ERROR;
end if;
attr := new mutex_attr_t;
to_a_prio_ceiling_attr_t(attr).all := (
rec_type => krn_defs.R_PRIO_CEILING_MUTEX_ATTR,
ceiling_prio => ceiling_prio
);
return to_address(attr);
end;
procedure intr_attr_init(
attr : a_mutex_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
is
begin
to_a_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
end;
function intr_attr_init(
attr : a_mutex_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mutex_attr_t
is
begin
to_a_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return attr;
end;
function intr_attr_init(
attr : a_mutex_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return address
is
begin
to_a_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return to_address(attr);
end;
function intr_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mutex_attr_t
is
attr: a_mutex_attr_t;
begin
attr := new mutex_attr_t;
to_a_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return attr;
end;
function intr_attr_init(
-- does an implicit "attr: a_mutex_attr_t := new mutex_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return address
is
attr: a_mutex_attr_t;
begin
attr := new mutex_attr_t;
to_a_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return to_address(attr);
end;
--------------------------------------------------------------------------
-- task_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_TASK_ATTR return a_task_attr_t is
begin
return null;
end;
function DEFAULT_TASK_ATTR return address is
begin
return NO_ADDR;
end;
procedure task_attr_init(
task_attr : a_task_attr_t;
prio : priority := priority'first;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null)
is
begin
task_attr.all := (
prio => prio,
sporadic_attr_address => NO_ADDR,
mutex_attr_address => to_address(mutex_attr),
cond_attr_address => to_address(cond_attr)
);
end;
function task_attr_init(
task_attr : a_task_attr_t;
prio : priority := priority'first;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address
is
begin
task_attr.all := (
prio => prio,
sporadic_attr_address => NO_ADDR,
mutex_attr_address => to_address(mutex_attr),
cond_attr_address => to_address(cond_attr)
);
return to_address(task_attr);
end;
function task_attr_init(
-- does an implicit "task_attr: a_task_attr_t := new task_attr_t;"
prio : priority := priority'first;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address
is
task_attr : a_task_attr_t := new task_attr_t'(
prio => prio,
sporadic_attr_address => NO_ADDR,
mutex_attr_address => to_address(mutex_attr),
cond_attr_address => to_address(cond_attr)
);
begin
return to_address(task_attr);
end;
procedure sporadic_task_attr_init(
task_attr : a_task_attr_t;
sporadic_attr : a_sporadic_attr_t;
prio : priority;
low_prio : priority;
replenish_period : duration;
initial_budget : duration;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null)
is
begin
if not sporadic_task_enabled then
raise PROGRAM_ERROR;
end if;
task_attr.all := (
prio => prio,
sporadic_attr_address => to_address(sporadic_attr),
mutex_attr_address => to_address(mutex_attr),
cond_attr_address => to_address(cond_attr)
);
sporadic_attr.all := (
low_prio => low_prio,
replenish_period => replenish_period,
initial_budget => initial_budget,
min_replenishment => min_replenishment,
replenishment_count => replenishment_count
);
end;
function sporadic_task_attr_init(
task_attr : a_task_attr_t;
sporadic_attr : a_sporadic_attr_t;
prio : priority;
low_prio : priority;
replenish_period : duration;
initial_budget : duration;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address
is
begin
if not sporadic_task_enabled then
raise PROGRAM_ERROR;
end if;
task_attr.all := (
prio => prio,
sporadic_attr_address => to_address(sporadic_attr),
mutex_attr_address => to_address(mutex_attr),
cond_attr_address => to_address(cond_attr)
);
sporadic_attr.all := (
low_prio => low_prio,
replenish_period => replenish_period,
initial_budget => initial_budget,
min_replenishment => min_replenishment,
replenishment_count => replenishment_count
);
return to_address(task_attr);
end;
function sporadic_task_attr_init(
-- does an implicit "task_attr: a_task_attr_t := new task_attr_t;"
-- does an implicit "sporadic_attr: a_sporadic_attr_t :=
-- new sporadic_attr_t;"
prio : priority;
low_prio : priority;
replenish_period : duration;
initial_budget : duration;
min_replenishment : duration := 0.0;
replenishment_count : natural := 2;
mutex_attr : a_mutex_attr_t := null;
cond_attr : a_cond_attr_t := null) return address
is
task_attr : a_task_attr_t;
sporadic_attr : a_sporadic_attr_t;
begin
if not sporadic_task_enabled then
raise PROGRAM_ERROR;
end if;
task_attr := new task_attr_t;
sporadic_attr := new sporadic_attr_t;
task_attr.all := (
prio => prio,
sporadic_attr_address => to_address(sporadic_attr),
mutex_attr_address => to_address(mutex_attr),
cond_attr_address => to_address(cond_attr)
);
sporadic_attr.all := (
low_prio => low_prio,
replenish_period => replenish_period,
initial_budget => initial_budget,
min_replenishment => min_replenishment,
replenishment_count => replenishment_count
);
return to_address(task_attr);
end;
--------------------------------------------------------------------------
-- semaphore_attr_t: DEFAULT subprogram
--------------------------------------------------------------------------
function DEFAULT_SEMAPHORE_ATTR return a_semaphore_attr_t is
begin
return null;
end;
--------------------------------------------------------------------------
-- count_semaphore_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_COUNT_SEMAPHORE_ATTR return a_count_semaphore_attr_t is
begin
return null;
end;
function DEFAULT_COUNT_INTR_ATTR return a_count_semaphore_attr_t is
begin
return to_a_count_semaphore_attr_t(memory_address(1));
end;
procedure count_intr_attr_init(
attr : a_count_semaphore_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
is
begin
to_a_count_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
end;
function count_intr_attr_init(
attr : a_count_semaphore_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_count_semaphore_attr_t
is
begin
to_a_count_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return attr;
end;
function count_intr_attr_init(
-- does an implicit
-- "attr: a_count_semaphore_attr_t := new count_semaphore_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_count_semaphore_attr_t
is
attr: a_count_semaphore_attr_t;
begin
attr := new count_semaphore_attr_t;
to_a_count_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return attr;
end;
--------------------------------------------------------------------------
-- mailbox_attr_t: DEFAULT and init subprograms
--------------------------------------------------------------------------
function DEFAULT_MAILBOX_ATTR return a_mailbox_attr_t is
begin
return null;
end;
function DEFAULT_MAILBOX_INTR_ATTR return a_mailbox_attr_t is
begin
return to_a_mailbox_attr_t(memory_address(1));
end;
procedure mailbox_intr_attr_init(
attr : a_mailbox_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
is
begin
to_a_mailbox_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
end;
function mailbox_intr_attr_init(
attr : a_mailbox_attr_t;
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mailbox_attr_t
is
begin
to_a_mailbox_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return attr;
end;
function mailbox_intr_attr_init(
-- does an implicit
-- "attr: a_mailbox_attr_t := new mailbox_attr_t;"
disable_status : intr_status_t := DISABLE_INTR_STATUS)
return a_mailbox_attr_t
is
attr: a_mailbox_attr_t;
begin
attr := new mailbox_attr_t;
to_a_mailbox_intr_attr_t(attr).all := (
rec_type => krn_defs.R_INTR_MUTEX_ATTR,
disable_status => disable_status
);
return attr;
end;
end