?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Ring 3 support' ??
MODULE pmm$tasking_support_ring_3;

{  PURPOSE:
{    This module contains ring 3 procedures and data structures necessary to support tasking.

?? NEWTITLE := '  Global declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc loc$deferred_entry_pt_library
*copyc ife$error_codes
*copyc loc$task_services_library_name
*copyc mmc$segment_manager_defaults
*copyc mme$condition_codes
*copyc pmt$task_id
*copyc pmt$task_control_block
*copyc pmt$program_description
*copyc pmt$task_state
*copyc pmt$stack_segment
*copyc pmt$segment_inheritance_options
*copyc pmt$loadable_rings
*copyc pmt$os_stack_frame_word
*copyc osc$unseen_mail_condition
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$execution_control_block
*copyc ost$caller_identifier
*copyc ost$global_task_id
*copyc ost$stack_frame_save_area
*copyc oss$task_private
*copyc oss$task_shared
*copyc pme$condition_exceptions
*copyc pme$execution_exceptions
*copyc pme$program_services_exceptions
*copyc pmt$apd_task_jobmode_statistics
*copyc lot$loader_type_definitions
*copyc tmc$signal_identifiers
?? POP ??
*copyc clp$validate_name
*copyc gfp$get_fde_p
*copyc i#build_adaptable_seq_pointer
*copyc i#disable_traps
*copyc i#move
*copyc i#restore_traps
*copyc lop$augment_allocated_segments
*copyc mmp$change_segment_inheritance
*copyc mmp$create_segment
*copyc mmp$fetch_segment_attributes
*copyc mmp$reserve_segment_number
*copyc mmp$store_segment_attributes
*copyc mmp$validate_segment_number
*copyc osp$establish_condition_handler
*copyc osp$force_access_violation
*copyc osp$is_caller_system_privileged
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc osp$verify_system_segment
*copyc pmp$await_task_termination
*copyc pmp$build_ada_task_table
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$set_system_flag
*copyc pmp$send_signal
*copyc pmp$find_task_tcb
*copyc pmp$find_task_xcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_executing_task_tcb
*copyc pmp$outward_call
*copyc pmp$ready_task_list_r1
*copyc pmp$set_relative_priority_r1
*copyc pmp$update_tos_ring_1
*copyc tmp$clear_wait_inhibited
*copyc clp$convert_integer_to_string
*copyc mmv$page_map_offsets
*copyc osv$page_size
*copyc pmv$debug_logging_enabled

  CONST
    child_xcb_lost = 'child XCB lost',
    unexpected_abnormal_status = 'unexpected abnormal status';

*copyc oss$job_paged_literal
*copyc lov$file_descriptors
*copyc lov$library_list
*copyc lov$allocated_segments
*copyc lov$highest_segment_index

  VAR
    pmv$emit_broken_task_msg_to_sl: [XREF] boolean;

  VAR
    pmv$unseen_mail_pending: [XDCL, STATIC, oss$task_shared] boolean := FALSE;

  VAR
    task_state: [STATIC, oss$task_private] pmt$task_state := pmc$task_active;

?? TITLE := '  [XDCL, #GATE] pmp$get_task_id', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_task_id
    (VAR task_id: pmt$task_id;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure returns the task_id of the executing task.

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    task_id := xcb^.task_id;
    status.normal := TRUE;

  PROCEND pmp$get_task_id;
?? TITLE := '  [XDCL] pmp$get_global_task_id', EJECT ??

  PROCEDURE [XDCL] pmp$get_global_task_id
    (    task_id: pmt$task_id;
     VAR global_task_id: ost$global_task_id;
     VAR status {control} : ost$status);

*copyc pmh$get_global_task_id


    VAR
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_task_xcb (task_id, xcb);
    IF xcb = NIL THEN
      osp$set_status_condition (pme$unknown_task_id, status);
    ELSE
      global_task_id := xcb^.global_task_id;
    IFEND;
  PROCEND pmp$get_global_task_id;
?? TITLE := '  [XDCL, #GATE] pmp$task_state', EJECT ??

  FUNCTION [XDCL, #GATE] pmp$task_state: pmt$task_state;

*copyc pmh$task_state

    pmp$task_state := task_state;
  FUNCEND pmp$task_state;
?? TITLE := '  [XDCL] pmp$set_task_state', EJECT ??

  PROCEDURE [XDCL] pmp$set_task_state
    (    new_task_state: pmt$task_state);

    task_state := new_task_state;
  PROCEND pmp$set_task_state;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_termination_status', EJECT ??
*copy pmh$get_termination_status

  PROCEDURE [XDCL, #GATE] pmp$get_termination_status
    (VAR termination_status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.task_kind = osc$tk_nosve_task THEN
      termination_status := tcb_p^.nosve.termination_status^;
    ELSE { IF tcb_p^.task_kind = osc$tk_unix_task THEN
      termination_status.normal := TRUE;
    IFEND;
  PROCEND pmp$get_termination_status;
?? TITLE := '  [XDCL] pmp$flag_all_child_tasks', EJECT ??

  PROCEDURE [XDCL] pmp$flag_all_child_tasks
    (    system_flag: ost$system_flag;
     VAR status {control} : ost$status);

*copyc pmh$flag_all_child_tasks

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true as long as no pmp$wait calls are issued by
{    the procedure or its subordinates.

    VAR
      child: ^pmt$task_control_block,
      child_gtid: ost$global_task_id,
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    child := tcb_p^.first_child;
    WHILE child <> NIL DO
      pmp$get_global_task_id (child^.task_id, child_gtid, local_status);
      IF NOT local_status.normal THEN
        osp$system_error (child_xcb_lost, NIL);
      IFEND;
      pmp$set_system_flag (system_flag, child_gtid, status);
      IF NOT status.normal THEN
        IF status.condition = pme$unknown_recipient_task THEN
          status.normal := TRUE;
        ELSE
          RETURN
        IFEND;
      IFEND;
      child := child^.next_sibling;
    WHILEND;
  PROCEND pmp$flag_all_child_tasks;
?? TITLE := '  [XDCL] pmp$signal_all_child_tasks', EJECT ??

  PROCEDURE [XDCL] pmp$signal_all_child_tasks
    (    signal: pmt$signal;
     VAR status {control} : ost$status);

*copyc pmh$signal_all_child_tasks

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true as long as no pmp$wait calls are issued by
{    the procedure or its subordinates.

    VAR
      child: ^pmt$task_control_block,
      child_gtid: ost$global_task_id,
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    child := tcb_p^.first_child;
    WHILE child <> NIL DO
      pmp$get_global_task_id (child^.task_id, child_gtid, local_status);
      IF NOT local_status.normal THEN
        osp$system_error (child_xcb_lost, NIL);
      IFEND;
      pmp$send_signal (child_gtid, signal, status);
      IF NOT status.normal THEN
        IF status.condition = pme$unknown_recipient_task THEN
          status.normal := TRUE;
        ELSE
          RETURN
        IFEND;
      IFEND;
      child := child^.next_sibling;
    WHILEND;
  PROCEND pmp$signal_all_child_tasks;
?? TITLE := '  [XDCL] pmp$verify_current_child', EJECT ??

  PROCEDURE [XDCL] pmp$verify_current_child
    (    task_id: pmt$task_id;
     VAR current_child {control} : boolean);

*copyc pmh$verify_child_task

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true as long as no pmp$wait calls are issued by
{    the procedure or its subordinates.

    VAR
      child: ^pmt$task_control_block,
      tcb_p: ^pmt$task_control_block;

    current_child := FALSE;
    pmp$find_executing_task_tcb (tcb_p);
    child := tcb_p^.first_child;

  /scan_child_list/
    WHILE child <> NIL DO
      IF task_id = child^.task_id THEN
        current_child := TRUE;
        EXIT /scan_child_list/;
      ELSE
        child := child^.next_sibling;
      IFEND;
    WHILEND /scan_child_list/;
  PROCEND pmp$verify_current_child;
?? TITLE := '  [XDCL, #GATE] pmp$await_ada_task', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$await_ada_task
    (    os_stack_frame_word: ^pmt$os_stack_frame_word);

*copy pmh$await_ada_task

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true while the procedure is not in wait.

    VAR
      status: ost$status,
      ada_child_found: boolean,
      child: ^pmt$task_control_block,
      tcb_p: ^pmt$task_control_block;

?? NEWTITLE := 'aat_condition_handler', EJECT ??

{ PURPOSE:
{   This condition handler detects a condition that goes off during termination
{   of an ADA task that has child tasks.  The condition is continued to the
{   ring crossing with the standard procedure executed.  If the continue
{   request returns with abnormal status, the task is terminated.  If a terminate
{   break was issued by the user, the task is terminated.

    PROCEDURE aat_condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IF NOT handler_status.normal THEN
        pmp$exit (handler_status);
      ELSEIF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN
        osp$set_status_condition (ife$terminate_break_received, handler_status);
        pmp$exit (handler_status);
      IFEND;
    PROCEND aat_condition_handler;
?? OLDTITLE ??
?? EJECT ??

    osp$establish_condition_handler (^aat_condition_handler, {block_exit} FALSE);

    REPEAT
      ada_child_found := FALSE;
      pmp$find_executing_task_tcb (tcb_p);
      child := tcb_p^.first_child;

{ Find a child task that is an ADA asynchronous procedure that has the subject stack frame
{ as a critical frame.  If found, then await the termination of that task.  Return to the
{ caller when the critical frame count for this frame is zero.

    /find_ada_child/
      WHILE child <> NIL DO
        IF ((child^.nosve.ada_starting_procedure <> NIL) AND (child^.nosve.ada_critical_frame <> NIL)) AND
              (child^.nosve.ada_critical_frame = os_stack_frame_word) THEN
          ada_child_found := TRUE;
          EXIT /find_ada_child/;
        ELSE
          child := child^.next_sibling;
        IFEND;

      WHILEND /find_ada_child/;

      IF ada_child_found THEN
        pmp$await_task_termination (child^.task_id, status);

      ELSEIF os_stack_frame_word^.ada_critical_frame_count <> 0 THEN
        osp$set_status_condition (pme$ada_critical_frame_error, status);
        os_stack_frame_word^.ada_critical_frame_count := 0;
      IFEND;

    UNTIL os_stack_frame_word^.ada_critical_frame_count = 0;
    os_stack_frame_word^.ada_critical_frame := FALSE;

  PROCEND pmp$await_ada_task;
?? TITLE := '  [XDCL, #GATE] pmp$reserve_stack_segments', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$reserve_stack_segments
    (    number_of_tasks: pmt$max_number_of_tasks;
     VAR status: ost$status);

*copy pmh$reserve_stack_segments

    VAR
      seg_num_array: ^array [ * ] of ost$segment;

    status.normal := TRUE;

{ Assure caller is not an asynchronous procedure and build the task table for
{ use by segment manager when assigning shared stacks.

    pmp$build_ada_task_table (number_of_tasks, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Reserve <number_of_tasks> stack segments for use by asynchronous procedures.

    PUSH seg_num_array: [1 .. number_of_tasks];
    mmp$reserve_segment_number (TRUE, seg_num_array, status);

  PROCEND pmp$reserve_stack_segments;
?? TITLE := '  [XDCL, #GATE] pmp$change_inheritable_segments', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_inheritable_segments
    (    option: pmt$segment_inheritance_options;
     VAR status: ost$status);

*copy pmh$change_inheritable_segments

    VAR
      i: integer,
      index: lot$allocated_segments_index,
      loaded_rings: pmt$loadable_rings,
      library: ^lot$library_descriptor,
      previous_save_area: ^ost$stack_frame_save_area,
      pva: ^cell,
      ring: pmt$loadable_ring,
      tcb_p: ^pmt$task_control_block,
      caller: ost$caller_identifier;

    status.normal := TRUE;

    IF option <> pmc$inherit_code_and_data THEN
      osp$set_status_condition (pme$invalid_inheritance_option, status);
      RETURN;
    IFEND;

    #CALLER_ID (caller);

{ Insure that the caller is not an Asynchronous Procedure.

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.ada_starting_procedure <> NIL THEN
      osp$set_status_condition (pme$illegal_ada_control_task, status);
      RETURN;
    IFEND;

{ Insure that the caller is not a multi-ring task.

    pmp$get_loaded_rings (loaded_rings);
    FOR ring := osc$sj_ring_2 TO osc$user_ring_2 DO
      IF (ring IN loaded_rings) AND (ring <> caller.ring) THEN
        osp$set_status_condition (pme$invalid_loaded_ring, status);
        RETURN;
      IFEND;
    FOREND;

{ Search LOV$ALLOCATED_SEGMENTS for all segments within the caller's ring privilege.
{ For each segment found call MMP$CHANGE_SEGMENT_INHERITANCE to make the segment inheritable.

    FOR index := 1 TO lov$highest_segment_index DO
      IF lov$allocated_segments^ [index].attributes.r2 >= caller.ring THEN
        pva := #ADDRESS (caller.ring, lov$allocated_segments^ [index].segment, 0);
        mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

{ Get the debug table segments so that callees may inherit them for debugging.
{ For each segment call MMP$CHANGE_SEGMENT_INHERITANCE to make the segment inheritable.

    IF tcb_p^.nosve.debug_table^.module_segment.seq_pointer <> NIL THEN
      pva := tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
      mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer <> NIL THEN
      pva := tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer;
      mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Now search LOV$LIBRARY_LIST.  Call MMP$CHANGE_SEGMENT_INHERITANCE for each open library.

    library := lov$library_list.first;

    WHILE (library <> NIL) DO
      IF (library^.library_open AND library^.library_valid) AND
            (library^.attributes.name <> loc$task_services_library_name) AND
            (library^.attributes.name (1, loc$deferred_entry_pt_lib_size) <>
            loc$deferred_entry_pt_library) THEN
        pva := library^.segment;
        mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
      IFEND;

      library := library^.nnext;
      IF (library = lov$library_list.first) OR (NOT status.normal) THEN
        RETURN;
      IFEND;
    WHILEND;

{ Now search LOV$FILE_DESCRIPTORS.  Call MMP$CHANGE_SEGMENT_INHERITANCE for
{ each object file that is a library.

    IF lov$file_descriptors <> NIL THEN
      FOR i := 1 TO UPPERBOUND (lov$file_descriptors^) DO
        pva := lov$file_descriptors^ [i].segment;
        mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND pmp$change_inheritable_segments;
?? TITLE := '  [XDCL, #GATE] pmp$create_ada_heap', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_ada_heap
    (VAR heap_segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

*copy pmh$create_ada_heap

    VAR
      heap_segment_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      tcb_p: ^pmt$task_control_block,
      caller: ost$caller_identifier;

    status.normal := TRUE;

    #CALLER_ID (caller);

{ Insure that the caller is not an Asynchronous Procedure.

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.ada_starting_procedure <> NIL THEN
      osp$set_status_condition (pme$illegal_ada_control_task, status);
      RETURN;
    IFEND;

{ Create a heap segment in the ring of the caller.

    heap_segment_pointer.kind := mmc$heap_pointer;

    heap_segment_attributes [1].keyword := mmc$kw_ring_numbers;
    heap_segment_attributes [1].r1 := caller.ring;
    heap_segment_attributes [1].r2 := caller.ring;
    mmp$create_segment (^heap_segment_attributes, mmc$heap_pointer, 1, heap_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Put an entry for this heap segment in LOV$ALLOCATED_SEGMENTS so that the segment will be
{ inherited by all subseqent ADA asynchronous procedures.

    IF lov$highest_segment_index = UPPERBOUND (lov$allocated_segments^) THEN
      lop$augment_allocated_segments;
    IFEND;

    lov$highest_segment_index := lov$highest_segment_index + 1;
    lov$allocated_segments^ [lov$highest_segment_index].current_length := mmc$default_maximum_seg_length;
    lov$allocated_segments^ [lov$highest_segment_index].maximum_length := mmc$default_maximum_seg_length;
    lov$allocated_segments^ [lov$highest_segment_index].segment :=
          #SEGMENT (heap_segment_pointer.heap_pointer);
    lov$allocated_segments^ [lov$highest_segment_index].attributes.access_control.execute_privilege :=
          osc$non_executable;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.access_control.read_privilege :=
          osc$read_uncontrolled;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.access_control.write_privilege :=
          osc$write_uncontrolled;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.r1 := caller.ring;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.r2 := caller.ring;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.stack := FALSE;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.extensible := FALSE;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.debug_segment := FALSE;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.apd_binding_segment := FALSE;

  PROCEND pmp$create_ada_heap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$debug_logging_enabled', EJECT ??
*copy pmh$debug_logging_enabled

  FUNCTION [XDCL, #GATE] pmp$debug_logging_enabled
    (    broken_task_message: boolean): boolean;

    IF broken_task_message THEN
      pmp$debug_logging_enabled := pmv$emit_broken_task_msg_to_sl;
    ELSE
      pmp$debug_logging_enabled := pmv$debug_logging_enabled;
    IFEND;

  FUNCEND pmp$debug_logging_enabled;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_stack_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$find_stack_segment
    (    ring: ost$ring;
     VAR stack_segment: ^pmt$stack_segment);

{  PURPOSE:
{    This procedure determines the stack segment associated with a specified ring in the
{    executing task.
{  NOTE:
{    This implementation is model_dependent.  A model_independent implementation requires a
{    monitor request to fetch the TOS register.
{    Consider moving this procedure to segment_management, since segment_management must
{    also handle stack segments in a model_independent fashion.  This would localize the
{    model_dependency considerations in a single area.

{!  This procedure should be gated if the stack_frame popper is to use it.

    VAR
      xcb: ^ost$execution_control_block,
      stack_segment_attributes: array [1 .. 2] of mmt$attribute_descriptor,
      stack_segment_pointer: mmt$segment_pointer,
      sequence_pointer: ^SEQ ( * ),
      tos_pointer: ^cell,
      local_status: ost$status;

    pmp$find_executing_task_xcb (xcb);
    tos_pointer := #ADDRESS (xcb^.xp.tos_registers [ring].pva.ring, xcb^.xp.tos_registers [ring].
          pva.seg, xcb^.xp.tos_registers [ring].pva.offset);
    IF tos_pointer = NIL THEN
      stack_segment_attributes [1].keyword := mmc$kw_ring_numbers;
      stack_segment_attributes [1].r1 := ring;
      stack_segment_attributes [1].r2 := ring;
      stack_segment_attributes [2].keyword := mmc$kw_software_attributes;
      stack_segment_attributes [2].software_attri_set := $mmt$software_attribute_set [mmc$sa_stack];
      mmp$create_segment (^stack_segment_attributes, mmc$sequence_pointer, 1, stack_segment_pointer,
            local_status);
      IF NOT local_status.normal THEN
        osp$system_error (unexpected_abnormal_status, ^local_status);
      IFEND;
      stack_segment := stack_segment_pointer.seq_pointer;
    ELSE
      i#build_adaptable_seq_pointer (xcb^.xp.tos_registers [ring].pva.ring,
            xcb^.xp.tos_registers [ring].pva.seg, 0, osc$maximum_offset,
            xcb^.xp.tos_registers [ring].pva.offset, sequence_pointer);
      stack_segment := sequence_pointer;
    IFEND;
  PROCEND pmp$find_stack_segment;
?? TITLE := '  [XDCL] pmp$get_loaded_rings', EJECT ??

  PROCEDURE [XDCL] pmp$get_loaded_rings
    (VAR loaded_rings: pmt$loadable_rings);

{  PURPOSE:
{    This procedure determines which rings in the executing task have had code sections loaded
{    into them, i.e., which rings have stack segments allocated.
{  NOTE:
{    This implementation is model_dependent.  A model_independent implementation requires a
{    monitor request to fetch the TOS register.
{    Consider moving this procedure to segment_management, since segment_management must
{    also handle stack segments in a model_independent fashion.  This would localize the
{    model_dependency considerations in a single area.

    VAR
      i: pmt$loadable_ring,
      tos_pointer: ^cell,
      xcb: ^ost$execution_control_block;

    loaded_rings := $pmt$loadable_rings [];
    pmp$find_executing_task_xcb (xcb);
    FOR i := LOWERVALUE (pmt$loadable_ring) TO UPPERVALUE (pmt$loadable_ring) DO
      tos_pointer := #ADDRESS (xcb^.xp.tos_registers [i].pva.ring, xcb^.xp.tos_registers [i].pva.seg,
            xcb^.xp.tos_registers [i].pva.offset);
      IF tos_pointer <> NIL THEN
        loaded_rings := loaded_rings + $pmt$loadable_rings [i];
      IFEND;
    FOREND;
  PROCEND pmp$get_loaded_rings;

?? TITLE := ' [XDCL, #GATE] pmp$get_program_size_in_bytes', EJECT ??

*copy pmh$get_program_size_in_bytes

  PROCEDURE [XDCL, #GATE] pmp$get_program_size_in_bytes
    (VAR program_size: ost$segment_length;
     VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.task_kind = osc$tk_nosve_task THEN
      program_size := #SIZE (tcb_p^.nosve.program_description^);
    ELSE { IF tcb_p^.task_kind = osc$tk_unix_task THEN
      program_size := 0;
    IFEND;

  PROCEND pmp$get_program_size_in_bytes;

?? TITLE := '  [XDCL, #GATE] pmp$get_program_size', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_program_size
    (VAR number_of_object_files: pmt$number_of_object_files;
     VAR number_of_modules: pmt$number_of_modules;
     VAR number_of_libraries: pmt$number_of_libraries;
     VAR status: ost$status);

    VAR
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.task_kind = osc$tk_nosve_task THEN
      program_description := tcb_p^.nosve.program_description;
      RESET program_description;
      NEXT program_attributes IN program_description;
      IF (pmc$object_file_list_specified IN program_attributes^.contents) THEN
        number_of_object_files := program_attributes^.number_of_object_files;
      ELSE
        number_of_object_files := 0;
      IFEND;
      IF (pmc$module_list_specified IN program_attributes^.contents) THEN
        number_of_modules := program_attributes^.number_of_modules;
      ELSE
        number_of_modules := 0;
      IFEND;
      IF (pmc$library_list_specified IN program_attributes^.contents) THEN
        number_of_libraries := program_attributes^.number_of_libraries;
      ELSE
        number_of_libraries := 0;
      IFEND;
    ELSE { IF tcb_p^.task_kind = osc$tk_unix_task THEN
      number_of_object_files := 0;
      number_of_modules := 0;
      number_of_libraries := 0;
    IFEND;

  PROCEND pmp$get_program_size;
?? TITLE := '  [XDCL, #GATE] pmp$get_parent_calling_ring', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_parent_calling_ring
    (VAR ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    ring := tcb_p^.target_ring;

  PROCEND pmp$get_parent_calling_ring;
?? TITLE := '  [XDCL, #GATE] pmp$get_program_description', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_program_description
    (VAR program_description: pmt$program_description;
     VAR status: ost$status);

    VAR
      current_program_descrip_size: ost$segment_length,
      new_program_description_size: ost$segment_length,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    new_program_description_size := #SIZE (program_description);
    current_program_descrip_size := #SIZE (tcb_p^.nosve.program_description^);
    IF ((new_program_description_size = current_program_descrip_size) OR
          ((new_program_description_size + #SIZE (pmt$enable_inhibit_conditions)) =
          current_program_descrip_size)) THEN
      i#move (tcb_p^.nosve.program_description, ^program_description, new_program_description_size);
    ELSE
      osp$set_status_condition (pme$prog_description_size_error, status);
    IFEND;

  PROCEND pmp$get_program_description;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_apd_task_jobmode_stats', EJECT ??
*copy pmh$get_apd_task_jobmode_stats

{ NOTE: This procedure is called by the ASSEMBLE deck PMM$INTERCEPT_PROCEDURES.
{ Any changes made to PMP$GET_APD_TASK_JOBMODE_STATS may require a change to
{ PMM$INTERCEPT_PROCEDURES.

  PROCEDURE [XDCL, #GATE] pmp$get_apd_task_jobmode_stats
    (VAR jobmode_statistics: pmt$apd_task_jobmode_statistics);

    VAR
      old_te: 0 .. 3,
      xcb_p: ^ost$execution_control_block;

    i#disable_traps (old_te);
    pmp$find_executing_task_xcb (xcb_p);
    jobmode_statistics.jobmode_cptime := xcb_p^.pit_count - #READ_REGISTER (osc$pr_process_interval_timer);
    jobmode_statistics.paging_statistics.page_in_count :=
          xcb_p^.paging_statistics.page_in_count + xcb_p^.paging_statistics.pages_from_server;
    jobmode_statistics.paging_statistics.pages_reclaimed_from_queue :=
          xcb_p^.paging_statistics.pages_reclaimed_from_queue;
    jobmode_statistics.paging_statistics.new_pages_assigned := xcb_p^.paging_statistics.new_pages_assigned;
    jobmode_statistics.paging_statistics.page_fault_count := xcb_p^.paging_statistics.page_fault_count;
    i#restore_traps (old_te);

  PROCEND pmp$get_apd_task_jobmode_stats;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$update_tos_ring_3', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$update_tos_ring_3
    (    top_of_stack: ^cell);


    pmp$update_tos_ring_1 (top_of_stack);


  PROCEND pmp$update_tos_ring_3;
?? TITLE := '  [XDCL, #GATE] pmp$clear_wait_inhibited', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$clear_wait_inhibited
    (VAR was_wait_inhibited: boolean;
     VAR status: ost$status);

    status.normal := TRUE;
    tmp$clear_wait_inhibited (was_wait_inhibited);

  PROCEND pmp$clear_wait_inhibited;

?? TITLE := '  [XDCL, #GATE] pmp$get_parent_task_id', EJECT ??
*copyc pmh$get_parent_task_id
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_parent_task_id
    (    child_task_id: pmt$task_id;
     VAR parent_task_id: pmt$task_id;
     VAR status: ost$status);

    CONST
      base_16 = 16,
      include_radix = TRUE;

    VAR
      child_tcb: ^pmt$task_control_block,
      strng: ost$string;

    status.normal := TRUE;

    pmp$find_task_tcb (child_task_id, child_tcb);
    IF (child_tcb = NIL) THEN
      clp$convert_integer_to_string (child_task_id, base_16, include_radix, strng, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osp$set_status_abnormal ('PM', pme$task_id_not_found, strng.value (1, strng.size), status);
      RETURN;
    IFEND;

    IF (child_tcb^.parent = NIL) THEN
      clp$convert_integer_to_string (child_task_id, base_16, include_radix, strng, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osp$set_status_abnormal ('PM', pme$task_has_no_parent, strng.value (1, strng.size), status);
      RETURN;
    IFEND;

    parent_task_id := child_tcb^.parent^.task_id;

  PROCEND pmp$get_parent_task_id;
?? TITLE := '  [XDCL, #GATE]  pmp$set_relative_priority', EJECT ??
*copyc pmh$set_relative_priority

  PROCEDURE [XDCL, #GATE] pmp$set_relative_priority
    (    priority: 0 .. 255;
     VAR status: ost$status);

    IF (priority < 0) OR (priority > 255) THEN
      osp$set_status_condition (pme$invalid_relative_priority, status);
      RETURN;
    IFEND;

    pmp$set_relative_priority_r1 (priority);

  PROCEND pmp$set_relative_priority;
?? TITLE := '  [XDCL, #GATE]  pmp$cause_intra_job_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$cause_intra_job_condition
    (    condition: pmt$condition_name;
         task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      signal: pmt$signal,
      xcb: ^ost$execution_control_block,
      vn: ost$name,
      valid: boolean,
      p_condition: ^pmt$condition_name;

    clp$validate_name (condition, vn, valid);
    IF NOT valid THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_condition_name, vn, status);
      RETURN;
    IFEND;
    IF vn <> osc$unseen_mail_condition THEN
      IF (vn (1, 4) = 'CYE$') OR (vn (1, 4) = 'OSC$') THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_condition_name, vn, status);
        RETURN;
      IFEND;
    IFEND;

    pmp$find_task_xcb (task_id, xcb);
    IF xcb = NIL THEN
      osp$set_status_condition (pme$unknown_recipient_task, status);
      RETURN;
    IFEND;

    signal.identifier := pmc$multi_task_condition;
    p_condition := #LOC (signal.contents);
    p_condition^ := condition;

    pmp$send_signal (xcb^.global_task_id, signal, status);

  PROCEND pmp$cause_intra_job_condition;
?? TITLE := '  [XDCL, #GATE] pmp$change_transient_to_write', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_transient_to_write
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_transient_to_write

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor;

    #CALLER_ID (caller_id);

    status.normal := TRUE;
    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      RETURN;
    IFEND;

    segment_attributes [1].access_control.write_privilege := osc$write_uncontrolled;
    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

  PROCEND pmp$change_transient_to_write;
?? TITLE := '  [XDCL, #GATE] pmp$change_transient_to_execute', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_transient_to_execute
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_transient_to_execute

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      RETURN;
    IFEND;

    segment_attributes [1].access_control.execute_privilege := osc$non_privileged;
    segment_attributes [1].access_control.write_privilege := osc$non_writable;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

  PROCEND pmp$change_transient_to_execute;
?? TITLE := '  [XDCL, #GATE] pmp$change_transient_to_binding', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_transient_to_binding
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_transient_to_binding

    VAR
      caller_id: ost$caller_identifier,
      code_base_pointer_array: ^array [1 .. osc$max_segment_length DIV 8] of ost$internal_code_base_pointer,
      conversion_pointer: ^cell,
      fde_entry_p: gft$file_desc_entry_p,
      index: 1 .. osc$max_segment_length DIV 8,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 3] of mmt$attribute_descriptor,
      segment_end_descriptor: pmt$established_handler;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    segment_attributes [3].keyword := mmc$kw_max_segment_length;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      RETURN;
    IFEND;

    conversion_pointer := #ADDRESS (osc$tsrv_ring, #SEGMENT (segment), 0);
    code_base_pointer_array := conversion_pointer;

    FOR index := 1 TO segment_attributes [3].max_length DIV 8 DO
      IF code_base_pointer_array^ [index].r3 <> 0 THEN
        IF code_base_pointer_array^ [index].r3 <> caller_id.ring THEN
          osp$set_status_condition (pme$code_base_pointer_error, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    segment_attributes [1].access_control.read_privilege := osc$binding_segment;
    segment_attributes [1].access_control.write_privilege := osc$non_writable;
    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

  PROCEND pmp$change_transient_to_binding;
?? TITLE := '  [XDCL, #GATE] pmp$change_binding_to_write', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_binding_to_write
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_binding_to_write

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor;

    #CALLER_ID (caller_id);

    status.normal := TRUE;
    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      RETURN;
    IFEND;

    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    segment_attributes [1].access_control.write_privilege := osc$write_uncontrolled;
    segment_attributes [1].access_control.read_privilege := osc$read_uncontrolled;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

  PROCEND pmp$change_binding_to_write;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] PMP$READY_TASK_LIST', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$ready_task_list
    (    taskid_list_size: ost$task_index;
     VAR taskid_list: {input} pmt$ready_task_list;
         taskid_response_list_p: {output} ^pmt$ready_task_response_list;
     VAR first_bad_task_id_index: ost$task_index;
     VAR status: ost$status);

    status.normal := TRUE;
    pmp$ready_task_list_r1 (taskid_list_size - 1, taskid_list, taskid_response_list_p,
          first_bad_task_id_index, status);

  PROCEND pmp$ready_task_list;
?? NEWTITLE := '    [XDCL, #GATE] pmp$meape_segments_constrained', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$meape_segments_constrained
    (VAR constrained: boolean);

*copyc pmv$constrain_meape_segments

    constrained := pmv$constrain_meape_segments;
  PROCEND pmp$meape_segments_constrained;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$post_unseen_mail', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$post_unseen_mail;

{  This procedure records that unseen_mail condition processing has been postponed.

    IF osp$is_caller_system_privileged () THEN
      pmv$unseen_mail_pending := TRUE;
    IFEND;
  PROCEND pmp$post_unseen_mail;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$schedule_unseen_mail', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$schedule_unseen_mail;

{  This procedure records that unseen_mail condition processing is no longer postponed.

    IF osp$is_caller_system_privileged () THEN
      pmv$unseen_mail_pending := FALSE;
    IFEND;
  PROCEND pmp$schedule_unseen_mail;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$inward_call', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$inward_call
    (    callee: ^ost$external_code_base_pointer;
         target_ring: ost$ring;
         callee_parameter_list: ^cell;
         callee_previous_save_area: ^ost$stack_frame_save_area);

{ This request allows an operating system procedure executing in
{ a less privileged ring to call another operating system procedure
{ to execute in a more privileged ring.

    VAR
      stack_offset_pad_p: ^array [1 .. *] of cell,
      stack_segment: ^pmt$stack_segment;


    osp$verify_system_privilege;

    osp$verify_system_segment (callee^.code_pva);

    IF target_ring <= osc$tsrv_ring THEN
      osp$force_access_violation;
    IFEND;

    pmp$find_stack_segment (target_ring, stack_segment);
    RESET stack_segment;
    NEXT stack_offset_pad_p: [1 .. (mmv$page_map_offsets [mmc$pmo_user_stack] * osv$page_size) +
          mmc$ring_crossing_offset] IN stack_segment;
    pmp$outward_call (callee, target_ring, callee_parameter_list, callee_previous_save_area, stack_segment);

  PROCEND pmp$inward_call;
?? OLDTITLE ??
MODEND pmm$tasking_support_ring_3;
