|
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: 41088 (0xa080)
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«
└─⟦972e89375⟧
└─⟦this⟧
-- Copyright 1991 Verdix Corporation
with system; use system;
with ada_krn_defs; use ada_krn_defs;
with link_block;
package ada_krn_i is
pragma suppress(ALL_CHECKS);
pragma suppress(EXCEPTION_TABLES);
pragma not_elaborated;
pragma local_access;
--------------------------------------------------------------------------
-- Interface to the Ada kernel services for VADS_MICRO/MC68020
--------------------------------------------------------------------------
-------------------------------------------------------------------------
-- Program services
-------------------------------------------------------------------------
--
-- Note: type program_id is defined in system. Its the address of
-- the program's Ada PCB (Program Control Block).
--
-- If program_init returns, then, the program is ready to exit and
-- it returns the exit status.
function program_init(
usr_link_block : link_block.a_link_block_t;
-- link_block has pointers to stack_limit, raise_exception,
-- predefined Ada exceptions, configuration table.
init_continue : address;
-- If we create a new task for the main program, start
-- it at init_continue and return when the program is
-- ready to exit. Otherwise, simply call init_continue and
-- never return.
--
-- init_continue has the following interface:
--
-- procedure init_continue(prg: program_id);
--
Ada_tcb_size : natural;
idle_callout : address;
-- Decides when it is time to exit
--
-- The idle_callout has the following call interface:
--
-- procedure idle_callout(prg: program_id);
--
idle_stack_size : natural;
Ada_pcb_size : natural;
-- Size of Ada's program control block
init_Ada_pcb : address;
-- Points to the initial values to be copied into the
-- Ada program control block. The Ada pcb must be initialized
-- from here before init_continue or idle_callout is called.
-- Values for the following parameters were extracted from the
-- user's configuration table or were set by pragmas in the
-- main procedure.
main_stack_size : natural;
main_prio : priority;
exception_stack_size : natural;
priority_inheritance_enabled: boolean) return integer;
pragma interface(ADA, program_init);
pragma interface_name(program_init, "__ADA_PROGRAM_INIT");
procedure program_exit(status: integer);
pragma interface(ADA, program_exit);
pragma interface_name(program_exit, "__ADA_PROGRAM_EXIT");
procedure program_diagnostic(s: string);
pragma interface(ADA, program_diagnostic);
pragma interface_name(program_diagnostic, "__ADA_PROGRAM_DIAGNOSTIC");
procedure panic_exit(
s : string;
status : integer := -1);
pragma interface(ADA, panic_exit);
pragma interface_name(panic_exit, "__ADA_PANIC_EXIT");
-- Returns TRUE if the program has already been started
function program_is_active(usr_link_block: link_block.a_link_block_t)
return boolean;
pragma interface(ADA, program_is_active);
pragma interface_name(program_is_active, "__ADA_PROGRAM_IS_ACTIVE");
function program_self return program_id;
pragma interface(ADA, program_self);
pragma interface_name(program_self, "__ADA_PROGRAM_SELF");
-------------------------------------------------------------------------
-- Program services (VADS EXEC augmentation)
-------------------------------------------------------------------------
function program_get(tsk: task_id) return program_id;
pragma interface(ADA, program_get);
pragma interface_name(program_get, "__ADA_PROGRAM_GET");
-- Returns NO_PROGRAM_ID if not supported or unable to start program
function program_start(
usr_link_block : link_block.a_link_block_t;
key : address;
terminate_callout : address) return program_id;
pragma interface(ADA, program_start);
pragma interface_name(program_start, "__ADA_PROGRAM_START");
-- This procedure is called to mark the current program as a
-- server program containing procedures called via
-- ada_krn_i.program_inter_call().
--
-- A server program has the following attributes:
-- - Its automatically terminated when no non-server program is
-- active.
-- - Its inhibited from exiting prematurely or being terminated.
-- - When its main procedure returns (at end of server's elaboration),
-- the main task's stack is freed and its micro-kernel thread is
-- stopped/freed.
procedure program_set_is_server;
pragma interface(ADA, program_set_is_server);
pragma interface_name(program_set_is_server,
"__ADA_PROGRAM_SET_IS_SERVER");
-- Returns true if the program is a server
function program_is_server(prg: program_id) return boolean;
pragma interface(ADA, program_is_server);
pragma interface_name(program_is_server, "__ADA_PROGRAM_IS_SERVER");
procedure program_terminate(prg: program_id; status: integer);
pragma interface(ADA, program_terminate);
pragma interface_name(program_terminate, "__ADA_PROGRAM_TERMINATE");
function program_get_key(prg: program_id) return address;
pragma interface(ADA, program_get_key);
pragma interface_name(program_get_key, "__ADA_PROGRAM_GET_KEY");
-- Returns NO_PROGRAM_ID if the kernel program isn't also an Ada program
function program_get_Ada_id(krn_prg: krn_program_id) return program_id;
pragma interface(ADA, program_get_Ada_id);
pragma interface_name(program_get_Ada_id, "__ADA_PROGRAM_GET_ADA_ID");
function program_get_krn_id(prg: program_id) return krn_program_id;
pragma interface(ADA, program_get_krn_id);
pragma interface_name(program_get_krn_id, "__ADA_PROGRAM_GET_KRN_ID");
-- Call a procedure in another program.
--
-- Normally, program_inter_call()
-- is used in conjunction with the ada_krn_i.name_bind() and
-- ada_krn_i.name_resolve() services where a name has been bound
-- to the procedure to be called. Also, the program containing
-- the procedure should be marked as a server via
-- ada_krn_i.program_set_is_server().
--
-- program_inter_call()'s arg parameter is passed as the only argument
-- to the called procedure. The called procedure has the following
-- interface:
-- procedure called_proc(arg: address);
-- for called_proc use at proc_addr;
--
-- Before doing the call, the current program is switched.
-- Also, the stack_limit in the program containing the called
-- procedure is switched. Before returning, everything is restored.
--
-- Note: the PROGRAM_SWITCH_EVENT callouts aren't called. The task's
-- parent program isn't switched. The PROGRAM_SWITCH_EVENT callouts
-- are only called when the parent program switches (i.e. when we switch
-- to another task that is in another parent program).
--
-- If the called procedure does any task creates or kernel memory
-- allocations, then, the program containing the called procedure is the
-- parent or owner.
--
-- Ada exceptions can be raised and handled in the called procedure.
-- However, program_inter_call() doesn't handle the propogation of Ada
-- exceptions across inter_program calls. Therefore, the called procedure
-- must have a handler for all possible Ada exceptions. An Ada exception
-- raised in the called procedure can have an outer handler that
-- maps the exception to error status returned to the calling program.
-- The calling program can then, decode the error status and reraise the
-- Ada exception.
--
-- If the proc_prg argument is NO_PROGRAM_ID or program_self(), then,
-- the procedure is called directly without switching the current
-- program or stack_limit. If proc_prg is set to NO_PROGRAM_ID and
-- the called_proc is in another program, then, the called procedure
-- must use "pragma suppress(ALL_CHECKS)" and it can't raise any Ada
-- exceptions. Also, if it calls any kernel services, the calling
-- program will still be the parent and owner of any created objects.
procedure program_inter_call(
proc_prg : program_id;
proc_addr : address;
arg : address);
pragma interface(ADA, program_inter_call);
pragma interface_name(program_inter_call, "__ADA_PROGRAM_INTER_CALL");
-------------------------------------------------------------------------
-- Kernel scheduling services (VADS EXEC augmentation)
-------------------------------------------------------------------------
function kernel_get_time_slicing_enabled return boolean;
pragma interface(ADA, kernel_get_time_slicing_enabled);
pragma interface_name(kernel_get_time_slicing_enabled,
"__ADA_KERNEL_GET_TIME_SLICING_ENABLED");
procedure kernel_set_time_slicing_enabled(new_value: boolean);
pragma interface(ADA, kernel_set_time_slicing_enabled);
pragma interface_name(kernel_set_time_slicing_enabled,
"__ADA_KERNEL_SET_TIME_SLICING_ENABLED");
-------------------------------------------------------------------------
-- Task management services
-------------------------------------------------------------------------
--
-- Note: type task_id is defined in system. Its the address of
-- the task's Ada TCB (Task Control Block).
--
function task_self return task_id;
pragma inline_only(task_self);
procedure task_set_priority(tsk: task_id; prio: priority);
pragma interface(ADA, task_set_priority);
pragma interface_name(task_set_priority, "__ADA_TASK_SET_PRIORITY");
function task_get_priority(tsk: task_id) return priority;
pragma interface(ADA, task_get_priority);
pragma interface_name(task_get_priority, "__ADA_TASK_GET_PRIORITY");
-- Returns NO_TASK_ID if task create is unsuccessful.
function task_create(prio: priority; stack_size: natural;
start: address; task_attr: a_task_attr_t) return task_id;
pragma interface(ADA, task_create);
pragma interface_name(task_create, "__ADA_TASK_CREATE");
--
-- Upon entry/exit: the masters' mutex is locked. This inhibits
-- task_self from being stopped.
-- Returns the task's unique sequence number. This number is >= 0.
--
-- For multiple programs, these sequence numbers are unique
-- across all programs.
function task_get_sequence_number(tsk: task_id) return integer;
pragma interface(ADA, task_get_sequence_number);
pragma interface_name(task_get_sequence_number,
"__ADA_TASK_GET_SEQUENCE_NUMBER");
procedure task_activate(tsk: task_id);
pragma interface(ADA, task_activate);
pragma interface_name(task_activate, "__ADA_TASK_ACTIVATE");
--
-- Upon entry/exit: task_self is locked. This inhibits
-- task_self from being stopped.
function task_stop(tsk: task_id) return boolean;
-- Returns TRUE if the task was stopped.
-- Not applicable to current task.
--
-- Upon entry/exit: the task is locked. Also, masters' mutex is locked.
--
-- NOTE: need to be able to stop a task that has been created
-- but not yet activated. Also need to be able to stop a task
-- that is blocked at a task_wait.
--
-- Implementation guideline: return FALSE if the task can't be stopped
-- asynchronously. At the next Ada synch point (delay, rendezvous, ...)
-- the task will call task_stop_self(). However, must signal a task
-- that is doing a task_wait().
pragma interface(ADA, task_stop);
pragma interface_name(task_stop, "__ADA_TASK_STOP");
procedure task_destroy(tsk: task_id);
pragma interface(ADA, task_destroy);
pragma interface_name(task_destroy, "__ADA_TASK_DESTROY");
-- A previous call has been made to task_stop or task_stop_self for the
-- task to be destroyed.
-- Not applicable to current task
--
-- Upon entry/exit: the task is locked. Also, masters' mutex is locked.
procedure task_stop_self;
pragma interface(ADA, task_stop_self);
pragma interface_name(task_stop_self, "__ADA_TASK_STOP_SELF");
-- A subsequent call will be made to task_destroy from another
-- task.
--
-- Upon entry: the task is locked. It should be unlocked
-- before switching to another task. Note, after the task is
-- unlocked, no fields may be referenced in the task control block.
-- A higher priority task may immediately acquire the task's lock
-- and do a task_destroy().
--
-- No return.
procedure task_destroy_self;
pragma interface(ADA, task_destroy_self);
pragma interface_name(task_destroy_self, "__ADA_TASK_DESTROY_SELF");
--
-- Upon entry the task is locked
--
-- No return.
-------------------------------------------------------------------------
-- Task management services (VADS EXEC augmentation)
-------------------------------------------------------------------------
procedure task_disable_preemption;
pragma interface(ADA, task_disable_preemption);
pragma interface_name(task_disable_preemption,
"__ADA_TASK_DISABLE_PREEMPTION");
procedure task_enable_preemption;
pragma interface(ADA, task_enable_preemption);
pragma interface_name(task_enable_preemption,
"__ADA_TASK_ENABLE_PREEMPTION");
-- Returns NO_TASK_ID if the kernel task isn't also an Ada task
function task_get_Ada_id(krn_tsk: krn_task_id) return task_id;
pragma interface(ADA, task_get_Ada_id);
pragma interface_name(task_get_Ada_id, "__ADA_TASK_GET_ADA_ID");
function task_get_krn_id(tsk: task_id) return krn_task_id;
pragma interface(ADA, task_get_krn_id);
pragma interface_name(task_get_krn_id, "__ADA_TASK_GET_KRN_ID");
-- Returns TRUE if the suspend was sucessful.
function task_suspend(tsk: task_id) return boolean;
pragma interface(ADA, task_suspend);
pragma interface_name(task_suspend, "__ADA_TASK_SUSPEND");
-- Returns TRUE if the resume was sucessful.
function task_resume(tsk: task_id) return boolean;
pragma interface(ADA, task_resume);
pragma interface_name(task_resume, "__ADA_TASK_RESUME");
function task_get_time_slice(tsk: task_id) return duration;
pragma interface(ADA, task_get_time_slice);
pragma interface_name(task_get_time_slice, "__ADA_TASK_GET_TIME_SLICE");
procedure task_set_time_slice(tsk: task_id; new_interval: duration);
pragma interface(ADA, task_set_time_slice);
pragma interface_name(task_set_time_slice, "__ADA_TASK_SET_TIME_SLICE");
-- Returns TRUE if current task is in supervisor state
function task_get_supervisor_state return boolean;
pragma interface(ADA, task_get_supervisor_state);
pragma interface_name(task_get_supervisor_state,
"__ADA_TASK_GET_SUPERVISOR_STATE");
procedure task_enter_supervisor_state;
pragma interface(ADA, task_enter_supervisor_state);
pragma interface_name(task_enter_supervisor_state,
"__ADA_TASK_ENTER_SUPERVISOR_STATE");
procedure task_leave_supervisor_state;
pragma interface(ADA, task_leave_supervisor_state);
pragma interface_name(task_leave_supervisor_state,
"__ADA_TASK_LEAVE_SUPERVISOR_STATE");
-------------------------------------------------------------------------
-- Task masters synchronization services
-------------------------------------------------------------------------
procedure masters_lock;
-- masters' mutex is locked before any task's mutex is locked
-- except for the case where masters_trylock() is called.
--
-- A nested masters_lock() from the same task is erroneous.
pragma interface(ADA, masters_lock);
pragma interface_name(masters_lock, "__ADA_MASTERS_LOCK");
function masters_trylock return boolean;
-- If not supported, simply return FALSE. When FALSE is returned
-- the task's mutex is unlocked and then the above masters_lock()
-- is called
pragma interface(ADA, masters_trylock);
pragma interface_name(masters_trylock, "__ADA_MASTERS_TRYLOCK");
procedure masters_unlock;
pragma interface(ADA, masters_unlock);
pragma interface_name(masters_unlock, "__ADA_MASTERS_UNLOCK");
-------------------------------------------------------------------------
-- Task synchronization services
-------------------------------------------------------------------------
procedure task_lock(tsk: task_id);
pragma interface(ADA, task_lock);
pragma interface_name(task_lock, "__ADA_TASK_LOCK");
procedure task_unlock(tsk: task_id);
pragma interface(ADA, task_unlock);
pragma interface_name(task_unlock, "__ADA_TASK_UNLOCK");
procedure task_wait(locked_tsk: task_id);
-- locked_tsk may be the current or another task. locked_tsk is unlocked
-- while the current task waits and relocked before task_wait()
-- returns
--
-- Note: only return after task_self has been signaled. task_self
-- is only signaled once after another task locks the locked_tsk's mutex.
-- This differs from waiting on a POSIX condition variable.
--
-- Implementation guideline: if locked_tsk /= task_self(), then,
-- Ada tasking RTS inhibits task_self from being stopped.
pragma interface(ADA, task_wait);
pragma interface_name(task_wait, "__ADA_TASK_WAIT");
procedure task_wait_locked_masters;
-- The masters' mutex has already been locked. The masters'
-- mutex is unlocked while the current task waits and is relocked
-- before task_wait_locked_masters() returns.
pragma interface(ADA, task_wait_locked_masters);
pragma interface_name(task_wait_locked_masters,
"__ADA_TASK_WAIT_LOCKED_MASTERS");
--
-- Upon entry: task_self's mutex isn't locked.
--
-- Note: only return after task_self has been signaled. task_self
-- is only signaled once after another task locks the masters' mutex.
-- This differs from waiting on a POSIX condition variable.
function task_timed_wait(locked_tsk: task_id; sec: duration) return boolean;
pragma interface(ADA, task_timed_wait);
pragma interface_name(task_timed_wait, "__ADA_TASK_TIMED_WAIT");
--
-- Implementation guideline: if locked_tsk /= task_self(), then,
-- Ada tasking RTS inhibits task_self from being stopped.
procedure task_signal(tsk: task_id);
pragma interface(ADA, task_signal);
pragma interface_name(task_signal, "__ADA_TASK_SIGNAL");
-- task_wait, task_unlock
procedure task_wait_unlock(locked_tsk: task_id);
pragma interface(ADA, task_wait_unlock);
pragma interface_name(task_wait_unlock, "__ADA_TASK_WAIT_UNLOCK");
-- task_signal, task_unlock
procedure task_signal_unlock(tsk_to_signal: task_id; locked_tsk: task_id);
pragma interface(ADA, task_signal_unlock);
pragma interface_name(task_signal_unlock, "__ADA_TASK_SIGNAL_UNLOCK");
-- task_signal, task_wait, task_unlock
procedure task_signal_wait_unlock(tsk_to_signal: task_id;
locked_tsk: task_id);
pragma interface(ADA, task_signal_wait_unlock);
pragma interface_name(task_signal_wait_unlock,
"__ADA_TASK_SIGNAL_WAIT_UNLOCK");
-------------------------------------------------------------------------
-- Sporadic task services (CIFO augmentation)
-------------------------------------------------------------------------
-- Returns TRUE for a sporadic task
function task_is_sporadic(tsk: task_id) return boolean;
pragma interface(ADA, task_is_sporadic);
pragma interface_name(task_is_sporadic, "__ADA_TASK_IS_SPORADIC");
-- For a sporadic task: eventhough it might have already consumed all
-- of its available execution time for the replenishment period, force it
-- to use its normal high priority instead of its background low priority.
--
-- This routine is called by Ada tasking to force the high priority
-- if another task does a rendezvous with the sporadic task. This
-- routine is called when the rendezvous completes with the flag
-- set to FALSE to no longer force the high priority.
--
-- Upon entry/exit: tsk is locked
procedure task_set_force_high_priority(tsk: task_id; flag: boolean);
pragma interface(ADA, task_set_force_high_priority);
pragma interface_name(task_set_force_high_priority,
"__ADA_TASK_SET_FORCE_HIGH_PRIORITY");
-------------------------------------------------------------------------
-- Interrupt services
-------------------------------------------------------------------------
procedure interrupts_get_status(status: out intr_status_t);
pragma interface(ADA, interrupts_get_status);
pragma interface_name(interrupts_get_status,
"__ADA_INTERRUPTS_GET_STATUS");
procedure interrupts_set_status(old_status: out intr_status_t;
new_status: intr_status_t);
pragma interface(ADA, interrupts_set_status);
pragma interface_name(interrupts_set_status,
"__ADA_INTERRUPTS_SET_STATUS");
function isr_attach(iv: intr_vector_id_t; isr: address) return address;
-- Returns address of previously attached isr.
-- ada_krn_defs.BAD_INTR_VECTOR is returned for a bad intr_vector
-- parameter.
pragma interface(ADA, isr_attach);
pragma interface_name(isr_attach, "__ADA_ISR_ATTACH");
function isr_detach(iv: intr_vector_id_t) return address;
-- Returns address of previously attached isr.
-- ada_krn_defs.BAD_INTR_VECTOR is returned for a bad intr_vector
-- parameter.
pragma interface(ADA, isr_detach);
pragma interface_name(isr_detach, "__ADA_ISR_DETACH");
function isr_get(iv: intr_vector_id_t) return address;
-- Returns the address of the currently attached isr.
-- ada_krn_defs.BAD_INTR_VECTOR is returned for a bad intr_vector
-- parameter.
pragma interface(ADA, isr_get);
pragma interface_name(isr_get, "__ADA_ISR_GET");
function isr_get_ivt return address;
-- Returns address of the Interrupt Vector Table (IVT). Normally, the
-- IVT is an array of ISR addresses. However, the IVT representation
-- is CPU dependent (for 386 cross, its the IDT).
pragma interface(ADA, isr_get_ivt);
pragma interface_name(isr_get_ivt, "__ADA_ISR_GET_IVT");
function isr_in_check return boolean;
pragma inline_only(isr_in_check);
-------------------------------------------------------------------------
-- Time services
-------------------------------------------------------------------------
procedure time_set(day: day_t; sec: duration;
timer_support_arg: address := NO_ADDR);
pragma interface(ADA, time_set);
pragma interface_name(time_set, "__ADA_TIME_SET");
--
-- timer_support_arg - on self-hosts, if not NO_ADDR, then,
-- the address of the OS's time record. This allows, time_set()
-- to be atomically set with the OS's current time. For an
-- example, see how v_i_time.set_time() is called in calendar_s.a.
-- Returned time is normalized, sec < 86400.0
procedure time_get(day: out day_t; sec: out duration);
pragma interface(ADA, time_get);
pragma interface_name(time_get, "__ADA_TIME_GET");
procedure time_delay(sec: duration);
pragma interface(ADA, time_delay);
pragma interface_name(time_delay, "__ADA_TIME_DELAY");
--
-- Implementation guideline: this service can be implemented via:
-- task_lock(task_self);
-- task_timed_wait(task_self, sec);
-- task_unlock(task_self);
--
-- after, task_self is locked, you might need to check if it has
-- been stopped. If it has been stopped, then, return to allow
-- the Ada tasking software to complete itself.
-- Upon entry time has already been normalized (sec < 86400.0)
procedure time_delay_until(day: day_t; sec: duration);
pragma interface(ADA, time_delay_until);
pragma interface_name(time_delay_until, "__ADA_TIME_DELAY_UNTIL");
-------------------------------------------------------------------------
-- Allocation services
-------------------------------------------------------------------------
-- Returns NO_ADDR if alloc is unsuccessful.
function alloc(size: natural) return address;
pragma interface(ADA, alloc);
pragma interface_name(alloc, "__ADA_ALLOC");
procedure free(a: address);
pragma interface(ADA, free);
pragma interface_name(free, "__ADA_FREE");
-------------------------------------------------------------------------
-- Mutex services
-------------------------------------------------------------------------
-- Returns TRUE if mutex was successfully initialized.
function mutex_init(mutex: a_mutex_t; attr: a_mutex_attr_t)
return boolean;
pragma interface(ADA, mutex_init);
pragma interface_name(mutex_init, "__ADA_MUTEX_INIT");
procedure mutex_destroy(mutex: a_mutex_t);
pragma interface(ADA, mutex_destroy);
pragma interface_name(mutex_destroy, "__ADA_MUTEX_DESTROY");
procedure mutex_lock(mutex: a_mutex_t);
pragma interface(ADA, mutex_lock);
pragma interface_name(mutex_lock, "__ADA_MUTEX_LOCK");
function mutex_trylock(mutex: a_mutex_t) return boolean;
pragma interface(ADA, mutex_trylock);
pragma interface_name(mutex_trylock, "__ADA_MUTEX_TRYLOCK");
procedure mutex_unlock(mutex: a_mutex_t);
pragma interface(ADA, mutex_unlock);
pragma interface_name(mutex_unlock, "__ADA_MUTEX_UNLOCK");
-- Returns TRUE if cond variable was successfully initialized.
function cond_init(cond: a_cond_t; attr: a_cond_attr_t) return boolean;
pragma interface(ADA, cond_init);
pragma interface_name(cond_init, "__ADA_COND_INIT");
procedure cond_destroy(cond: a_cond_t);
pragma interface(ADA, cond_destroy);
pragma interface_name(cond_destroy, "__ADA_COND_DESTROY");
procedure cond_wait(cond: a_cond_t; mutex: a_mutex_t);
pragma interface(ADA, cond_wait);
pragma interface_name(cond_wait, "__ADA_COND_WAIT");
function cond_timed_wait(cond: a_cond_t; mutex: a_mutex_t;
sec: duration) return boolean;
pragma interface(ADA, cond_timed_wait);
pragma interface_name(cond_timed_wait, "__ADA_COND_TIMED_WAIT");
procedure cond_signal(cond: a_cond_t);
pragma interface(ADA, cond_signal);
pragma interface_name(cond_signal, "__ADA_COND_SIGNAL");
procedure cond_broadcast(cond: a_cond_t);
pragma interface(ADA, cond_broadcast);
pragma interface_name(cond_broadcast, "__ADA_COND_BROADCAST");
procedure cond_signal_unlock(cond: a_cond_t; mutex: a_mutex_t);
pragma interface(ADA, cond_signal_unlock);
pragma interface_name(cond_signal_unlock, "__ADA_COND_SIGNAL_UNLOCK");
-------------------------------------------------------------------------
-- ISR mutex services
-------------------------------------------------------------------------
-- Returns TRUE if mutex can be locked from an ISR
function isr_mutex_lockable(mutex: a_mutex_t) return boolean;
pragma interface(ADA, isr_mutex_lockable);
pragma interface_name(isr_mutex_lockable, "__ADA_ISR_MUTEX_LOCKABLE");
procedure isr_mutex_lock(mutex: a_mutex_t);
pragma interface(ADA, isr_mutex_lock);
pragma interface_name(isr_mutex_lock, "__ADA_ISR_MUTEX_LOCK");
procedure isr_mutex_unlock(mutex: a_mutex_t);
pragma inline_only(isr_mutex_unlock);
procedure isr_cond_signal(cond: a_cond_t);
pragma interface(ADA, isr_cond_signal);
pragma interface_name(isr_cond_signal, "__ADA_ISR_COND_SIGNAL");
-------------------------------------------------------------------------
-- Priority ceiling mutex services (CIFO augmentation)
-------------------------------------------------------------------------
-- Returns TRUE if underlying threads supports priority ceiling
-- protocol and the mutex was successfully initialized.
function ceiling_mutex_init(mutex: a_mutex_t; attr: a_mutex_attr_t;
ceiling_prio: priority := priority'last) return boolean;
pragma interface(ADA, ceiling_mutex_init);
pragma interface_name(ceiling_mutex_init, "__ADA_CEILING_MUTEX_INIT");
-- Returns FALSE if not a priority ceiling mutex
function ceiling_mutex_set_priority(mutex: a_mutex_t;
ceiling_prio: priority) return boolean;
pragma interface(ADA, ceiling_mutex_set_priority);
pragma interface_name(ceiling_mutex_set_priority,
"__ADA_CEILING_MUTEX_SET_PRIORITY");
-- Returns -1 if not a priority ceiling mutex
function ceiling_mutex_get_priority(mutex: a_mutex_t) return integer;
pragma interface(ADA, ceiling_mutex_get_priority);
pragma interface_name(ceiling_mutex_get_priority,
"__ADA_CEILING_MUTEX_GET_PRIORITY");
-------------------------------------------------------------------------
-- Semaphore services
-------------------------------------------------------------------------
-- Returns TRUE if semaphore was successfully initialized.
function semaphore_init(s: a_semaphore_t; init_state: semaphore_state_t;
attr: a_semaphore_attr_t) return boolean;
pragma interface(ADA, semaphore_init);
pragma interface_name(semaphore_init, "__ADA_SEMAPHORE_INIT");
procedure semaphore_destroy(s: a_semaphore_t);
pragma interface(ADA, semaphore_destroy);
pragma interface_name(semaphore_destroy, "__ADA_SEMAPHORE_DESTROY");
procedure semaphore_wait(s: a_semaphore_t);
pragma interface(ADA, semaphore_wait);
pragma interface_name(semaphore_wait, "__ADA_SEMAPHORE_WAIT");
function semaphore_trywait(s: a_semaphore_t) return boolean;
pragma interface(ADA, semaphore_trywait);
pragma interface_name(semaphore_trywait, "__ADA_SEMAPHORE_TRYWAIT");
function semaphore_timed_wait(s: a_semaphore_t;
sec: duration) return boolean;
pragma interface(ADA, semaphore_timed_wait);
pragma interface_name(semaphore_timed_wait, "__ADA_SEMAPHORE_TIMED_WAIT");
procedure semaphore_signal(s: a_semaphore_t);
pragma interface(ADA, semaphore_signal);
pragma interface_name(semaphore_signal, "__ADA_SEMAPHORE_SIGNAL");
-- The following is called by the VADS EXEC delete_semaphore() service
-- (for a binary semaphore). It should return TRUE if any task is waiting
-- on the semaphore. If you are unable to detect this condition, then,
-- return TRUE. By returning TRUE, you cause the delete_semaphore()
-- service to do a dummy semaphore signal and then wait a few seconds
-- before freeing the semaphore resources.
function semaphore_get_in_use(s: a_semaphore_t) return boolean;
pragma interface(ADA, semaphore_get_in_use);
pragma interface_name(semaphore_get_in_use,
"__ADA_SEMAPHORE_GET_IN_USE");
-------------------------------------------------------------------------
-- Count semaphore services (VADS EXEC augmentation)
-------------------------------------------------------------------------
-- Returns TRUE if semaphore was successfully initialized.
function count_semaphore_init(
s : a_count_semaphore_t;
init_count : integer;
attr : a_count_semaphore_attr_t) return boolean;
pragma interface(ADA, count_semaphore_init);
pragma interface_name(count_semaphore_init,
"__ADA_COUNT_SEMAPHORE_INIT");
procedure count_semaphore_destroy(s: a_count_semaphore_t);
pragma interface(ADA, count_semaphore_destroy);
pragma interface_name(count_semaphore_destroy,
"__ADA_COUNT_SEMAPHORE_DESTROY");
-- Waits on a counting semaphore.
--
-- Returns TRUE, if semaphore count > 0. The count is decremented
-- before returning.
--
-- If count <= 0, then, returns according to the wait_time parameter:
-- < 0.0 - returns when count > 0. This may necessitate
-- suspension of current task until another task
-- signals.
-- = 0.0 - returns FALSE immediately if count <= 0.
-- > 0.0 - if count doesn't become positive
-- within "wait_time" amount of time, returns FALSE.
function count_semaphore_wait(s: a_count_semaphore_t;
wait_time: duration) return boolean;
pragma interface(ADA, count_semaphore_wait);
pragma interface_name(count_semaphore_wait,
"__ADA_COUNT_SEMAPHORE_WAIT");
-- Signals a counting semaphore.
--
-- Increments the semphore's count. If count > 0, resumes next
-- task waiting on semaphore.
procedure count_semaphore_signal(s: a_count_semaphore_t);
pragma interface(ADA, count_semaphore_signal);
pragma interface_name(count_semaphore_signal,
"__ADA_COUNT_SEMAPHORE_SIGNAL");
-- The following is called by the VADS EXEC delete_semaphore() service
-- (for a count semaphore). It should return TRUE if any task is waiting
-- on the semaphore. If you are unable to detect this condition, then,
-- return TRUE. By returning TRUE, you cause the delete_semaphore()
-- service to do a dummy semaphore signal and then wait a few seconds
-- before freeing the semaphore resources.
function count_semaphore_get_in_use(s: a_count_semaphore_t) return boolean;
pragma interface(ADA, count_semaphore_get_in_use);
pragma interface_name(count_semaphore_get_in_use,
"__ADA_COUNT_SEMAPHORE_GET_IN_USE");
-------------------------------------------------------------------------
-- Mailbox services (VADS EXEC augmentation)
-------------------------------------------------------------------------
-- Returns TRUE if mailbox was successfully initialized.
function mailbox_init(
m : a_mailbox_t;
slots_cnt : positive;
slot_len : natural;
attr : a_mailbox_attr_t) return boolean;
pragma interface(ADA, mailbox_init);
pragma interface_name(mailbox_init, "__ADA_MAILBOX_INIT");
procedure mailbox_destroy(m: a_mailbox_t);
pragma interface(ADA, mailbox_destroy);
pragma interface_name(mailbox_destroy, "__ADA_MAILBOX_DESTROY");
-- Reads a message from a mailbox. Returns TRUE if message was
-- successfully read.
--
-- If no message is available for reading, then, returns according to
-- the wait_time parameter:
-- < 0.0 - returns when message was successfully read.
-- This may necessitate suspension of current task
-- until another task does mailbox write.
-- = 0.0 - returns FALSE immediately if unable to do
-- mailbox read
-- > 0.0 - if the mailbox read cannot be completed
-- within "wait_time" amount of time, returns FALSE.
function mailbox_read(m: a_mailbox_t; msg_addr: address;
wait_time: duration) return boolean;
pragma interface(ADA, mailbox_read);
pragma interface_name(mailbox_read, "__ADA_MAILBOX_READ");
-- Writes a message to a mailbox. Returns FALSE if no slot is
-- available for writing.
function mailbox_write(m: a_mailbox_t; msg_addr: address) return boolean;
pragma interface(ADA, mailbox_write);
pragma interface_name(mailbox_write, "__ADA_MAILBOX_WRITE");
-- Returns number of unread messages in mailbox
function mailbox_get_count(m: a_mailbox_t) return natural;
pragma interface(ADA, mailbox_get_count);
pragma interface_name(mailbox_get_count, "__ADA_MAILBOX_GET_COUNT");
-- The following is called by the VADS EXEC delete_mailbox() service.
-- It should return TRUE if any task is waiting to read from the mailbox.
-- If you are unable to detect this condition, then, return TRUE.
-- By returning TRUE, you cause the delete_mailbox() service to
-- do a dummy mailbox write and wait a few seconds before freeing
-- the mailbox resources.
function mailbox_get_in_use(m: a_mailbox_t) return boolean;
pragma interface(ADA, mailbox_get_in_use);
pragma interface_name(mailbox_get_in_use,
"__ADA_MAILBOX_GET_IN_USE");
-------------------------------------------------------------------------
-- Callout and task storage services (VADS EXEC augmentation)
-------------------------------------------------------------------------
-- Service to install a callout. Returns FALSE if service isn't
-- supported or unable to do the install.
function callout_install(event: callout_event_t; proc: address)
return boolean;
pragma interface(ADA, callout_install);
pragma interface_name(callout_install, "__ADA_CALLOUT_INSTALL");
-- Service to allocate storage in the task control block. Returns
-- NO_TASK_STORAGE_ID if service isn't supported or unable to
-- allocate memory.
function task_storage_alloc(size: natural) return task_storage_id;
pragma interface(ADA, task_storage_alloc);
pragma interface_name(task_storage_alloc, "__ADA_TASK_STORAGE_ALLOC");
function task_storage_get(tsk: task_id; storage: task_storage_id)
return address;
pragma interface(ADA, task_storage_get);
pragma interface_name(task_storage_get, "__ADA_TASK_STORAGE_GET");
function task_storage_get2(krn_tsk: krn_task_id; storage: task_storage_id)
return address;
pragma interface(ADA, task_storage_get2);
pragma interface_name(task_storage_get2, "__ADA_TASK_STORAGE_GET2");
-------------------------------------------------------------------------
-- Name services (VADS EXEC augmentation)
-------------------------------------------------------------------------
-- Bind a name to the program_id and address of a procedure or object.
--
-- The name parameter can be any sequence of characters. An exact
-- match is done for all name searches. ("MY_NAME" diffs from "my_name".)
--
-- The prg parameter should be set to NO_PROGRAM_ID if the name
-- isn't bound to a particular program or if the current program and
-- stack limit switch logic are to be eliminated for an
-- ada_krn_i.program_inter_call(). All procedures and objects in the kernel
-- program are bound with prg implicitly set to NO_PROGRAM_ID.
--
-- If successful, name_bind returns ada_krn_defs.NAME_BIND_OK. Otherwise,
-- it returns one of the following error codes also found in ada_krn_defs:
-- NAME_BIND_NOT_SUPPORTED
-- NAME_BIND_BAD_ARG
-- NAME_BIND_OUT_OF_MEMORY
-- NAME_BIND_ALREADY_BOUND
function name_bind(
name : string;
prg : program_id;
addr : address) return name_bind_status_t;
pragma interface(ADA, name_bind);
pragma interface_name(name_bind, "__ADA_NAME_BIND");
-- Resolve the name of a procedure or object into its program_id and
-- address.
--
-- name_resolve first attempts to find an already bound name that
-- exactly matches the name parameter. For a match, it returns
-- immediately with the prg and addr out parameters updated and
-- status set to ada_krn_defs.NAME_RESOLVE_OK. Otherwise, it
-- returns according to the wait_time parameter:
-- < 0.0 - waits indefinitely until the name is bound
-- = 0.0 - returns immediately with status set to
-- NAME_RESOLVE_FAILED
-- > 0.0 - if the name isn't bound within "wait_time",
-- returns with status set to NAME_RESOLVE_TIMED_OUT
--
-- If name services aren't supported or name_resolve was called with
-- a bad argument, then, status is set to NAME_RESOLVE_NOT_SUPPORTED
-- or NAME_RESOLVE_BAD_ARG.
procedure name_resolve(
name : string;
wait_time : duration;
prg : out program_id;
addr : out address;
status : out name_resolve_status_t);
pragma interface(ADA, name_resolve);
pragma interface_name(name_resolve, "__ADA_NAME_RESOLVE");
end ada_krn_i;
with system; use system;
with ada_krn_defs; use ada_krn_defs;
with link_block;
with krn_defs;
with usr_defs;
package body ada_krn_i is
pragma suppress(ALL_CHECKS);
pragma suppress(EXCEPTION_TABLES);
debug_block : link_block.debug_block_t;
pragma interface_name(debug_block, "DEBUG_BLOCK");
-------------------------------------------------------------------------
-- Task management services
-------------------------------------------------------------------------
function task_self return task_id is
begin
return krn_defs.to_a_a_krn_tcb_t(debug_block.ct).all.Ada_task_id;
end;
-------------------------------------------------------------------------
-- ISR mutex services
-------------------------------------------------------------------------
procedure isr_mutex_unlock(mutex: a_mutex_t) is
begin
null;
end;
-------------------------------------------------------------------------
-- Interrupt services
-------------------------------------------------------------------------
function isr_in_check return boolean is
begin
return usr_defs.to_a_natural(debug_block.intr_depth).all > 0;
end;
end ada_krn_i;