|
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 - 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