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