?? RIGHT := 110, LEFT := 1 ??
?? NEWTITLE := 'MMM$SEGMENT_MANAGER_JOB_TEMP' ??
MODULE mmm$segment_manager_job_temp;

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc dfe$error_condition_codes
*copyc dmt$addr_length_pair
*copyc dmt$error_condition_codes
*copyc gft$locked_file_desc_entry_p
*copyc gft$file_descriptor_entry
*copyc gft$system_file_identifier
*copyc mme$condition_codes
*copyc mmt$access_selections
*copyc mmt$attribute_keyword
*copyc mmt$lock_segment_status
*copyc mmt$segment_attrib_descriptor
*copyc mmt$user_attribute_descriptor
*copyc mmt$va_access_mode
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$system_flag
*copyc ost$system_privilege_map
*copyc sft$file_space_limit_kind
?? POP ??
?? EJECT ??
*copyc bap$exit_fap_on_condition
*copyc dfp$set_server_eoi
*copyc dpp$put_critical_message
*copyc dmp$get_initialized_addresses
*copyc dsp$system_committed
*copyc fmp$ln_open_chapter
*copyc gfp$get_fde_p
*copyc gfv$null_sfid
*copyc i#move
*copyc mmp$advise_out
*copyc mmp$assign_contiguous_memory
*copyc mmp$build_segment
*copyc mmp$change_seg_inheritance_r1
*copyc mmp$change_segment_number_r1
*copyc mmp$change_stack_attribute_r1
*copyc mmp$convert_ps_transfer_size
*copyc mmp$fetch_sdt_sdtx_locked_fde
*copyc mmp$fetch_offset_mod_pages_r1
*copyc mmp$fetch_segment_attributes_r1
*copyc mmp$get_allocated_addresses_r1
*copyc mmp$get_page_size
*copyc mmp$get_segment_length_r1
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc mmp$initiate_shadowing_r1
*copyc mmp$invalidate_segment
*copyc mmp$preset_page_streaming_r1
*copyc mmp$process_file_alloc
*copyc mmp$reserve_segment_number_r1
*copyc mmp$set_access_selections_r1
*copyc mmp$set_segment_length_r1
*copyc mmp$store_segment_attributes_r1
*copyc mmp$terminate_shadowing_r1
*copyc mmp$validate_segment_number
*copyc mmp$write_modified_pages
*copyc mmv$file_allocation_interval
*copyc mmv$shadow_by_segnum
*copyc mmv$temp_file_space_guard
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc osv$initial_exception_context
*copyc osv$page_size
*copyc osv$task_private_heap
*copyc pmp$exit
*copyc pmp$find_executing_task_xcb
*copyc pmp$log
*copyc pmp$task_state

{  Define variables that are global to this module.

  VAR
    osv$system_privilege_map: [XDCL, #GATE, oss$task_private] ost$system_privilege_map :=
          [REP (mmc$default_sdt_length + 1) of TRUE];

?? TITLE := 'DETERMINE_VALIDATING_RING_NUM' ??
?? EJECT ??

  PROCEDURE [INLINE] determine_validating_ring_num
    (    caller_ring: ost$ring;
         validation_ring_number: ost$valid_ring;
     VAR validating_ring_num: ost$valid_ring);

    IF validation_ring_number < caller_ring THEN
      validating_ring_num := caller_ring;
    ELSE
      validating_ring_num := validation_ring_number;
    IFEND;

  PROCEND determine_validating_ring_num;

?? TITLE := 'UPDATE_PASSIVE_WITH_ACTIVE', EJECT ??

  PROCEDURE update_passive_with_active
    (    segment_p: ^cell;
     VAR status: ost$status);

    TYPE
      offset_list = array [1 .. * ] of ost$segment_offset;

    VAR
      access_selections: mmt$access_selections,
      address_list: array [1 .. 100] of dmt$addr_length_pair,
      addr_returned: integer,
      dest_p: mmt$segment_pointer,
      dest: ^cell,
      dm_element_length: ost$segment_length,
      dm_element_offset: ost$segment_offset,
      fde_p: gft$file_desc_entry_p,
      file_limits_to_enforce: sft$file_space_limit_kind,
      i: integer,
      in_memory: boolean,
      list_overflow: boolean,
      list_p: ^offset_list,
      local_status: ost$status,
      memory_list_index: integer,
      offsets_returned: integer,
      sdt_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      source: ^cell,
      starting_addr: ost$segment_offset;

{  Get access selection before change to restore at end of proc.

    mmp$validate_segment_number (#SEGMENT (segment_p), sdt_p, sdtx_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sdtx_p^.software_attribute_set = $mmt$software_attribute_set
          [mmc$sa_read_transfer_unit, mmc$sa_free_behind] THEN
      access_selections := mmc$as_sequential;
    ELSEIF sdtx_p^.software_attribute_set = $mmt$software_attribute_set [mmc$sa_read_transfer_unit] THEN
      access_selections := mmc$as_read_tu;
    ELSE
      access_selections := mmc$as_random;
    IFEND;

{  Set read_transfer_unit attribute in ACTIVE segment.

    mmp$set_access_selections (segment_p, mmc$as_sequential, status);

{  Obtain access to PASSIVE segment.

    mmp$open_file_segment (sdtx_p^.shadow_info.shadow_sfid, NIL, mmc$cell_pointer, 1, sfc$no_limit, dest_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    offsets_returned := 100;
    REPEAT
      ALLOCATE list_p: [1 .. offsets_returned] IN osv$task_private_heap^;
      mmp$fetch_offset_modified_pages (segment_p, FALSE {return_unallocated_offsets} , list_p^,
            offsets_returned, status);
      IF NOT status.normal THEN
        FREE list_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
      IF offsets_returned > UPPERBOUND (list_p^) THEN
        FREE list_p IN osv$task_private_heap^;
      IFEND;
    UNTIL offsets_returned <= UPPERBOUND (list_p^);

    IF offsets_returned <> 0 THEN
{  Convert offsets to PVAs and move all modified pages from the ACTIVE segment
      FOR i := 1 TO offsets_returned DO
        source := #ADDRESS (1, #SEGMENT (segment_p), list_p^ [i]);
        dest := #ADDRESS (1, #SEGMENT (dest_p.cell_pointer), list_p^ [i]);
        i#move (source, dest, osv$page_size);
        mmp$advise_out (dest, osv$page_size, status);
      FOREND;
    IFEND;


{  Determine whether the segment is assigned to a device.
{  Get and move all initialized addresses from ACTIVE file.
{  If the segment is not assigned, no further action is then required.


    starting_addr := 0;
    gfp$get_fde_p (sdtx_p^.sfid, fde_p);
    list_overflow := (fde_p^.media = gfc$fm_mass_storage_file);

  /get_list_of_addresses/
    WHILE list_overflow DO
      dmp$get_initialized_addresses (sdtx_p^.sfid, starting_addr, address_list, addr_returned, list_overflow,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF addr_returned <> 0 THEN
        FOR i := 1 TO addr_returned DO

{ Look for offsets which may have already been written. Specifically, we are looking for pages which are on
{ disk and are not modified in real memory at the same time.

          dm_element_length := address_list [i].length;
          dm_element_offset := address_list [i].addr;
          memory_list_index := 1;
          WHILE (dm_element_length > 0) AND (memory_list_index > 0) DO
            memory_list_index := offsets_returned;

{ Search the list (of offsets of all modified pages for the ACTIVE segment) for the equivalent offset returned
{ from Device Management.  If ANY of the pages in <addr + length> are not found, move the disk pages, starting
{ at <address_list [i].addr> and continuing through <address_list [i].addr + address_list [i].length.>.  In
{ this case we MAY overwrite some addresses which were processed in the previous update above, but this is OK.

            WHILE (memory_list_index > 0) AND (list_p^ [memory_list_index] <> dm_element_offset) DO
              memory_list_index := memory_list_index - 1;
            WHILEND;
            dm_element_offset := dm_element_offset + osv$page_size;
            dm_element_length := dm_element_length - osv$page_size;
          WHILEND;

          IF memory_list_index = 0 THEN

{ The address offset returned from DM was not written (either partially or completely) in the previous
{ process; write it now.

            source := #ADDRESS (1, #SEGMENT (segment_p), address_list [i].addr);
            dest := #ADDRESS (1, #SEGMENT (dest_p.cell_pointer), address_list [i].addr);
            i#move (source, dest, address_list [i].length);
            mmp$advise_out (source, address_list [i].length, status);
            mmp$advise_out (dest, address_list [i].length, status);
          IFEND;
        FOREND;
        starting_addr := address_list [addr_returned].addr + address_list [addr_returned].length;
      IFEND;
    WHILEND /get_list_of_addresses/;

    mmp$set_access_selections (segment_p, access_selections, status);
    mmp$close_segment (dest_p, 1, local_status);
    FREE list_p IN osv$task_private_heap^;

  PROCEND update_passive_with_active;
?? TITLE := 'MMP$CHANGE_SEGMENT_INHERITANCE' ??
?? EJECT ??
*copyc mmh$change_segment_inheritance

  PROCEDURE [XDCL] mmp$change_segment_inheritance
    (    pva: ^cell;
         segment_inheritance: mmt$segment_inheritance;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, #RING (pva), validating_ring_number);
    mmp$change_seg_inheritance_r1 (#SEGMENT (pva), validating_ring_number, segment_inheritance, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$change_segment_inheritance;

?? TITLE := 'MMP$CHANGE_SEGMENT_NUMBER' ??
?? EJECT ??
*copyc mmh$change_segment_number

  PROCEDURE [XDCL] mmp$change_segment_number
    (    segment_pointer: amt$segment_pointer;
         segment_number: ost$segment;
         validation_ring_number: ost$valid_ring;
     VAR new_segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_segment_pointer: amt$segment_pointer,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$change_segment_number_r1 (#SEGMENT (segment_pointer.cell_pointer), segment_number,
          validating_ring_number, r1_status);
    IF r1_status.normal THEN
      new_segment_pointer := segment_pointer;
      new_segment_pointer.cell_pointer := #ADDRESS (#RING (segment_pointer.cell_pointer),
            segment_number, #OFFSET (segment_pointer.cell_pointer));
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$change_segment_number;

?? TITLE := 'MMP$CHANGE_STACK_ATTRIBUTE', EJECT ??
*copyc mmh$change_stack_attribute

  PROCEDURE [XDCL, #GATE] mmp$change_stack_attribute
    (    stack_pages_to_be_freed: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    mmp$change_stack_attribute_r1 (stack_pages_to_be_freed, caller_id.ring, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$change_stack_attribute;

?? TITLE := 'MMP$CLOSE_SEGMENT', EJECT ??
*copyc mmh$close_segment

  PROCEDURE [XDCL, #GATE] mmp$close_segment
    (VAR pointer: mmt$segment_pointer;
         validation_ring_number: ost$valid_ring;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), validating_ring_number,
          NIL {shared_taskid_array}, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer.cell_pointer := NIL;
    IFEND;

  PROCEND mmp$close_segment;
?? TITLE := 'MMP$CLOSE_SHARED_STACK', EJECT ??
*copyc mmh$close_shared_stack

  PROCEDURE [XDCL] mmp$close_shared_stack
    (VAR pointer: mmt$segment_pointer;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), caller_id.ring, shared_taskid_array, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer.cell_pointer := NIL;
    IFEND;

  PROCEND mmp$close_shared_stack;
?? TITLE := 'MMP$CREATE_SCRATCH_SEGMENT', EJECT ??
*copyc mmh$create_scratch_segment

  PROCEDURE [XDCL, #GATE] mmp$create_scratch_segment
    (    pointer_kind: amt$pointer_kind;
         access_selections: mmt$access_selections;
     VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      kind: mmt$segment_pointer_kind,
      p: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    IF pointer_kind = amc$cell_pointer THEN
      kind := mmc$cell_pointer;
    ELSEIF pointer_kind = amc$sequence_pointer THEN
      kind := mmc$sequence_pointer;
    ELSE
      kind := mmc$heap_pointer;
    IFEND;
    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$temp_file_space_limit;
    segment_attributes.pointer_kind := kind;
    segment_attributes.user_attributes := NIL;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , p, r1_status);

    IF r1_status.normal THEN
      IF access_selections = mmc$as_sequential THEN
        mmp$set_access_selections (p.cell_pointer, mmc$as_sequential, status);
      IFEND;
      pointer.kind := pointer_kind;
      IF pointer_kind = amc$cell_pointer THEN
        pointer.cell_pointer := p.cell_pointer;
      ELSEIF pointer_kind = amc$sequence_pointer THEN
        pointer.sequence_pointer := p.seq_pointer;
      ELSE
        pointer.heap_pointer := p.heap_pointer;
      IFEND;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$create_scratch_segment;

?? TITLE := 'MMP$CREATE_SEGMENT', EJECT ??
*copyc mmh$create_segment

  PROCEDURE [XDCL, #GATE] mmp$create_segment
    (    seg_attributes_p: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         validation_ring_number: ost$valid_ring;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    segment_attributes.validating_ring_number := validating_ring_number;
    IF mmv$temp_file_space_guard THEN
    segment_attributes.file_limits_to_enforce := sfc$temp_file_space_limit;
    ELSE
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    IFEND;
    segment_attributes.pointer_kind := pointer_kind;
    segment_attributes.user_attributes := seg_attributes_p;
    segment_attributes.sfid := gfv$null_sfid;
    IF segment_attributes.user_attributes <> NIL THEN
      PUSH segment_attributes.user_attributes: [LOWERBOUND (seg_attributes_p^
            ) .. UPPERBOUND (seg_attributes_p^)];
      segment_attributes.user_attributes^ := seg_attributes_p^;
    IFEND;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer := r1_pointer;
    IFEND;

  PROCEND mmp$create_segment;
?? TITLE := 'MMP$CREATE_SHADOW_SEGMENT', EJECT ??
*copyc mmh$create_shadow_segment

  PROCEDURE [XDCL, #GATE] mmp$create_shadow_segment
    (    segment_p: ^cell;
         shadow_offset: ost$segment_offset;
         shadow_length: ost$segment_length;
         pointer_kind: mmt$segment_pointer_kind;
     VAR pva: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      conv_ptr: ^cell,
      i: pmt$initialization_value,
      preset_value: pmt$initialization_value,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor,
      segnum: ost$segment;

    status.normal := TRUE;
    conv_ptr := #ADDRESS (#RING (segment_p), #SEGMENT (segment_p), shadow_offset);

{  Issue request to create ACTIVE segment.
    #CALLER_ID (caller_id);
    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    segment_attributes.pointer_kind := pointer_kind;
    PUSH segment_attributes.user_attributes: [1 .. 1];
    segment_attributes.user_attributes^ [1].keyword := mmc$kw_shadow_segment;
    segment_attributes.user_attributes^ [1].shadow_p := conv_ptr;
    segment_attributes.user_attributes^ [1].shadow_length := shadow_length;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pva := r1_pointer;
    IFEND;

  PROCEND mmp$create_shadow_segment;

?? TITLE := 'MMP$CREATE_SHARED_STACK', EJECT ??
*copyc mmh$create_shared_stack

  PROCEDURE [XDCL] mmp$create_shared_stack
    (    seg_attributes_p: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    segment_attributes.pointer_kind := pointer_kind;
    segment_attributes.user_attributes := seg_attributes_p;
    IF segment_attributes.user_attributes <> NIL THEN
      PUSH segment_attributes.user_attributes: [LOWERBOUND (seg_attributes_p^
            ) .. UPPERBOUND (seg_attributes_p^)];
      segment_attributes.user_attributes^ := seg_attributes_p^;
    IFEND;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, shared_taskid_array, r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer := r1_pointer;
    IFEND;

  PROCEND mmp$create_shared_stack;
?? TITLE := 'MMP$CREATE_USER_SEGMENT' ??
?? EJECT ??
*copyc mmh$create_user_segment

  PROCEDURE [XDCL, #GATE] mmp$create_user_segment
    (    user_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;
         pointer_kind: amt$pointer_kind;
         access_selections: mmt$access_selections;
     VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      byte: 0 .. 255,
      caller_id: ost$caller_identifier,
      contiguous_flag: boolean,
      contiguous_page_count: integer,
      file_limits_to_enforce: sft$file_space_limit_kind,
      i: integer,
      increment: integer,
      kind: mmt$segment_pointer_kind,
      local_status: ost$status,
      max_length_index: integer,
      max_length_specified: boolean,
      page_size: integer,
      preset_pointer: ^array [ * ] of 0 .. 255,
      r1_status: ost$status,
      save_index: integer,
      seg_attrib_p: ^array [ * ] of mmt$attribute_descriptor,
      segment_attributes: mmt$segment_attrib_descriptor,
      segment_pointer: mmt$segment_pointer,
      seq_p: ^SEQ ( * ),
      wired_flag: boolean,
      wired_index: integer;

    contiguous_flag := FALSE;
    status.normal := TRUE;
    max_length_specified := FALSE;
    wired_flag := FALSE;

    IF user_attributes_p <> NIL THEN
      PUSH seg_attrib_p: [LOWERBOUND (user_attributes_p^) .. UPPERBOUND (user_attributes_p^)];

      FOR i := LOWERBOUND (user_attributes_p^) TO UPPERBOUND (user_attributes_p^) DO
        CASE user_attributes_p^ [i].keyword OF
        = mmc$ua_ring_numbers =
          seg_attrib_p^ [i].keyword := mmc$kw_ring_numbers;
          seg_attrib_p^ [i].r1 := user_attributes_p^ [i].r1;
          seg_attrib_p^ [i].r2 := user_attributes_p^ [i].r2;
        = mmc$ua_segment_number =
          seg_attrib_p^ [i].keyword := mmc$kw_segment_number;
          seg_attrib_p^ [i].segnum := user_attributes_p^ [i].segnum;
        = mmc$ua_max_segment_length =
          seg_attrib_p^ [i].keyword := mmc$kw_max_segment_length;
          seg_attrib_p^ [i].max_length := user_attributes_p^ [i].max_length;
          max_length_specified := TRUE;
          max_length_index := i;
        = mmc$ua_preset_value =
          seg_attrib_p^ [i].keyword := mmc$kw_preset_value;
          seg_attrib_p^ [i].preset_value := user_attributes_p^ [i].preset_value;
        = mmc$ua_segment_access_control =
          seg_attrib_p^ [i].keyword := mmc$kw_segment_access_control;
          seg_attrib_p^ [i].access_control := user_attributes_p^ [i].access_control;
        = mmc$ua_wired_segment =
          seg_attrib_p^ [i].keyword := mmc$kw_wired_segment;
          IF user_attributes_p^ [i].wired_segment_length > 65536 THEN
            osp$set_status_abnormal ('MM', mme$wired_seg_length_too_large, '', status);
            RETURN;
          IFEND;
          seg_attrib_p^ [i].wired_segment_length := user_attributes_p^ [i].wired_segment_length;
          IF user_attributes_p^ [i].contiguous_real_memory THEN
            contiguous_flag := TRUE;
          IFEND;
          wired_flag := TRUE;
          wired_index := i;
        = mmc$ua_null_keyword =
          seg_attrib_p^ [i].keyword := mmc$kw_null_keyword;
        ELSE
        CASEND;
      FOREND;
    ELSE
      seg_attrib_p := NIL;
    IFEND;

    IF max_length_specified AND wired_flag THEN
      seg_attrib_p^ [max_length_index].max_length := seg_attrib_p^ [wired_index].wired_segment_length;
    IFEND;

    IF pointer_kind = amc$cell_pointer THEN
      kind := mmc$cell_pointer;
    ELSEIF pointer_kind = amc$sequence_pointer THEN
      kind := mmc$sequence_pointer;
    ELSE
      kind := mmc$heap_pointer;
    IFEND;
    #CALLER_ID (caller_id);

    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$temp_file_space_limit;
    segment_attributes.pointer_kind := kind;
    segment_attributes.user_attributes := seg_attrib_p;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , segment_pointer, r1_status);

    IF r1_status.normal THEN
      IF access_selections = mmc$as_sequential THEN
        mmp$set_access_selections (segment_pointer.cell_pointer, mmc$as_sequential, status);
      IFEND;
      pointer.kind := pointer_kind;
      IF pointer_kind = amc$cell_pointer THEN
        seq_p := #SEQ (segment_pointer.cell_pointer^);
        RESET seq_p;
        NEXT preset_pointer: [1 .. #SIZE (segment_pointer.cell_pointer^)] IN seq_p;
        pointer.cell_pointer := segment_pointer.cell_pointer;
      ELSEIF pointer_kind = amc$sequence_pointer THEN
        seq_p := #SEQ (segment_pointer.seq_pointer^);
        RESET seq_p;
        NEXT preset_pointer: [1 .. #SIZE (segment_pointer.seq_pointer^)] IN seq_p;
        pointer.sequence_pointer := segment_pointer.seq_pointer;
      ELSE
        seq_p := #SEQ (segment_pointer.heap_pointer^);
        RESET seq_p;
        NEXT preset_pointer: [1 .. #SIZE (segment_pointer.heap_pointer^)] IN seq_p;
        pointer.heap_pointer := segment_pointer.heap_pointer;
      IFEND;

      IF contiguous_flag THEN
        mmp$assign_contiguous_memory (pointer.cell_pointer, seg_attrib_p^ [wired_index].wired_segment_length,
              status);

        { MMP$ASSIGN_CONTIGUOUS_MEMORY will PRESET the pages it assigns to the segment--
        { if it was able to assign contiguous pages.

        IF NOT status.normal THEN
          mmp$delete_user_segment (pointer, local_status);
          RETURN;
        IFEND;
      ELSEIF wired_flag AND NOT contiguous_flag THEN

        { PRESET the pages of a wired segment-this is accomplished by touching every page in the segment.}

        mmp$get_page_size (page_size);
        increment := 1;
        WHILE increment < UPPERBOUND (preset_pointer^) DO
          byte := preset_pointer^ [increment];
          increment := increment + page_size;
        WHILEND;
      IFEND;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$create_user_segment;
?? TITLE := 'MMP$DELETE_SCRATCH_SEGMENT', EJECT ??
*copyc mmh$delete_scratch_segment

  PROCEDURE [XDCL, #GATE] mmp$delete_scratch_segment
    (VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      p: mmt$segment_pointer,
      r1_status: ost$status;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    p.kind := mmc$cell_pointer;
    p.cell_pointer := pointer.cell_pointer;

    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), caller_id.ring, NIL {shared_taskid_array} ,
          r1_status);
    IF r1_status.normal THEN
      pointer.cell_pointer := NIL;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$delete_scratch_segment;

?? TITLE := 'MMP$DELETE_SEGMENT' ??
?? EJECT ??
*copyc mmh$delete_segment

  PROCEDURE [XDCL, #GATE] mmp$delete_segment
    (VAR pointer: mmt$segment_pointer;
         validation_ring_number: ost$valid_ring;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), validating_ring_number,
          NIL {shared_taskid_array}, r1_status);
    IF r1_status.normal THEN
      pointer.cell_pointer := NIL;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$delete_segment;
?? TITLE := 'MMP$DELETE_USER_SEGMENT' ??
?? EJECT ??
*copyc mmh$delete_user_segment

  PROCEDURE [XDCL, #GATE] mmp$delete_user_segment
    (VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), caller_id.ring, NIL {shared_taskid_array} ,
          r1_status);
    IF r1_status.normal THEN
      pointer.cell_pointer := NIL;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$delete_user_segment;
?? TITLE := 'MMP$FAILED_ALLOCATION_FLAG_HDL' ??
?? EJECT ??
*copyc mmh$failed_allocation_flag_hdl

  PROCEDURE [XDCL] mmp$failed_allocation_flag_hdl
    (    flag_id: ost$system_flag);

    VAR
      i: integer,
      new_allocated_length: amt$file_byte_address,
      segnum: ost$segment,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);

    WHILE TRUE DO
      mmp$process_file_alloc (new_allocated_length, status);
      IF status.normal THEN
        RETURN;
      IFEND;

{ Any abnormal status which is actually returned to this procedure is an 'OK' status, which
{ will cause the system to keep attempting to allocate file_space for this task.
{ In the case of the File_Server, however, we don't want to wait forever because the server
{ may not EVER come back.  Just return; the next time the user references the page the correct
{ condition will be raised.

      IF (status.condition = dfe$family_not_served) OR (status.condition = dfe$server_not_active) OR
            (status.condition = dfe$server_has_terminated) THEN
        RETURN;
      IFEND;

      IF (xcb_p^.system_flags * $tmt$system_flags [jmc$kill_job_flag, pmc$kill_task_flag] <>
            $tmt$system_flags []) AND (xcb_p^.system_table_lock_count <= 0) THEN
        pmp$log (' Job KILLED while waiting for file allocation.', status);
        pmp$exit (status);
      IFEND;

      IF (xcb_p^.system_flags = $tmt$system_flags []) THEN
        FOR i := 1 TO tmc$maximum_signals DO
          IF xcb_p^.signals.present [i] THEN
            RETURN;
          IFEND;
        FOREND;
      ELSE
        RETURN;
      IFEND;

{ If the task is terminating, let it go on and attempt to continue termination.

      IF pmp$task_state () = pmc$task_terminating THEN
        RETURN;
      IFEND;

      IF status.condition = dme$unable_to_alloc_all_space THEN
        IF dsp$system_committed () THEN
          bap$exit_fap_on_condition (dme$unable_to_alloc_all_space);
          RETURN;
        ELSE
          {
          { System disk full in early deadstart.
          {
          dpp$put_critical_message ('The system disk is full - redeadstart without job recovery', status);
        IFEND;
      IFEND;

    WHILEND;

  PROCEND mmp$failed_allocation_flag_hdl;
?? TITLE := 'MMP$FETCH_OFFSET_MODIFIED_PAGES', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$fetch_offset_modified_pages
    (    segment_p: ^cell;
         return_unallocated_offsets: boolean;
     VAR offset_list: array [ * ] of ost$segment_offset;
     VAR offsets_returned: integer;
     VAR status: ost$status);

    VAR
      i: integer,
      r1_offset_list_p: ^array [ * ] of ost$segment_offset,
      r1_offsets_returned: integer,
      r1_status: ost$status;

    status.normal := TRUE;
    PUSH r1_offset_list_p: [1 .. UPPERBOUND (offset_list)];
    mmp$fetch_offset_mod_pages_r1 (#SEGMENT (segment_p), gfv$null_sfid, return_unallocated_offsets,
        r1_offset_list_p, r1_offsets_returned, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      offset_list := r1_offset_list_p^;
      offsets_returned := r1_offsets_returned;
    IFEND;

  PROCEND mmp$fetch_offset_modified_pages;

?? TITLE := 'MMP$FETCH_SEGMENT_ATTRIBUTES' ??
?? EJECT ??
*copyc mmh$fetch_segment_attributes

  PROCEDURE [XDCL, #GATE] mmp$fetch_segment_attributes
    (    pva: ^cell;
     VAR seg_attributes: array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      i: integer,
      r1_status: ost$status,
      r1_segment_attributes_p: ^array [ * ] of mmt$attribute_descriptor;

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    PUSH r1_segment_attributes_p: [LOWERBOUND (seg_attributes) .. UPPERBOUND (seg_attributes)];
    r1_segment_attributes_p^ := seg_attributes;
    mmp$fetch_segment_attributes_r1 (#SEGMENT (pva), caller_id.ring, r1_segment_attributes_p, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      seg_attributes := r1_segment_attributes_p^;
    IFEND;

  PROCEND mmp$fetch_segment_attributes;
?? TITLE := 'MMP$GET_ALLOCATED_ADDRESSES', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$get_allocated_addresses
    (    file: ^cell;
         starting_byte_address: ost$segment_offset;
     VAR addr_list: array [ * ] of dmt$addr_length_pair;
     VAR addr_returned: integer;
     VAR list_overflow: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      i: integer,
      r1_addr_list_p: ^array [ * ] of dmt$addr_length_pair,
      r1_addr_returned: integer,
      r1_list_overflow: boolean,
      r1_status: ost$status;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    PUSH r1_addr_list_p: [LOWERBOUND (addr_list) .. UPPERBOUND (addr_list)];
    mmp$get_allocated_addresses_r1 (#SEGMENT (file), caller_id.ring, starting_byte_address, r1_addr_list_p,
          r1_addr_returned, r1_list_overflow, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      addr_list := r1_addr_list_p^;
      list_overflow := r1_list_overflow;
      addr_returned := r1_addr_returned;
    IFEND;
  PROCEND mmp$get_allocated_addresses;

?? TITLE := 'MMP$GET_SEGMENT_LENGTH' ??
?? EJECT ??
*copy mmh$get_segment_length

  PROCEDURE [XDCL, #GATE] mmp$get_segment_length
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
     VAR segment_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_segment_length: ost$segment_length,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    status.normal := TRUE;
    segment_length := 0;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$get_segment_length_r1 (#SEGMENT (pva), validating_ring_number, r1_segment_length, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      segment_length := r1_segment_length;
    IFEND;

  PROCEND mmp$get_segment_length;

?? TITLE := 'MMP$INITIATE_DEBUG_SHADOWING' ??
?? EJECT ??
*copyc mmh$initiate_debug_shadowing

  PROCEDURE [XDCL, #GATE] mmp$initiate_debug_shadowing
    (    segment_pointer: ^cell;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: ^cell,
      r1_status: ost$status,
      validating_ring: ost$valid_ring;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Change the segment attributes to WRITE and flush the pages to disk.

    mmp$write_modified_pages (segment_pointer, osc$maximum_offset, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Issue ring_1 call to establish ACTIVE segment.

    r1_pointer := segment_pointer;
    mmp$initiate_shadowing_r1 (r1_pointer, caller_id.ring, mmc$ssk_read_only_file, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$initiate_debug_shadowing;
?? TITLE := 'MMP$INITIATE_SHADOWING' ??
?? EJECT ??
*copyc mmh$initiate_shadowing

  PROCEDURE [XDCL, #GATE] mmp$initiate_shadowing
    (    segment_p: ^cell;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: ^cell,
      r1_status: ost$status;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Change the segment attributes to WRITE and flush the pages to disk.

    mmp$write_modified_pages (segment_p, osc$maximum_offset, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


{  Issue ring_1 call to establish ACTIVE segment.

    r1_pointer := segment_p;
    mmp$initiate_shadowing_r1 (r1_pointer, #RING (segment_p), mmc$ssk_read_write_file, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$initiate_shadowing;
?? TITLE := 'MMP$OPEN_FILE_SEGMENT' ??
?? EJECT ??
*copyc mmh$open_file_segment

  PROCEDURE [XDCL] mmp$open_file_segment
    (    sfid: gft$system_file_identifier,
         attr_p: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         validation_ring_number: ost$valid_ring;
         file_limits_to_enforce: sft$file_space_limit_kind;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    segment_attributes.validating_ring_number := validating_ring_number;
    segment_attributes.file_limits_to_enforce := file_limits_to_enforce;
    segment_attributes.pointer_kind := pointer_kind;
    segment_attributes.user_attributes := attr_p;
    IF segment_attributes.user_attributes <> NIL THEN
      PUSH segment_attributes.user_attributes: [LOWERBOUND (attr_p^) .. UPPERBOUND (attr_p^)];
      segment_attributes.user_attributes^ := attr_p^;
    IFEND;
    segment_attributes.sfid := sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer := r1_pointer;
    IFEND;

  PROCEND mmp$open_file_segment;
?? TITLE := ' mmp$open_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$open_segment
    (    file_name: ost$name;
         seg_attributes: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);
    fmp$ln_open_chapter (file_name, 0, caller_id.ring, seg_attributes, pointer_kind, pointer, status);

  PROCEND mmp$open_segment;
?? TITLE := 'MMP$PRESET_PAGE_STREAMING', EJECT ??
{--------------------------------------------------------------------------------------------------------
{ PURPOSE:
{ Procedure mmp$preset_page_streaming provides the capability of presetting the SDTX of a segment so that
{ it is already in page streaming mode, with free behind TRUE and the transfer size as specified.  It returns
{ the original values of free behind and transfer size so that the caller can call again later and restore
{ the original values.
{
{ DESIGN:
{ There is nothing fancy,  The boolean "preset_and_save_ts_fb" indicates the purpose of a call,  a value
{ of TRUE indicates preset and save the original values, a value of FALSE indicates a restore.  Nothing is
{ done to ensure calls are in order or completed.  In preset mode, the transfer size is changed if the
{ specified transfer size is > sdtx.stream.transfer_size.   IF sdtx.stream.streaming = TRUE the segment is
{ already in page streaming mode and nothing else need be done.  If sdtx.stream.streaming = FALSE then
{ the boolean sdtx.stream.preset_streaming is set to indicate that the next fault should stream.  To ensure
{ the next fault enters the page streaming code, the value of sdtx.stream.sequential_accesses is forced
{ to be  >= mmv$page_streaming_prestream.
{ When restoring the original values, the streaming boolean in the SDTX is left TRUE.  The page
{ fault process will terminate streaming if that is appropriate.  If the restore call is not made, the only
{ result is that free behind is TRUE and Transfer size =>64K which may or may not have been original values.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL, #GATE] mmp$preset_page_streaming
    (    preset_and_save_ts_fb: boolean;
         pva: ^cell;
         temp_transfer_size: integer;
     VAR saved_transfer_size: 0 .. 15;
     VAR saved_free_behind: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_free_behind: boolean,
      r1_transfer_size: 0 .. 15,
      r1_status: ost$status;

{  Validate the pva and get a pointer to the segment descriptor.

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    mmp$preset_page_streaming_r1 (#SEGMENT (pva), caller_id.ring, preset_and_save_ts_fb, temp_transfer_size,
          r1_transfer_size, r1_free_behind, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      saved_transfer_size := r1_transfer_size;
      saved_free_behind := r1_free_behind;
    IFEND;

  PROCEND mmp$preset_page_streaming;
?? TITLE := 'MMP$RESERVE_SEGMENT_NUMBER', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$reserve_segment_number
    (    shared_stack_flag: boolean;
     VAR segment_num_array: ^array [ * ] of ost$segment;
     VAR status: ost$status);

    VAR
      i: integer,
      r1_num_array_p: ^array [ * ] of ost$segment,
      r1_status: ost$status;

{ This procedure is the user interface to reserve segments for subsequent explicit assignment.

    status.normal := TRUE;
    PUSH r1_num_array_p: [LOWERBOUND (segment_num_array^) .. UPPERBOUND (segment_num_array^)];
    FOR i := LOWERBOUND (segment_num_array^) TO UPPERBOUND (segment_num_array^) DO
      r1_num_array_p^ [i] := 0;
    FOREND;

    mmp$reserve_segment_number_r1 (shared_stack_flag, r1_num_array_p, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      FOR i := LOWERBOUND (segment_num_array^) TO UPPERBOUND (segment_num_array^) DO
        segment_num_array^ [i] := r1_num_array_p^ [i];
      FOREND;
    IFEND;

  PROCEND mmp$reserve_segment_number;
?? TITLE := 'MMP$REVERIFY_ACCESS' ??
?? EJECT ??
*copyc mmh$reverify_access

  FUNCTION [XDCL] mmp$reverify_access
    (    pva_p: ^^cell): boolean;

    VAR
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    segnum := #SEGMENT (pva_p^);

    xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segnum);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
    mmp$reverify_access := (segnum <= xcb_p^.xp.segment_table_length) AND
          (sdt_entry_p^.ste.vl <> osc$vl_invalid_entry) AND (sdtx_entry_p^.access_state <>
          mmc$sas_terminate_access);
  FUNCEND mmp$reverify_access;

?? TITLE := 'MMP$SET_ACCESS_SELECTIONS', EJECT ??
*copyc mmh$set_access_selections

  PROCEDURE [XDCL, #GATE] mmp$set_access_selections
    (    pva: ^cell;
         access_selections: mmt$access_selections;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, #RING (pva), validating_ring_number);
    mmp$set_access_selections_r1 (#SEGMENT (pva), validating_ring_number, access_selections, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$set_access_selections;
?? TITLE := 'MMP$SET_SEGMENT_LENGTH' ??
?? EJECT ??
*copy mmh$set_segment_length

  PROCEDURE [XDCL, #GATE] mmp$set_segment_length
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
         segment_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      fde_p: gft$file_desc_entry_p,
      context: ^ost$ecp_exception_context,
      local_status: ost$status,
      r1_status: ost$status,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_pointer: ^cell,
      validating_ring_number: ost$valid_ring,
      xcb_p: ^ost$execution_control_block;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    context := NIL;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    segment_pointer := pva;
    mmp$set_segment_length_r1 (#SEGMENT (segment_pointer), validating_ring_number, segment_length, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

{ If this is a served segment/file, update the EOI on the server mainframe using a remote procedure call.

    xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, #SEGMENT (segment_pointer));
    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_p);
    IF fde_p^.media = gfc$fm_served_file THEN
      REPEAT
        dfp$set_server_eoi (sdtx_entry_p^.sfid, segment_length, local_status);
        IF NOT local_status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_segment;
            context^.file.file_segment := pva;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
    IFEND;

  PROCEND mmp$set_segment_length;
?? TITLE := 'MMP$STORE_SEGMENT_ATTRIBUTES' ??
?? EJECT ??
*copyc mmh$store_segment_attributes

  PROCEDURE [XDCL, #GATE] mmp$store_segment_attributes
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
         attr: array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      r1_segment_attributes_p: ^array [ * ] of mmt$attribute_descriptor;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    PUSH r1_segment_attributes_p: [LOWERBOUND (attr) .. UPPERBOUND (attr)];
    r1_segment_attributes_p^ := attr;
    mmp$store_segment_attributes_r1 (#SEGMENT (pva), caller_id.ring,
          osv$system_privilege_map[caller_id.segnum], r1_segment_attributes_p, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$store_segment_attributes;
?? TITLE := 'MMP$TERMINATE_SHADOWING' ??
?? EJECT ??
*copyc mmh$terminate_shadowing

  PROCEDURE [XDCL, #GATE] mmp$terminate_shadowing
    (    segment_p: ^cell;
         update: boolean;
     VAR status: ost$status);

    VAR
      access_selections: mmt$access_selections,
      dest_p: mmt$segment_pointer,
      r1_status: ost$status;

    status.normal := TRUE;
{  Determine if update (PASSIVE with ACTIVE)is required.

    IF update THEN
      update_passive_with_active (segment_p, status);
    IFEND;

    mmp$terminate_shadowing_r1 (#SEGMENT (segment_p), r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$terminate_shadowing;
?? TITLE := 'MMP$VERIFY_ACCESS' ??
?? EJECT ??
*copyc mmh$verify_access

  FUNCTION [XDCL, #GATE] mmp$verify_access
    (    pva_p: ^^cell;
         access_mode: mmt$va_access_mode): boolean;

    TYPE
      external_code_base_pointer = packed record
        fill: 0 .. 0f(16),
        vmid: 0 .. 0f(16),
        xp: boolean,
        fill2: 0 .. 7,
        r3: 0 .. 15,
        code_pva: ost$pva,
        fill3: 0 .. 0ffff(16),
        binding_pva: ost$pva,
      recend;

    VAR
      caller_id: ost$caller_identifier,
      code_pva: ost$pva,
      pointer: record
        case (pva, code_pointer, str) of
        = pva =
          pva: ost$pva,
        = code_pointer =
          cbp_p: ^external_code_base_pointer,
          static_link: ost$pva,
        = str =
          s: string (12),
        casend,
      recend,
      ptr: record
        case 0 .. 1 of
        = 0 =
          pva_p: ^^cell,
        = 1 =
          s_p: ^string (12),
        casend,
      recend,
      ref_r: ost$ring,
      sd_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    mmp$verify_access := TRUE;
    ptr.pva_p := pva_p;
    pointer.s := ptr.s_p^;
    segnum := pointer.pva.seg;

  /verify_access/
    BEGIN
      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
      IF segnum > xcb_p^.xp.segment_table_length THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;
      sd_p := mmp$get_sdt_entry_p (xcb_p, segnum);
      sdtx_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
      IF sd_p^.ste.vl = osc$vl_invalid_entry THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;
      IF (sdtx_p^.access_state = mmc$sas_terminate_access) THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;


      #CALLER_ID (caller_id);
      ref_r := pointer.pva.ring;
      IF ref_r = 0 THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;


{  Move pointer being verified to a local variable so that ring number checking will be
{  valid on recursive calls.


      IF caller_id.ring > ref_r THEN
        ref_r := caller_id.ring;
        pointer.pva.ring := caller_id.ring;
      IFEND;

      CASE access_mode OF
      = mmc$va_read =
        mmp$verify_access := (ref_r <= sd_p^.ste.r2) AND (sd_p^.ste.rp <> osc$non_readable);
      = mmc$va_write =
        mmp$verify_access := (ref_r <= sd_p^.ste.r1) AND (sd_p^.ste.wp <> osc$non_writable);
      = mmc$va_read_write =
        mmp$verify_access := (ref_r <= sd_p^.ste.r1) AND (sd_p^.ste.wp <> osc$non_writable) AND
              (sd_p^.ste.rp <> osc$non_readable);
      = mmc$va_execute =
        mmp$verify_access := (ref_r >= sd_p^.ste.r1) AND (ref_r <= sd_p^.ste.r2) AND
              (sd_p^.ste.xp <> osc$non_executable);
      = mmc$va_read_execute =
        mmp$verify_access := mmp$verify_access (#LOC (pointer.pva), mmc$va_execute) AND
              mmp$verify_access (#LOC (pointer.pva), mmc$va_read);
      = mmc$va_binding =
        mmp$verify_access := sd_p^.ste.rp = osc$binding_segment;
      = mmc$va_pointer_to_procedure =

{  To verify a pointer to procedure the following must be checked:
{    . The procedure pointer must be in a segment with read access.
{    . The static link pointer, code base pointer, code PVA, or binding PVA must not have a ring number
{      equal to zero.
{    . The code base pointer must be in a segment with the "binding" attribute and be in a ring
{      readable segment.
{    . The caller must be within the call bracket.
{    . The code PVA in the code base pointer must be in a segment with "execute" privilege.
{    . The binding PVA in the code base pointer must be in a segment with the "binding" attribute
{      if this is a two word external code base pointer.

        IF mmp$verify_access (#LOC (pointer.pva), mmc$va_read) = FALSE THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF pointer.static_link.ring = 0 THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF pointer.cbp_p^.code_pva.ring = 0 THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        pointer.pva.ring := ref_r;
        IF (mmp$verify_access (#LOC (pointer.pva), mmc$va_binding) AND mmp$verify_access (#LOC (pointer.pva),
              mmc$va_read)) = FALSE THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF ref_r > pointer.cbp_p^.r3 THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

{  The caller is within the call bracket so the call is possible.  The ring of execution will be r2 from
{  the code pva segment descriptor if it is greater than the caller's ring number, if not the caller's
{  ring number is the ring of execution.  The ring of execution is used as the ring number in
{  validating the code pva and the new binding pva if there is one.

        code_pva := pointer.cbp_p^.code_pva;
        IF ref_r > sd_p^.ste.r2 THEN
          code_pva.ring := sd_p^.ste.r2;
          ref_r := sd_p^.ste.r2;
        ELSE
          code_pva.ring := ref_r;
        IFEND;

        IF mmp$verify_access (#LOC (code_pva), mmc$va_execute) = FALSE THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF pointer.cbp_p^.xp = TRUE THEN
          IF pointer.cbp_p^.binding_pva.ring = 0 THEN
            mmp$verify_access := FALSE;
            EXIT /verify_access/;
          IFEND;
        IFEND;
      ELSE
        mmp$verify_access := FALSE;
      CASEND;
    END /verify_access/;

  FUNCEND mmp$verify_access;
?? TITLE := 'MMP$VERIFY_ACCESS_FOR_RING', EJECT ??

  FUNCTION [XDCL, #GATE] mmp$verify_access_for_ring
    (    pva_p: ^^cell;
         access_mode: mmt$va_access_mode;
         ring: ost$valid_ring): boolean;

    TYPE
      external_code_base_pointer = packed record
        fill: 0 .. 0f(16),
        vmid: 0 .. 0f(16),
        xp: boolean,
        fill2: 0 .. 7,
        r3: 0 .. 15,
        code_pva: ost$pva,
        fill3: 0 .. 0ffff(16),
        binding_pva: ost$pva,
      recend;

    VAR
      code_pva: ost$pva,
      pointer: record
        case (pva, code_pointer, str) of
        = pva =
          pva: ost$pva,
        = code_pointer =
          cbp_p: ^external_code_base_pointer,
          static_link: ost$pva,
        = str =
          s: string (12),
        casend,
      recend,
      ptr: record
        case 0 .. 1 of
        = 0 =
          pva_p: ^^cell,
        = 1 =
          s_p: ^string (12),
        casend,
      recend,
      ref_r: ost$ring,
      sd_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    mmp$verify_access_for_ring := TRUE;
    ptr.pva_p := pva_p;
    pointer.s := ptr.s_p^;
    segnum := pointer.pva.seg;

  /verify_access/
    BEGIN
      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
      IF segnum > xcb_p^.xp.segment_table_length THEN
        mmp$verify_access_for_ring := FALSE;
        EXIT /verify_access/; {----->
      IFEND;
      sd_p := mmp$get_sdt_entry_p (xcb_p, segnum);
      sdtx_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
      IF sd_p^.ste.vl = osc$vl_invalid_entry THEN
        mmp$verify_access_for_ring := FALSE;
        EXIT /verify_access/; {----->
      IFEND;
      IF (sdtx_p^.access_state = mmc$sas_terminate_access) THEN
        mmp$verify_access_for_ring := FALSE;
        EXIT /verify_access/; {----->
      IFEND;


      ref_r := pointer.pva.ring;
      IF ref_r = 0 THEN
        mmp$verify_access_for_ring := FALSE;
        EXIT /verify_access/; {----->
      IFEND;


{  Move pointer being verified to a local variable so that ring number checking will be
{  valid on recursive calls.


      IF ring > ref_r THEN
        ref_r := ring;
        pointer.pva.ring := ring;
      IFEND;

      CASE access_mode OF
      = mmc$va_read =
        mmp$verify_access_for_ring := (ref_r <= sd_p^.ste.r2) AND (sd_p^.ste.rp <> osc$non_readable);
      = mmc$va_write =
        mmp$verify_access_for_ring := (ref_r <= sd_p^.ste.r1) AND (sd_p^.ste.wp <> osc$non_writable);
      = mmc$va_read_write =
        mmp$verify_access_for_ring := (ref_r <= sd_p^.ste.r1) AND (sd_p^.ste.wp <> osc$non_writable) AND
              (sd_p^.ste.rp <> osc$non_readable);
      = mmc$va_execute =
        mmp$verify_access_for_ring := (ref_r >= sd_p^.ste.r1) AND (ref_r <= sd_p^.ste.r2) AND
              (sd_p^.ste.xp <> osc$non_executable);
      = mmc$va_read_execute =
        mmp$verify_access_for_ring := mmp$verify_access_for_ring (#LOC (pointer.pva),
              mmc$va_execute, ring) AND mmp$verify_access_for_ring (#LOC (pointer.pva), mmc$va_read, ring);
      = mmc$va_binding =
        mmp$verify_access_for_ring := sd_p^.ste.rp = osc$binding_segment;
      = mmc$va_pointer_to_procedure =

{  To verify a pointer to procedure the following must be checked:
{    . The procedure pointer must be in a segment with read access.
{    . The static link pointer, code base pointer, code PVA, or binding PVA must not have a ring number
{      equal to zero.
{    . The code base pointer must be in a segment with the "binding" attribute and be in a ring
{      readable segment.
{    . The caller must be within the call bracket.
{    . The code PVA in the code base pointer must be in a segment with "execute" privilege.
{    . The binding PVA in the code base pointer must be in a segment with the "binding" attribute
{      if this is a two word external code base pointer.

        IF mmp$verify_access_for_ring (#LOC (pointer.pva), mmc$va_read, ring) = FALSE THEN
          mmp$verify_access_for_ring := FALSE;
          EXIT /verify_access/; {----->
        IFEND;

        IF pointer.static_link.ring = 0 THEN
          mmp$verify_access_for_ring := FALSE;
          EXIT /verify_access/; {----->
        IFEND;

        IF pointer.cbp_p^.code_pva.ring = 0 THEN
          mmp$verify_access_for_ring := FALSE;
          EXIT /verify_access/; {----->
        IFEND;

        pointer.pva.ring := ref_r;
        IF (mmp$verify_access_for_ring (#LOC (pointer.pva), mmc$va_binding, ring) AND
              mmp$verify_access_for_ring (#LOC (pointer.pva), mmc$va_read, ring)) = FALSE THEN
          mmp$verify_access_for_ring := FALSE;
          EXIT /verify_access/; {----->
        IFEND;

        IF ref_r > pointer.cbp_p^.r3 THEN
          mmp$verify_access_for_ring := FALSE;
          EXIT /verify_access/; {----->
        IFEND;

{  The caller is within the call bracket so the call is possible.  The ring of execution will be r2 from
{  the code pva segment descriptor if it is greater than the caller's ring number, if not the caller's
{  ring number is the ring of execution.  The ring of execution is used as the ring number in
{  validating the code pva and the new binding pva if there is one.

        code_pva := pointer.cbp_p^.code_pva;
        IF ref_r > sd_p^.ste.r2 THEN
          code_pva.ring := sd_p^.ste.r2;
          ref_r := sd_p^.ste.r2;
        ELSE
          code_pva.ring := ref_r;
        IFEND;

        IF mmp$verify_access_for_ring (#LOC (code_pva), mmc$va_execute, ring) = FALSE THEN
          mmp$verify_access_for_ring := FALSE;
          EXIT /verify_access/; {----->
        IFEND;

        IF pointer.cbp_p^.xp = TRUE THEN
          IF pointer.cbp_p^.binding_pva.ring = 0 THEN
            mmp$verify_access_for_ring := FALSE;
            EXIT /verify_access/; {----->
          IFEND;
        IFEND;
      ELSE
        mmp$verify_access_for_ring := FALSE;
      CASEND;
    END /verify_access/;

  FUNCEND mmp$verify_access_for_ring;
?? TITLE := 'MMP$VOLUME_UNAVAILABLE_FLAG_HDL' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$volume_unavailable_flag_hdl
    (    flag_id: ost$system_flag);

    bap$exit_fap_on_condition (mme$volume_unavailable);

  PROCEND mmp$volume_unavailable_flag_hdl;
?? OLDTITLE ??
MODEND mmm$segment_manager_job_temp;
