?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Real Memory Builder', EJECT ??
MODULE ocm$real_memory_builder;



{ PURPOSE:
{   This module contains the routines for executing the VE
{ Real Memory Builder.

?? PUSH (LISTEXT := ON) ??
*copyc fsc$file_contents
*copyc mmt$segment_descriptor_table_ex
*copyc occ$symbol_table_version
*copyc oce$library_generator_errors
*copyc oce$rm_builder_exceptions
*copyc oce$ve_linker_exceptions
*copyc oct$build_options
*copyc oct$list_of_entry_points
*copyc oct$symbol_table_header
*copyc ost$exchange_package
*copyc ost$execution_control_block
*copyc ost$hardware_subranges
*copyc ost$page_size
*copyc ost$page_table
*copyc ost$spaa_entry
*copyc pmd$memory_image_header
*copyc pmt$virtual_memory_image_header
?? POP ??
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi

*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_file
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page

*copyc i#current_sequence_position
*copyc i#move

*copyc ocp$get_ring_brackets

*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal

*copyc pmp$get_last_path_name
*copyc pmp$get_legible_date_time
*copyc pmp$position_object_library

*copyc syp$advised_move_bytes
?? NEWTITLE := '  Global Variables', EJECT ??

  CONST
    nos_asid = 0ffff(16),
    ssr_asid = 8000(16),

    reserved = TRUE;

  VAR
    strng: string (80),
    l: integer,

    v$real_memory_image: oct$real_memory_descriptor,
    v$page_table_pages: ^oct$page_descriptor,
    v$end_of_real_memory: ost$real_memory_address,
    v$mtr_exchange_info: oct$exchange_package_info,
    v$job_exchange_info: oct$exchange_package_info,
    v$pp_address_array_rma: ost$real_memory_address,
    v$pp_address_array_pva: oct$exchange_address,
    v$pages_loaded_pva: oct$exchange_address,
    v$page_size_pva: oct$exchange_address,
    v$diagnostic_count: integer,
    v$asid_seed: integer,
    v$display_control: clt$display_control,
    v$zero_filled_page: ^array [ * ] of ost$byte,
    ocv$rmb_scratch_seq: [XREF] ^SEQ ( * );


  VAR
    v$page_header: [STATIC] string (100) :=
          'MEMORY MAP OF                                                                        PAGE';

?? OLDTITLE ??
?? NEWTITLE := '  OCP$GENERATE_REAL_MEMORY', EJECT ??


  PROCEDURE [XDCL] ocp$generate_real_memory
    (    build_options: oct$build_options;
         image_file: amt$local_file_name;
     VAR status: ost$status);

?? NEWTITLE := '    ISSUE_DIAGNOSTIC', EJECT ??

    PROCEDURE issue_diagnostic
      (VAR status: ost$status);



      VAR
        local_status: ost$status,

        message_content: ost$status_message,
        message: ^ost$status_message,
        diagnostic_line_count: ^ost$status_message_line_count,
        diagnostic_line_index: ost$status_message_line_count,
        diagnostic_line_size: ^ost$status_message_line_size,
        diagnostic_line: ^ost$status_message_line;



      message := ^message_content;

      osp$format_message (status, osc$full_message_level, v$display_control.page_width, message_content,
            local_status);

      RESET message;
      NEXT diagnostic_line_count IN message;

      FOR diagnostic_line_index := 1 TO diagnostic_line_count^ DO
        NEXT diagnostic_line_size IN message;
        NEXT diagnostic_line: [diagnostic_line_size^] IN message;

        clp$put_partial_display (v$display_control, diagnostic_line^, clc$no_trim, amc$start, local_status);
      FOREND;

      v$diagnostic_count := v$diagnostic_count + 1;
      status.normal := TRUE;

    PROCEND issue_diagnostic;
?? OLDTITLE ??
?? NEWTITLE := '    NEW_PAGE_PROCEDURE', EJECT ??

    PROCEDURE new_page_procedure
      (VAR display_control: clt$display_control;
           new_page_number: integer;
       VAR status: ost$status);




      clp$reset_for_next_display_page (display_control, status);

      v$page_header (91, 3) := '   ';

      STRINGREP (v$page_header (90, * ), l, display_control.page_number);
      clp$put_display (display_control, v$page_header, clc$trim, status);

      clp$new_display_line (display_control, 2, status);


    PROCEND new_page_procedure;
?? OLDTITLE ??
?? NEWTITLE := '    INITIALIZE_EXCHANGE_INFO', EJECT ??

    PROCEDURE initialize_exchange_info
      (    address_space: oct$address_space_id;
       VAR exchange_info: oct$exchange_package_info);




      exchange_info.p_address.ring := osc$invalid_ring;
      exchange_info.p_address.seg := 0;
      exchange_info.p_address.offset := 0;

      exchange_info.binding_address.ring := osc$invalid_ring;
      exchange_info.binding_address.seg := 0;
      exchange_info.binding_address.offset := 0;

      exchange_info.address_space := address_space;
      exchange_info.rma := 0;
      exchange_info.segment_descriptor_list.link := NIL;
      exchange_info.symbol_table := NIL;

    PROCEND initialize_exchange_info;
?? OLDTITLE ??
?? NEWTITLE := '    SETUP_RMB_PARAMETERS', EJECT ??

    PROCEDURE setup_rmb_parameters
      (VAR status: ost$status);




      VAR
        of_execution: boolean,
        i: integer,
        time: ost$time,
        date: ost$date,
        valid_position: boolean,
        default_rings: amt$ring_attributes,
        open_position: amt$open_position,
        local_status: ost$status;



      v$asid_seed := 1;
      v$diagnostic_count := 0;

      pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_last_path_name (image_file, v$page_header (17, 31), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      v$page_header (62, 8) := date.mdy;
      v$page_header (72, 8) := time.hms;

      initialize_exchange_info (occ$mtr, v$mtr_exchange_info);
      initialize_exchange_info (occ$job, v$job_exchange_info);
      v$pp_address_array_rma := 0;

      NEXT v$zero_filled_page: [1 .. build_options.page_size] IN ocv$rmb_scratch_seq;
      IF v$zero_filled_page = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB0', status);
        RETURN;
      IFEND;

      FOR i := 1 TO build_options.page_size DO
        v$zero_filled_page^ [i] := 0;
      FOREND;

      NEXT v$real_memory_image.page: [0 .. build_options.page_table_length DIV 8] IN ocv$rmb_scratch_seq;
      IF v$real_memory_image.page = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB1', status);
        RETURN;
      IFEND;

      FOR i := 0 TO UPPERBOUND (v$real_memory_image.page^) DO
        v$real_memory_image.page^ [i].reserved := FALSE;
        v$real_memory_image.page^ [i].continue_bits := 0;
      FOREND;

      v$end_of_real_memory := (build_options.page_table_length DIV 8) * build_options.page_size;


      v$real_memory_image.reserved_asids.link := NIL;

      open_real_memory_image (image_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (build_options.building_ei) OR (build_options.load_address <> 0) THEN
        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, build_options.load_address,
              valid_position);
      ELSE
        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
              build_options.page_table_address + build_options.page_table_length, valid_position);
      IFEND;

      v$real_memory_image.next_free_page := i#current_sequence_position
            (v$real_memory_image.segment.sequence_pointer);
      v$real_memory_image.length := 0;
      v$real_memory_image.pt_continue_bits := 0;

      default_rings.r1 := #RING (^of_execution);
      default_rings.r2 := #RING (^of_execution);
      default_rings.r3 := #RING (^of_execution);

      clp$open_display_file (build_options.memory_map, ^new_page_procedure, fsc$list, default_rings,
            v$display_control, status);
      IF NOT status.normal THEN
        amp$close (v$real_memory_image.id, local_status);
        RETURN;
      IFEND;

    PROCEND setup_rmb_parameters;
?? OLDTITLE ??
?? NEWTITLE := '    VERIFY_BUILD_OPTIONS', EJECT ??

    PROCEDURE verify_build_options
      (    build_options: oct$build_options;
       VAR status: ost$status);




      IF (i#current_sequence_position (v$real_memory_image.segment.sequence_pointer) MOD
            build_options.page_size) <> 0 THEN
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'LOAD ADDRESS MUST BE ON PAGE BOUNDRY',
              status);
        RETURN;
      IFEND;

      IF i#current_sequence_position (v$real_memory_image.segment.sequence_pointer) <
            build_options.load_offset THEN
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'LOAD ADDRESS MUST BE GE TO LOAD OFFSET',
              status);
        RETURN;
      IFEND;

      IF NOT build_options.building_ei THEN
        IF build_options.page_table_address < build_options.load_offset THEN
          osp$set_status_abnormal ('OC', oce$e_build_option_error,
                'PAGE TABLE ADDRESS MUST BE GE LOAD OFFSET', status);
          RETURN;
        IFEND;


        IF (build_options.page_table_address MOD build_options.page_table_length) <> 0 THEN
          osp$set_status_abnormal ('OC', oce$e_build_option_error,
                'PAGE TABLE ADDRESS MUST BE 0 MOD PAGE TABLE LENGTH', status);
          RETURN;
        IFEND;

        IF (build_options.page_table_address + build_options.page_table_length) >
              i#current_sequence_position (v$real_memory_image.segment.sequence_pointer) THEN
          osp$set_status_abnormal ('OC', oce$e_build_option_error,
                'LOAD ADDRESS MUST BE GT END OF PAGE TABLE', status);
          RETURN;
        IFEND;
      IFEND;

      IF (build_options.ssr_size MOD build_options.page_size) <> 0 THEN
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'SSR_SIZE MUST BE ZERO MOD PAGE SIZE',
              status);
        RETURN;
      IFEND;

    PROCEND verify_build_options;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_PAGE_TABLE', EJECT ??

    PROCEDURE allocate_page_table
      (VAR status: ost$status);

      VAR
        valid_position: boolean,
        i: 0 .. osc$max_page_table_entries;


      allocate_pages (build_options.page_table_address, build_options.page_table_length, v$page_table_pages,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
            build_options.page_table_address, valid_position);

      NEXT v$real_memory_image.page_table: [0 .. build_options.page_table_length DIV 8] IN
            v$real_memory_image.segment.sequence_pointer;

      FOR i := 0 TO UPPERBOUND (v$real_memory_image.page_table^) DO
        v$real_memory_image.page_table^ [i].v := FALSE;
        v$real_memory_image.page_table^ [i].c := FALSE;
        v$real_memory_image.page_table^ [i].u := FALSE;
        v$real_memory_image.page_table^ [i].m := FALSE;
        v$real_memory_image.page_table^ [i].pageid.asid := 0;
        v$real_memory_image.page_table^ [i].pageid.pagenum := 0;
        v$real_memory_image.page_table^ [i].rma := 0;
      FOREND;


{ Deadstart kludge to protect the location of the PP_ADDRESS_ARRAY pointer.

      v$real_memory_image.page_table^ [1].v := TRUE;
      v$real_memory_image.page_table^ [1].m := TRUE;


    PROCEND allocate_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    OPEN_INPUT_FILE', EJECT ??

    PROCEDURE open_input_file
      (    name: amt$local_file_name;
       VAR input_file: oct$file_descriptor;
       VAR status: ost$status);


      VAR
        local_file: boolean,
        existing_file: boolean,
        contains_data: boolean,

        get_attributes: [STATIC] array [1 .. 2] of amt$get_item :=
              [[ * , amc$file_contents, * ], [ * , amc$file_structure, * ]],

        read_attributes: [STATIC] array [1 .. 1] of amt$access_selection :=
              [[amc$access_mode, $pft$usage_selections [pfc$read]]];


      input_file.name := name;

      amp$get_file_attributes (input_file.name, get_attributes, local_file, existing_file, contains_data,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (get_attributes [1].file_contents <> amc$unknown_contents) OR
            (get_attributes [2].file_structure <> amc$data) THEN
        osp$set_status_abnormal ('OC', oce$e_bad_input_file, input_file.name, status);
        RETURN;
      IFEND;

      amp$open (input_file.name, amc$segment, ^read_attributes, input_file.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (input_file.id, amc$sequence_pointer, input_file.segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND open_input_file;
?? OLDTITLE ??
?? NEWTITLE := '    OPEN_REAL_MEMORY_IMAGE', EJECT ??

    PROCEDURE open_real_memory_image
      (    name: amt$local_file_name;
       VAR status: ost$status);




?? FMT (FORMAT := OFF) ??
  VAR
    file_attributes: [STATIC] array [1 .. 6] of amt$access_selection := [
      [amc$ring_attributes, *],
      [amc$access_mode, $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten, pfc$read]],
      [amc$preset_value, 00(16)],
      [amc$file_structure, amc$data],
      [amc$file_contents, amc$unknown_contents],
      [amc$file_processor, amc$unknown_processor]];


?? FMT (FORMAT:=ON) ??

      ocp$get_ring_brackets (name, file_attributes [1].ring_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$open (name, amc$segment, ^file_attributes, v$real_memory_image.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      amp$get_segment_pointer (v$real_memory_image.id, amc$sequence_pointer, v$real_memory_image.segment,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET v$real_memory_image.segment.sequence_pointer;


    PROCEND open_real_memory_image;
?? OLDTITLE ??
?? NEWTITLE := '    CLOSE_FILE', EJECT ??

    PROCEDURE close_file
      (    file_descriptor: oct$file_descriptor;
       VAR status: ost$status);



      amp$close (file_descriptor.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND close_file;
?? OLDTITLE ??
?? NEWTITLE := '    SEARCH_FOR_SEGMENT', EJECT ??

    PROCEDURE search_for_segment
      (    address_space: oct$address_space_id;
           segment_number: ost$segment;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR found: boolean);



      IF address_space = occ$mtr THEN
        segment_descriptor := v$mtr_exchange_info.segment_descriptor_list.link;
      ELSE
        segment_descriptor := v$job_exchange_info.segment_descriptor_list.link;
      IFEND;

      WHILE segment_descriptor <> NIL DO

        IF segment_descriptor^.segment_number = segment_number THEN
          found := TRUE;
          RETURN;
        IFEND;

        segment_descriptor := segment_descriptor^.link;
      WHILEND;

      found := FALSE;

    PROCEND search_for_segment;
?? OLDTITLE ??
?? NEWTITLE := '    SEARCH_FOR_OFFSET', EJECT ??

    PROCEDURE search_for_offset
      (    offset: ost$segment_offset;
           pages: ^oct$page_descriptor;
       VAR rma: ost$real_memory_address;
       VAR found: boolean);


      VAR
        page: ^oct$page_descriptor,
        offset_in_segment: ost$segment_offset;


      offset_in_segment := 0;
      page := pages;

      WHILE page <> NIL DO
        IF (offset_in_segment + build_options.page_size) > offset THEN
          rma := page^.offset + (offset - offset_in_segment);
          found := TRUE;
          RETURN;
        ELSE
          offset_in_segment := offset_in_segment + build_options.page_size;
          page := page^.link;
        IFEND;
      WHILEND;

      found := FALSE;


    PROCEND search_for_offset;
?? OLDTITLE ??
?? NEWTITLE := '    SEARCH_RESERVED_ASIDS', EJECT ??

    PROCEDURE search_reserved_asids
      (    asid: ost$asid;
       VAR found: boolean;
       VAR last_asid: ^oct$reserved_asids);



      last_asid := ^v$real_memory_image.reserved_asids;

      WHILE last_asid^.link <> NIL DO
        last_asid := last_asid^.link;

        IF last_asid^.asid = asid THEN
          found := TRUE;
          RETURN;
        IFEND;
      WHILEND;

      found := FALSE;


    PROCEND search_reserved_asids;
?? OLDTITLE ??
?? NEWTITLE := '    GENERATE_PAGE_TABLE_INDEX', EJECT ??

    PROCEDURE generate_page_table_index
      (    asid: ost$asid;
           pagenum: 0 .. 3fffff(16);
       VAR pti: -osc$max_page_table_entries .. osc$max_page_table_entries);



      VAR
        i: integer,
        temp_asid: ost$asid,
        temp_pagenum: 0 .. osc$max_page_table_entries,
        f: integer;



      f := 2;
      pti := 0;
      temp_asid := asid;
      temp_pagenum := (pagenum * 512) DIV build_options.page_size;

      FOR i := 1 TO 16 DO
        IF (temp_asid MOD 2) <> (temp_pagenum MOD 2) THEN
          pti := pti + f;
        IFEND;

        temp_asid := temp_asid DIV 2;
        temp_pagenum := temp_pagenum DIV 2;
        f := f * 2;
      FOREND;

      pti := pti MOD (build_options.page_table_length DIV 8);


    PROCEND generate_page_table_index;
?? OLDTITLE ??
?? NEWTITLE := '    ADD_A_SEGMENT', EJECT ??

    PROCEDURE add_a_segment
      (    new_segment_descriptor: ^oct$segment_descriptor;
       VAR segment_descriptor_list: oct$segment_descriptor);




      VAR
        segment_descriptor: ^oct$segment_descriptor,
        local_status: ost$status;



      segment_descriptor := ^segment_descriptor_list;

      WHILE (segment_descriptor^.link <> NIL) AND (segment_descriptor^.link^.segment_number <>
            new_segment_descriptor^.segment_number) DO
        segment_descriptor := segment_descriptor^.link;
      WHILEND;

      IF segment_descriptor^.link = NIL THEN
        segment_descriptor^.link := new_segment_descriptor;
        segment_descriptor^.link^.link := NIL;
      ELSE
        STRINGREP (strng, l, new_segment_descriptor^.segment_number);
        osp$set_status_abnormal ('OC', oce$e_duplicate_segment_numbers, strng (1, l), local_status);
        issue_diagnostic (local_status);
      IFEND;


    PROCEND add_a_segment;
?? OLDTITLE ??
?? NEWTITLE := '    RESERVE_PAGES', EJECT ??

    PROCEDURE search_for_contiguous_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR found: boolean;
       VAR start_of_contiguous_pages: ost$real_memory_address);





      VAR
        contiguous_memory: ost$real_memory_address,
        memory_needed: ost$real_memory_address;





      IF length = 0 THEN
        found := TRUE;
        RETURN;
      IFEND;

      start_of_contiguous_pages := starting_address - (starting_address MOD build_options.page_size);
      memory_needed := length + (starting_address MOD build_options.page_size);

      WHILE start_of_contiguous_pages < v$end_of_real_memory DO
        contiguous_memory := 0;

        WHILE ((start_of_contiguous_pages + contiguous_memory) < v$end_of_real_memory) AND
              (NOT v$real_memory_image.page^ [(contiguous_memory + start_of_contiguous_pages) DIV
              build_options.page_size].reserved) DO
          IF contiguous_memory >= memory_needed THEN
            found := TRUE;
            RETURN;
          IFEND;
          contiguous_memory := contiguous_memory + build_options.page_size;
        WHILEND;

        IF (start_of_contiguous_pages + contiguous_memory) >= v$end_of_real_memory THEN
          found := FALSE;
          RETURN;
        IFEND;

        start_of_contiguous_pages := start_of_contiguous_pages + contiguous_memory + build_options.page_size;
      WHILEND;

      found := FALSE;

    PROCEND search_for_contiguous_pages;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_PAGES', EJECT ??

    PROCEDURE allocate_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR pages: ^oct$page_descriptor;
       VAR status: ost$status);



      VAR
        valid_position: boolean,
        memory: ^array [ * ] of ost$byte,
        current_address: ost$real_memory_address,
        adjusted_length: ost$segment_length,
        memory_allocated: ost$segment_length,
        last_page_descriptor: ^oct$page_descriptor,
        page_descriptor: oct$page_descriptor;


      page_descriptor.link := NIL;
      last_page_descriptor := ^page_descriptor;

      current_address := starting_address - (starting_address MOD build_options.page_size);
      adjusted_length := length + (starting_address MOD build_options.page_size);
      memory_allocated := 0;

      WHILE memory_allocated < adjusted_length DO
        WHILE v$real_memory_image.page^ [current_address DIV build_options.page_size].reserved DO
          current_address := current_address + build_options.page_size;
        WHILEND;

        IF current_address >= v$end_of_real_memory THEN
          osp$set_status_abnormal ('OC', oce$e_no_memory_available, '', status);
          RETURN;
        IFEND;

        NEXT last_page_descriptor^.link IN ocv$rmb_scratch_seq;
        last_page_descriptor := last_page_descriptor^.link;
        IF last_page_descriptor = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB4', status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, current_address,
              valid_position);
        NEXT memory: [1 .. build_options.page_size] IN v$real_memory_image.segment.sequence_pointer;
        IF memory = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
          RETURN;
        IFEND;

        memory^ := v$zero_filled_page^;

        v$real_memory_image.page^ [current_address DIV build_options.page_size].reserved := reserved;
        last_page_descriptor^.offset := current_address;
        current_address := current_address + build_options.page_size;
        memory_allocated := memory_allocated + build_options.page_size;
      WHILEND;

      last_page_descriptor^.link := NIL;

      WHILE v$real_memory_image.page^ [v$real_memory_image.next_free_page DIV
            build_options.page_size].reserved DO
        v$real_memory_image.next_free_page := v$real_memory_image.next_free_page + build_options.page_size;
      WHILEND;

      pages := page_descriptor.link;

    PROCEND allocate_pages;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_FIXED_PAGES', EJECT ??

    PROCEDURE allocate_fixed_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);




      VAR
        adjusted_length: ost$segment_length;



      segment_descriptor^.pages := NIL;

      IF length > 0 THEN
        IF v$real_memory_image.page^ [starting_address DIV build_options.page_size].reserved THEN
          STRINGREP (strng, l, starting_address);
          osp$set_status_abnormal ('OC', oce$e_page_already_allocated, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        allocate_pages (starting_address, build_options.page_size, segment_descriptor^.pages, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        adjusted_length := length + (starting_address MOD build_options.page_size);

        IF adjusted_length > build_options.page_size THEN
          allocate_pages (v$real_memory_image.next_free_page, adjusted_length - build_options.page_size,
                segment_descriptor^.pages^.link, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    PROCEND allocate_fixed_pages;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_FIXED_CONTIGUOUS_PAGES', EJECT ??

    PROCEDURE allocate_fixed_contiguous_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);



      VAR
        adjusted_address: ost$real_memory_address,
        adjusted_length: ost$segment_length,
        contiguous_pages_found: boolean,
        start_of_contiguous_pages: ost$real_memory_address;




      segment_descriptor^.pages := NIL;

      IF length > 0 THEN
        adjusted_address := starting_address - (starting_address MOD build_options.page_size);
        adjusted_length := length + (starting_address MOD build_options.page_size);

        search_for_contiguous_pages (adjusted_address, adjusted_length, contiguous_pages_found,
              start_of_contiguous_pages);
        IF (NOT contiguous_pages_found) OR (adjusted_address <> start_of_contiguous_pages) THEN
          STRINGREP (strng, l, segment_descriptor^.segment_number);
          osp$set_status_abnormal ('OC', oce$e_no_contiguous_real_memory, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        allocate_pages (start_of_contiguous_pages, adjusted_length, segment_descriptor^.pages, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND allocate_fixed_contiguous_pages;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_SEGMENT_DESCRIPTORS', EJECT ??

    PROCEDURE build_segment_descriptor
      (    input_segment: ^pmt$linked_segment_description;
       VAR segment_descriptor: oct$segment_descriptor);



      segment_descriptor.ste := input_segment^.segment_descriptor;

      segment_descriptor.software_attributes := input_segment^.software_attributes;

      segment_descriptor.pages := NIL;
      segment_descriptor.asid := NIL;
      segment_descriptor.segment_number := input_segment^.segment_number;
      segment_descriptor.segment_id := osc$null_name;

      NEXT segment_descriptor.segment_length IN ocv$rmb_scratch_seq;
      IF segment_descriptor.segment_length = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB14', status);
        RETURN;
      IFEND;

      segment_descriptor.segment_length^ := input_segment^.length;
      segment_descriptor.link := NIL;

    PROCEND build_segment_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '    COPY_FILE', EJECT ??

    PROCEDURE copy_file
      (VAR segment_file: oct$file_descriptor;
       VAR segment_descriptor: oct$segment_descriptor;
       VAR status: ost$status);





      VAR
        segment: ^array [1 .. * ] of ost$byte,
        page: ^array [1 .. * ] of ost$byte,
        page_descriptor: ^oct$page_descriptor,
        next_page_descriptor: ^oct$page_descriptor,

        valid_position: boolean,

        bytes_to_move: ost$segment_offset,
        byte: ost$segment_offset,
        length: ost$segment_offset;


      IF segment_descriptor.segment_length^ > 0 THEN

      /copy/
        BEGIN
          NEXT segment: [1 .. segment_descriptor.segment_length^] IN segment_file.segment.sequence_pointer;
          IF segment = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, segment_file.name, status);
            EXIT /copy/;
          IFEND;

          byte := 0;
          page_descriptor := segment_descriptor.pages;

          WHILE page_descriptor <> NIL DO
            bytes_to_move := build_options.page_size;
            next_page_descriptor := page_descriptor^.link;
            WHILE (next_page_descriptor <> NIL) AND ((page_descriptor^.offset + bytes_to_move) =
                  next_page_descriptor^.offset) DO
              bytes_to_move := bytes_to_move + build_options.page_size;
              next_page_descriptor := next_page_descriptor^.link;
            WHILEND;

            pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
                  page_descriptor^.offset, valid_position);

            NEXT page: [1 .. bytes_to_move] IN v$real_memory_image.segment.sequence_pointer;
            IF page = NIL THEN
              osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
              EXIT /copy/;
            IFEND;

            IF (bytes_to_move) <= (segment_descriptor.segment_length^ -byte) THEN
              length := bytes_to_move;
            ELSE
              length := segment_descriptor.segment_length^ -byte;
            IFEND;

            syp$advised_move_bytes (#LOC (segment^ [byte + 1]), #LOC (page^ [1]), length, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            byte := byte + bytes_to_move;
            page_descriptor := next_page_descriptor;
          WHILEND;

          RETURN;
        END /copy/;
      IFEND;

    PROCEND copy_file;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_DEFINE_SEGMENTS', EJECT ??

    PROCEDURE process_define_segments
      (    define_segment_list: oct$define_command_list;
       VAR status: ost$status);





      VAR
        last_asid: ^oct$reserved_asids,

        found: boolean,

        segment_descriptor: ^oct$segment_descriptor,
        duplicate_segment_descriptor: ^oct$segment_descriptor,
        define_segments: ^oct$define_command_list;



      define_segments := define_segment_list.link;

      WHILE define_segments <> NIL DO

      /define_segment/
        BEGIN
          IF (define_segments^.address MOD build_options.page_size) <> 0 THEN
            STRINGREP (strng, l, define_segments^.segment_number);
            osp$set_status_abnormal ('OC', oce$e_invalid_define_seg_addr, strng (1, l), status);
            issue_diagnostic (status);
            EXIT /define_segment/;
          IFEND;

          IF define_segments^.address < build_options.load_offset THEN
            STRINGREP (strng, l, define_segments^.segment_number);
            osp$set_status_abnormal ('OC', oce$e_invalid_define_seg_addr, strng (1, l), status);
            issue_diagnostic (status);
            EXIT /define_segment/;
          IFEND;

          NEXT segment_descriptor IN ocv$rmb_scratch_seq;
          IF segment_descriptor = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB5', status);
            RETURN;
          IFEND;

          segment_descriptor^.segment_id := define_segments^.segment_id;

          IF define_segments^.hardware_attributes.cache_bypass THEN
            segment_descriptor^.ste.vl := osc$vl_cache_bypass;
          ELSE
            segment_descriptor^.ste.vl := osc$vl_regular_segment;
          IFEND;

          segment_descriptor^.ste.xp := define_segments^.hardware_attributes.execute_privilege;
          segment_descriptor^.ste.wp := define_segments^.hardware_attributes.write_privilege;
          segment_descriptor^.ste.rp := define_segments^.hardware_attributes.read_privilege;
          segment_descriptor^.ste.r1 := define_segments^.r1;
          segment_descriptor^.ste.r2 := define_segments^.r2;
          segment_descriptor^.ste.key_lock := define_segments^.key_lock;
          segment_descriptor^.software_attributes := define_segments^.software_attributes;

          NEXT segment_descriptor^.asid IN ocv$rmb_scratch_seq;
          IF segment_descriptor^.asid = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB6', status);
            RETURN;
          IFEND;

          segment_descriptor^.asid^.assigned := FALSE;

          IF occ$asid IN define_segments^.parameters THEN
            search_reserved_asids (define_segments^.active_segment_id, found, last_asid);
            IF found THEN
              STRINGREP (strng, l, define_segments^.active_segment_id);
              osp$set_status_abnormal ('OC', oce$e_duplicate_asid_specified, strng (1, l), status);
              issue_diagnostic (status);
              EXIT /define_segment/;
            ELSE
              NEXT last_asid^.link IN ocv$rmb_scratch_seq;
              last_asid := last_asid^.link;
              IF last_asid = NIL THEN
                osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB7', status);
                RETURN;
              IFEND;

              last_asid^.asid := define_segments^.active_segment_id;
              last_asid^.link := NIL;
              segment_descriptor^.asid^.predefined := TRUE;
              segment_descriptor^.asid^.active_segment_id := define_segments^.active_segment_id;
            IFEND;
          ELSE
            segment_descriptor^.asid^.predefined := FALSE;
          IFEND;

          segment_descriptor^.segment_number := define_segments^.segment_number;

          NEXT segment_descriptor^.segment_length IN ocv$rmb_scratch_seq;
          IF segment_descriptor^.segment_length = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB15', status);
            RETURN;
          IFEND;
          segment_descriptor^.segment_length^ := define_segments^.length;

          IF define_segments^.segment_id <> 'PAGE_TABLE                     ' THEN
            IF define_segments^.contiguous_space THEN
              allocate_fixed_contiguous_pages (define_segments^.address, segment_descriptor^.segment_length^,
                    segment_descriptor, status);
            ELSE
              allocate_fixed_pages (define_segments^.address, segment_descriptor^.segment_length^,
                    segment_descriptor, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            segment_descriptor^.pages := v$page_table_pages;
          IFEND;

          CASE define_segments^.address_space OF
          = occ$mtr =
            add_a_segment (segment_descriptor, v$mtr_exchange_info.segment_descriptor_list);

          = occ$job =
            add_a_segment (segment_descriptor, v$job_exchange_info.segment_descriptor_list);

          = occ$both =
            NEXT duplicate_segment_descriptor IN ocv$rmb_scratch_seq;
            IF duplicate_segment_descriptor = NIL THEN
              osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB15', status);
              RETURN;
            IFEND;

            duplicate_segment_descriptor^ := segment_descriptor^;

            add_a_segment (segment_descriptor, v$mtr_exchange_info.segment_descriptor_list);

            add_a_segment (duplicate_segment_descriptor, v$job_exchange_info.segment_descriptor_list);
          CASEND;
        END /define_segment/;

        define_segments := define_segments^.link;
      WHILEND;

    PROCEND process_define_segments;
?? OLDTITLE ??
?? NEWTITLE := '    READ_SYMBOL_TABLE', EJECT ??

    PROCEDURE read_symbol_table
      (    lst_file: oct$file_descriptor;
       VAR lst_last: integer;
       VAR status: ost$status);


      VAR
        header: ^oct$symbol_table_header,
        linker_symbol_table: ^oct$list_of_entry_points,
        lst_sequence: ^SEQ ( * ),
        symbol_table: ^oct$symbol_table,
        symbol_number: integer;


      lst_sequence := lst_file.segment.sequence_pointer;

      RESET lst_sequence;
      NEXT header IN lst_sequence;
      IF header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, lst_file.name, status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      IF header^.version <> occ$symbol_table_version THEN
        osp$set_status_abnormal ('OC', oce$e_invalid_lst_version, lst_file.name, status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      IF header^.number_of_symbols > 0 THEN
        NEXT linker_symbol_table: [1 .. header^.number_of_symbols] IN lst_sequence;
        IF linker_symbol_table = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, lst_file.name, status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        NEXT symbol_table: [1 .. header^.number_of_symbols] IN ocv$rmb_scratch_seq;
        IF symbol_table = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB8', status);
          RETURN;
        IFEND;

        FOR symbol_number := 1 TO header^.number_of_symbols DO
          symbol_table^ [symbol_number].name := linker_symbol_table^ [symbol_number].name;
          symbol_table^ [symbol_number].pva := linker_symbol_table^ [symbol_number].pva;
        FOREND;

        lst_last := lst_last + header^.number_of_symbols;
      IFEND;

    PROCEND read_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_SYMBOL_TABLE', EJECT ??

    PROCEDURE build_symbol_table
      (    symbol_table_list: oct$symbol_table_list;
       VAR exchange_info: oct$exchange_package_info;
       VAR status: ost$status);





      VAR
        local_status: ost$status,

        number_of_symbols: integer,
        reset_value: ^SEQ ( * ),

        ost_file: oct$file_descriptor,
        symbol_tables: ^oct$symbol_table_list;



      reset_value := ocv$rmb_scratch_seq;
      number_of_symbols := 0;
      symbol_tables := symbol_table_list.link;

      WHILE symbol_tables <> NIL DO

        open_input_file (symbol_tables^.name, ost_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        read_symbol_table (ost_file, number_of_symbols, status);
        IF NOT status.normal THEN
          close_file (ost_file, local_status);
          IF NOT local_status.normal THEN
            issue_diagnostic (local_status);
          IFEND;
          RETURN;
        IFEND;

        close_file (ost_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        symbol_tables := symbol_tables^.link;
      WHILEND;

      IF number_of_symbols <> 0 THEN
        ocv$rmb_scratch_seq := reset_value;
        NEXT exchange_info.symbol_table: [1 .. number_of_symbols] IN ocv$rmb_scratch_seq;
      IFEND;

    PROCEND build_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '    CHANGE_EXCHANGE_NAME_TO_ADDR', EJECT ??

    PROCEDURE change_exchange_name_to_addr
      (    exchange_name: oct$exchange_name;
       VAR exchange_address: oct$exchange_address);



      VAR
        local_status: ost$status,

        symbol_table: ^oct$symbol_table,
        i: integer;


      IF exchange_name.address_space = occ$null THEN
        exchange_address.address_space := occ$null;
      ELSE
        IF exchange_name.address_space = occ$mtr THEN
          symbol_table := v$mtr_exchange_info.symbol_table;
        ELSE
          symbol_table := v$job_exchange_info.symbol_table;
        IFEND;

        IF symbol_table <> NIL THEN
          FOR i := 1 TO UPPERBOUND (symbol_table^) DO
            IF exchange_name.name = symbol_table^ [i].name THEN
              exchange_address.address_space := exchange_name.address_space;
              exchange_address.segment := symbol_table^ [i].pva.seg;
              exchange_address.segment_offset := symbol_table^ [i].pva.offset;
              RETURN;
            IFEND;
          FOREND;
        IFEND;

        exchange_address.address_space := occ$null;
        osp$set_status_abnormal ('OC', oce$e_exchange_symbol_not_found, exchange_name.name, local_status);
        issue_diagnostic (local_status);
      IFEND;

    PROCEND change_exchange_name_to_addr;
?? OLDTITLE ??
?? NEWTITLE := '    LOAD_FILE', EJECT ??

    PROCEDURE load_file
      (VAR segment_file: oct$file_descriptor;
       VAR exchange_info: oct$exchange_package_info;
       VAR status: ost$status);


      VAR
        pva: ^ost$pva,
        found: boolean,
        starting_address: ost$real_memory_address,

        virtual_memory_image_header: ^pmt$virtual_memory_image_header,
        segment_descriptors: ^oct$segment_descriptors,
        linked_segment_description: ^pmt$linked_segment_description,

{ 170 comparability kludge

        segment_command: ^oct$segment_command_list,
        seg_desc: ost$segment;



      RESET segment_file.segment.sequence_pointer;

      NEXT virtual_memory_image_header IN segment_file.segment.sequence_pointer;
      IF virtual_memory_image_header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, segment_file.name, status);
        RETURN;
      IFEND;

      IF virtual_memory_image_header^.version <> pmc$image_version THEN
        osp$set_status_abnormal ('OC', oce$e_invalid_load_file_version, segment_file.name, status);
        RETURN;
      IFEND;

      IF virtual_memory_image_header^.number_of_segments = 0 THEN
        osp$set_status_abnormal ('OC', oce$e_empty_segment_file, segment_file.name, status);
        RETURN;
      ELSE

{ The p_address ring number is zero only if there was no primary entry point for
{ this group of load segments.

        pva := #LOC (virtual_memory_image_header^.starting_procedure.code_pva);

        IF pva^.ring <> osc$invalid_ring THEN
          exchange_info.p_address := pva^;

          pva := #LOC (virtual_memory_image_header^.starting_procedure.binding_pva);
          exchange_info.binding_address := pva^;
        IFEND;

        NEXT segment_descriptors: [1 .. virtual_memory_image_header^.number_of_segments] IN
              ocv$rmb_scratch_seq;
        IF segment_descriptors = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB9', status);
          RETURN;
        IFEND;

      /process_segments/
        FOR seg_desc := 1 TO virtual_memory_image_header^.number_of_segments DO

          NEXT linked_segment_description IN segment_file.segment.sequence_pointer;
          IF linked_segment_description = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, segment_file.name, status);
            RETURN;
          IFEND;

          build_segment_descriptor (linked_segment_description, segment_descriptors^ [seg_desc]);

          NEXT segment_descriptors^ [seg_desc].asid IN ocv$rmb_scratch_seq;
          IF segment_descriptors^ [seg_desc].asid = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB10', status);
            RETURN;
          IFEND;

          segment_descriptors^ [seg_desc].asid^.assigned := FALSE;
          segment_descriptors^ [seg_desc].asid^.predefined := FALSE;

          starting_address := v$real_memory_image.next_free_page;
          IF (exchange_info.address_space = v$job_exchange_info.exchange_address.address_space) AND
                (v$job_exchange_info.exchange_address.segment = segment_descriptors^ [seg_desc].
                segment_number) THEN
            search_for_contiguous_pages (starting_address, segment_descriptors^ [seg_desc].segment_length^,
                  found, starting_address);
            IF found THEN
              v$job_exchange_info.rma := starting_address + exchange_info.exchange_address.segment_offset;
            ELSE
              v$job_exchange_info.exchange_address.address_space := occ$null;
              osp$set_status_abnormal ('OC', oce$e_no_contiguous_real_memory,
                    'containing JOB EXCHANGE PACKAGE', status);
              issue_diagnostic (status);
              CYCLE /process_segments/;
            IFEND;
          IFEND;

          IF (exchange_info.address_space = v$mtr_exchange_info.exchange_address.address_space) AND
                (v$mtr_exchange_info.exchange_address.segment = segment_descriptors^ [seg_desc].
                segment_number) THEN
            search_for_contiguous_pages (starting_address, segment_descriptors^ [seg_desc].segment_length^,
                  found, starting_address);
            IF found THEN
              v$mtr_exchange_info.rma := starting_address + exchange_info.exchange_address.segment_offset;
            ELSE
              v$mtr_exchange_info.exchange_address.address_space := occ$null;
              osp$set_status_abnormal ('OC', oce$e_no_contiguous_real_memory,
                    'containing MTR EXCHANGE PACKAGE', status);
              issue_diagnostic (status);
              CYCLE /process_segments/;
            IFEND;
          IFEND;


          allocate_pages (starting_address, segment_descriptors^ [seg_desc].segment_length^,
                segment_descriptors^ [seg_desc].pages, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          copy_file (segment_file, segment_descriptors^ [seg_desc], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ 170 comparability kludge

          segment_command := build_options.segment_commands.link;
          WHILE segment_command <> NIL DO
            IF segment_command^.kind = occ$extend THEN
              IF (segment_command^.address_space = exchange_info.address_space) AND
                    (segment_command^.segment_number = segment_descriptors^ [seg_desc].segment_number) THEN
                extend_segment (segment_command, segment_descriptors^ [seg_desc], status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
            segment_command := segment_command^.link;
          WHILEND;

          add_a_segment (^segment_descriptors^ [seg_desc], exchange_info.segment_descriptor_list);
        FOREND /process_segments/;
      IFEND;

    PROCEND load_file;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_LOAD_FILES', EJECT ??

    PROCEDURE process_load_files
      (    load_file_list: oct$load_file_list;
       VAR status: ost$status);





      VAR
        local_status: ost$status,

        header_file: oct$file_descriptor,
        load_files: ^oct$load_file_list;



      load_files := load_file_list.link;

      WHILE load_files <> NIL DO
        open_input_file (load_files^.name, header_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE load_files^.address_space OF
        = occ$mtr =
          load_file (header_file, v$mtr_exchange_info, status);

        = occ$job =
          load_file (header_file, v$job_exchange_info, status);

        CASEND;

        IF NOT status.normal THEN
          close_file (header_file, local_status);
          IF NOT local_status.normal THEN
            issue_diagnostic (local_status);
          IFEND;
          RETURN;
        IFEND;


        close_file (header_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        load_files := load_files^.link;
      WHILEND;


    PROCEND process_load_files;
?? OLDTITLE ??
?? NEWTITLE := '    CHANGE_SEGMENT', EJECT ??

    PROCEDURE change_segment
      (    change_command: ^oct$segment_command_list;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);




      VAR
        found: boolean,
        last_asid: ^oct$reserved_asids;



      IF occ$attributes IN change_command^.parameters THEN
        IF change_command^.hardware_attributes.cache_bypass THEN
          segment_descriptor^.ste.vl := osc$vl_cache_bypass;
        ELSE
          segment_descriptor^.ste.vl := osc$vl_regular_segment;
        IFEND;

        segment_descriptor^.ste.xp := change_command^.hardware_attributes.execute_privilege;
        segment_descriptor^.ste.rp := change_command^.hardware_attributes.read_privilege;
        segment_descriptor^.ste.wp := change_command^.hardware_attributes.write_privilege;
        segment_descriptor^.software_attributes := change_command^.software_attributes;
      IFEND;


      IF occ$ring_brackets IN change_command^.parameters THEN
        segment_descriptor^.ste.r1 := change_command^.r1;
        segment_descriptor^.ste.r2 := change_command^.r2;
      IFEND;

      IF occ$asid IN change_command^.parameters THEN
        IF NOT ((segment_descriptor^.asid^.predefined) AND (change_command^.active_segment_id =
              segment_descriptor^.asid^.active_segment_id)) THEN
          search_reserved_asids (change_command^.active_segment_id, found, last_asid);
          IF found THEN
            STRINGREP (strng, l, change_command^.active_segment_id);
            osp$set_status_abnormal ('OC', oce$e_duplicate_asid_specified, strng (1, l), status);
            issue_diagnostic (status);
          ELSE
            IF segment_descriptor^.asid^.predefined THEN
              search_reserved_asids (segment_descriptor^.asid^.active_segment_id, found, last_asid);
            ELSE
              NEXT last_asid^.link IN ocv$rmb_scratch_seq;
              last_asid := last_asid^.link;
              IF last_asid = NIL THEN
                osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB12', status);
                RETURN;
              IFEND;

              last_asid^.link := NIL;
            IFEND;
            last_asid^.asid := change_command^.active_segment_id;
            segment_descriptor^.asid^.active_segment_id := change_command^.active_segment_id;
            segment_descriptor^.asid^.predefined := TRUE;
          IFEND;
        IFEND;
      IFEND;


      IF occ$gl_key IN change_command^.parameters THEN
        segment_descriptor^.ste.key_lock := change_command^.key_lock;
      IFEND;


    PROCEND change_segment;
?? OLDTITLE ??
?? NEWTITLE := '    SHARE_SEGMENT', EJECT ??

    PROCEDURE share_segment
      (    share_command: ^oct$segment_command_list;
           segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);



      VAR
        new_segment_descriptor: ^oct$segment_descriptor;



      NEXT new_segment_descriptor IN ocv$rmb_scratch_seq;
      IF new_segment_descriptor = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB13', status);
        RETURN;
      IFEND;

      new_segment_descriptor^ := segment_descriptor^;
      new_segment_descriptor^.segment_number := share_command^.new_segment_number;

      CASE share_command^.new_address_space OF

      = occ$mtr =
        add_a_segment (new_segment_descriptor, v$mtr_exchange_info.segment_descriptor_list);

      = occ$job =
        add_a_segment (new_segment_descriptor, v$job_exchange_info.segment_descriptor_list);
      CASEND;

    PROCEND share_segment;
?? OLDTITLE ??
?? NEWTITLE := '    EXTEND_SEGMENT', EJECT ??

    PROCEDURE extend_segment
      (    extend_command: ^oct$segment_command_list;
       VAR segment_descriptor: oct$segment_descriptor;
       VAR status: ost$status);



      VAR
        page_descriptor: ^^oct$page_descriptor,
        adjusted_length: ost$segment_length;




      adjusted_length := extend_command^.extend_length - (build_options.page_size -
            (segment_descriptor.segment_length^ MOD build_options.page_size));

      IF adjusted_length > 0 THEN
        page_descriptor := ^segment_descriptor.pages;

        WHILE page_descriptor^ <> NIL DO
          page_descriptor := ^page_descriptor^^.link;
        WHILEND;

        allocate_pages (v$real_memory_image.next_free_page, adjusted_length, page_descriptor^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      segment_descriptor.segment_length^ := segment_descriptor.segment_length^ +extend_command^.extend_length;


    PROCEND extend_segment;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_SEGMENT_COMMANDS', EJECT ??

    PROCEDURE process_segment_commands
      (    segment_command_list: oct$segment_command_list;
       VAR status: ost$status);



      VAR
        segment_descriptor: ^oct$segment_descriptor,
        segment_command: ^oct$segment_command_list,
        segment_found: boolean;



      segment_command := segment_command_list.link;

      WHILE segment_command <> NIL DO
        search_for_segment (segment_command^.address_space, segment_command^.segment_number,
              segment_descriptor, segment_found);

        IF NOT segment_found THEN
          STRINGREP (strng, l, segment_command^.segment_number);
          osp$set_status_abnormal ('OC', oce$e_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
        ELSE
          CASE segment_command^.kind OF
          = occ$change =
            change_segment (segment_command, segment_descriptor, status);

          = occ$share =
            share_segment (segment_command, segment_descriptor, status);

          = occ$extend =

{ 170 comparability kludge
{ extend_segment (segment_command, segment_descriptor^, status);

          CASEND;

          IF NOT status.normal THEN
            issue_diagnostic (status);
          IFEND;
        IFEND;

        segment_command := segment_command^.link;
      WHILEND;

    PROCEND process_segment_commands;
?? OLDTITLE ??
?? NEWTITLE := '    DISPLAY_MEMORY_ADDRESS', EJECT ??

    PROCEDURE display_memory_address
      (    starting_address: ost$real_memory_address;
           length: ost$real_memory_address;
       VAR display_control: clt$display_control;
       VAR status: ost$status);



      CONST
        word_size = 19;


      VAR
        i: integer,
        memory: ^array [ * ] of ost$byte,
        display_word: ^oct$display_word,
        local_status: ost$status,

        bytes_per_line: integer,
        sum_of_line: integer,
        blank_line: boolean,
        valid_position: boolean,

        current_address: ost$real_memory_address,
        ending_address: ost$real_memory_address;


      VAR
        strng: [STATIC] string (11) := '           ';





      IF display_control.page_width < 28 THEN
        osp$set_status_abnormal ('OC', oce$e_page_width_error, '', status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      current_address := starting_address;

      IF starting_address + length > v$real_memory_image.length THEN
        IF starting_address >= v$real_memory_image.length THEN
          osp$set_status_abnormal ('OC', oce$w_invalid_display_mem_addr, '', status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        ending_address := v$real_memory_image.length - 1;
      ELSE
        ending_address := starting_address + length - 1;
      IFEND;

      pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, starting_address,
            valid_position);
      NEXT memory: [starting_address .. ending_address] IN v$real_memory_image.segment.sequence_pointer;

      blank_line := FALSE;
      bytes_per_line := ((display_control.page_width - 9) DIV word_size) * 8;

      WHILE (current_address + 7) <= ending_address DO
        IF ((display_control.column_number + word_size) > display_control.page_width) OR
              (display_control.column_number = 1) THEN
          IF (current_address + bytes_per_line) > ending_address THEN
            bytes_per_line := ending_address - current_address + 1;
          IFEND;

          sum_of_line := 0;
          FOR i := 0 TO bytes_per_line - 1 DO
            sum_of_line := sum_of_line + memory^ [current_address + i];
          FOREND;

          IF sum_of_line = 0 THEN
            IF NOT blank_line THEN
              blank_line := TRUE;
              clp$new_display_line (display_control, 1, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

            current_address := current_address + bytes_per_line;
          ELSE
            blank_line := FALSE;

            clp$convert_integer_to_rjstring (current_address, 16, FALSE, '0', strng (3, 8), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (3, 9), clc$no_trim, amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSE
          display_word := #LOC (memory^ [current_address]);

          clp$convert_integer_to_rjstring (display_word^.upper_half, 16, FALSE, '0', strng (3, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, strng (1, 10), clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (display_word^.lower_half, 16, FALSE, '0', strng (3, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, strng (2, 9), clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          current_address := current_address + 8;
        IFEND;
      WHILEND;

      IF current_address <= ending_address THEN
        bytes_per_line := ending_address - current_address;

        sum_of_line := 0;
        FOR i := 0 TO bytes_per_line DO
          sum_of_line := sum_of_line + memory^ [current_address + i];
        FOREND;

        IF sum_of_line <> 0 THEN
          IF (display_control.column_number + word_size) > display_control.page_width THEN
            clp$convert_integer_to_rjstring (current_address, 16, FALSE, '0', strng (3, 8), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (3, 9), clc$no_trim, amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          IF (current_address + 3) <= ending_address THEN
            display_word := #LOC (memory^ [current_address]);

            clp$convert_integer_to_rjstring (display_word^.upper_half, 16, FALSE, '0', strng (3, 8), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (1, 10), clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            current_address := current_address + 4;
          ELSE
            clp$put_partial_display (display_control, '  ', clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          WHILE current_address <= ending_address DO
            clp$convert_integer_to_rjstring (memory^ [current_address], 16, FALSE, '0', strng (3, 2), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (3, 2), clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            current_address := current_address + 1;
          WHILEND;
        IFEND;
      IFEND;

      IF (starting_address + length) > v$real_memory_image.length THEN
        clp$put_partial_display (display_control, '          END OF REAL MEMORY IMAGE', clc$no_trim,
              amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND display_memory_address;
?? OLDTITLE ??
?? NEWTITLE := '    PRINT_PAGE_TABLE', EJECT ??

    PROCEDURE print_page_table
      (    segment_descriptor_list: oct$segment_descriptor;
           address_space: string (3);
       VAR display_control: clt$display_control;
       VAR status: ost$status);




      VAR
        attr_column: 79 .. 111,
        segment_descriptor: ^oct$segment_descriptor;



      VAR
        underline: [STATIC] string (89) :=
              '-----------------------------------------------------------------------------------------',
        page_table_header: [STATIC] string (89) :=
              '              ID                  ASID     RMA     PAGES   R1/R2   SN  TYPE   ATTRIBUTES',
        page_table_template: [STATIC] string (111) :=
              '                                                           ( , )';



      IF display_control.page_width < 105 THEN
        osp$set_status_abnormal ('OC', oce$e_page_width_error, '', status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      segment_descriptor := segment_descriptor_list.link;

      clp$put_partial_display (display_control, page_table_header, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, underline, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      WHILE segment_descriptor <> NIL DO
        page_table_template (1, 31) := segment_descriptor^.segment_id;

        clp$convert_integer_to_rjstring (segment_descriptor^.asid^.active_segment_id, 16, FALSE, '0',
              page_table_template (35, 4), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF segment_descriptor^.pages <> NIL THEN
          clp$convert_integer_to_rjstring (segment_descriptor^.pages^.offset, 16, FALSE, '0',
                page_table_template (42, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          page_table_template (42, 8) := '********';
        IFEND;

        clp$convert_integer_to_rjstring ((segment_descriptor^.segment_length^ +build_options.page_size -
              1) DIV build_options.page_size, 16, FALSE, '0', page_table_template (53, 4), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.ste.r1, 16, FALSE, '0',
              page_table_template (61, 1), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.ste.r2, 16, FALSE, '0',
              page_table_template (63, 1), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.segment_number, 16, FALSE, '0',
              page_table_template (68, 2), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        page_table_template (73, 3) := address_space;

        attr_column := 79;
        page_table_template (79, 33) := '  ';

        IF segment_descriptor^.ste.xp = osc$non_privileged THEN
          page_table_template (attr_column, 2) := 'EX';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.xp = osc$local_privilege THEN
          page_table_template (attr_column, 2) := 'LP';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.xp = osc$global_privilege THEN
          page_table_template (attr_column, 2) := 'GP';
          attr_column := attr_column + 3;
        IFEND;

        IF segment_descriptor^.ste.rp = osc$read_key_lock_controlled THEN
          page_table_template (attr_column, 2) := 'RK';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.rp = osc$read_uncontrolled THEN
          page_table_template (attr_column, 2) := 'RD';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.rp = osc$binding_segment THEN
          page_table_template (attr_column, 2) := 'BI';
        IFEND;

        IF segment_descriptor^.ste.wp = osc$write_key_lock_controlled THEN
          page_table_template (attr_column, 2) := 'WK';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.wp = osc$write_uncontrolled THEN
          page_table_template (attr_column, 2) := 'WT';
          attr_column := attr_column + 3;
        IFEND;

        IF segment_descriptor^.ste.vl = osc$vl_cache_bypass THEN
          page_table_template (attr_column, 2) := 'CB';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_wired IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'WR';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_fixed IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'FX';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_stack IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'ST';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_read_transfer_unit IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'RT';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_free_behind IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'FB';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_no_append IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'NA';
        IFEND;

        clp$put_partial_display (display_control, page_table_template, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        segment_descriptor := segment_descriptor^.link;
      WHILEND;

    PROCEND print_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    PRINT_MEMORY_MAP', EJECT ??

    PROCEDURE print_memory_map
      (    segment_descriptor_list: oct$segment_descriptor;
           address_space: string (3);
       VAR display_control: clt$display_control;
       VAR status: ost$status);




      VAR
        pages: ^oct$page_descriptor,
        offset: ost$segment_offset,
        segment_descriptor: ^oct$segment_descriptor,
        page_address: ost$real_memory_address,
        segment_info: [STATIC] string (52) := '    segment 000 from',
        address_template: [STATIC] string (65) :=
              '  0 000 00000000  ...  0 000 00000000     00000000  ...  00000000';



      IF display_control.page_width < 65 THEN
        osp$set_status_abnormal ('OC', oce$e_page_width_error, '', status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      segment_descriptor := segment_descriptor_list.link;

      WHILE segment_descriptor <> NIL DO
        segment_info (1, 3) := address_space;

        clp$convert_integer_to_rjstring (segment_descriptor^.segment_number, 16, FALSE, '0',
              segment_info (13, 3), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, segment_info, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.ste.r1, 16, FALSE, '0', address_template (3, 1),
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        address_template (24, 1) := address_template (3, 1);
        address_template (5, 3) := segment_info (13, 3);
        address_template (26, 3) := address_template (5, 3);

        pages := segment_descriptor^.pages;
        offset := 0;

        WHILE pages <> NIL DO
          clp$convert_integer_to_rjstring (offset, 16, FALSE, '0', address_template (9, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (pages^.offset, 16, FALSE, '0', address_template (43, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          page_address := pages^.offset;

          WHILE (pages <> NIL) AND (pages^.offset = page_address) DO
            page_address := page_address + build_options.page_size;
            offset := offset + build_options.page_size;
            pages := pages^.link;
          WHILEND;

          IF pages = NIL THEN
            offset := offset - build_options.page_size + (segment_descriptor^.segment_length^ MOD
                  build_options.page_size);
            page_address := page_address - build_options.page_size +
                  (segment_descriptor^.segment_length^ MOD build_options.page_size);
          IFEND;

          clp$convert_integer_to_rjstring (offset - 1, 16, FALSE, '0', address_template (30, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (page_address - 1, 16, FALSE, '0', address_template (58, 8),
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, address_template, clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        WHILEND;

        segment_descriptor := segment_descriptor^.link;
      WHILEND;

    PROCEND print_memory_map;
?? OLDTITLE ??
?? NEWTITLE := '    PRINT_RMB_SUMMARY', EJECT ??

    PROCEDURE print_rmb_summary
      (VAR display_control: clt$display_control;
       VAR status: ost$status);



      VAR
        highest_load_address: [STATIC] string (32) := ' HIGHEST LOAD ADDRESS =         ',
        pt_continue_bits: [STATIC] string (32) := ' PAGE TABLE CONTINUE BITS =     ';



      clp$convert_integer_to_rjstring (v$real_memory_image.length - 1, 16, FALSE, '0',
            highest_load_address (25, 8), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, highest_load_address, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (v$real_memory_image.pt_continue_bits, 10, FALSE, '0',
            pt_continue_bits (29, 4), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, pt_continue_bits, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND print_rmb_summary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_MEMORY_COMMANDS', EJECT ??

    PROCEDURE process_memory_commands
      (    memory_command_list: oct$memory_command_list;
       VAR status: ost$status);




      VAR
        of_execution: boolean,
        local_status: ost$status,
        default_rings: amt$ring_attributes,
        display_control: clt$display_control,
        display_control_ptr: ^clt$display_control,
        memory_command: ^oct$memory_command_list;



      VAR
        position_attribute: array [1 .. 1] of amt$file_item,
        memory_dump_header: [STATIC] string (22) := 'DISPLAY MEMORY ADDRESS',
        mtr_xp_header: [STATIC] string (24) := 'MONITOR EXCHANGE PACKAGE',
        job_xp_header: [STATIC] string (20) := 'JOB EXCHANGE PACKAGE',
        underline: [STATIC] string (24) := '------------------------';




      memory_command := memory_command_list.link;

      WHILE memory_command <> NIL DO
        IF (memory_command^.file_name_specified) AND (memory_command^.output.local_file_name <>
              build_options.memory_map.local_file_name) THEN

          default_rings.r1 := #RING (^of_execution);
          default_rings.r2 := #RING (^of_execution);
          default_rings.r3 := #RING (^of_execution);

          clp$open_display_file (memory_command^.output, ^new_page_procedure, fsc$list, default_rings,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_control_ptr := ^display_control;
        ELSE
          display_control_ptr := ^v$display_control;
          clp$new_display_line (v$display_control, 2, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      /command_loop/
        BEGIN
          CASE memory_command^.kind OF

          = occ$display_memory =

            CASE memory_command^.memory OF
            = occ$all =
              display_memory_address (build_options.load_offset, v$real_memory_image.length,
                    display_control_ptr^, status);

            = occ$page_table =
              IF v$mtr_exchange_info.segment_descriptor_list.link <> NIL THEN
                print_page_table (v$mtr_exchange_info.segment_descriptor_list, 'MTR', display_control_ptr^,
                      status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;

                clp$new_display_line (display_control_ptr^, 2, status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;
              IFEND;

              IF v$job_exchange_info.segment_descriptor_list.link <> NIL THEN
                print_page_table (v$job_exchange_info.segment_descriptor_list, 'JOB', display_control_ptr^,
                      status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;

                clp$new_display_line (display_control_ptr^, 2, status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;
              IFEND;

              print_rmb_summary (display_control_ptr^, status);

            = occ$memory_map =
              print_memory_map (v$mtr_exchange_info.segment_descriptor_list, 'MTR', display_control_ptr^,
                    status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              print_memory_map (v$job_exchange_info.segment_descriptor_list, 'JOB', display_control_ptr^,
                    status);

            = occ$mps =
              clp$put_partial_display (display_control_ptr^, mtr_xp_header, clc$no_trim, amc$start, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              clp$put_display (display_control_ptr^, underline, clc$no_trim, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              IF v$mtr_exchange_info.exchange_address.address_space <> occ$null THEN
                display_memory_address (v$mtr_exchange_info.rma, #SIZE (ost$exchange_package),
                      display_control_ptr^, status);
              ELSE
                osp$set_status_abnormal ('OC', oce$w_no_exchange_package, 'MTR EXCHANGE PACKAGE', status);
                issue_diagnostic (status);
              IFEND;

            = occ$jps =
              clp$put_partial_display (display_control_ptr^, job_xp_header, clc$no_trim, amc$start, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              clp$put_display (display_control_ptr^, underline (1, 20), clc$no_trim, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              IF v$job_exchange_info.exchange_address.address_space <> occ$null THEN
                display_memory_address (v$job_exchange_info.rma, #SIZE (ost$exchange_package),
                      display_control_ptr^, status);
              ELSE
                osp$set_status_abnormal ('OC', oce$w_no_exchange_package, 'JOB EXCHANGE PACKAGE', status);
                issue_diagnostic (status);
              IFEND;
            CASEND;

          = occ$display_memory_address =
            clp$put_partial_display (display_control_ptr^, memory_dump_header, clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              EXIT /command_loop/;
            IFEND;

            clp$put_display (display_control_ptr^, underline (1, 22), clc$no_trim, status);
            IF NOT status.normal THEN
              EXIT /command_loop/;
            IFEND;

            display_memory_address (memory_command^.display_address, memory_command^.length,
                  display_control_ptr^, status);
          CASEND;
        END /command_loop/;

        IF NOT status.normal THEN
          IF (memory_command^.file_name_specified) AND (memory_command^.output.local_file_name <>
                build_options.memory_map.local_file_name) THEN
            clp$close_display (display_control_ptr^, local_status);
            IF NOT local_status.normal THEN
              issue_diagnostic (local_status);
            IFEND;
          IFEND;
          RETURN;
        IFEND;

        IF (memory_command^.file_name_specified) AND (memory_command^.output.local_file_name <>
              build_options.memory_map.local_file_name) THEN
          clp$put_display (display_control_ptr^, '  ', clc$no_trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$close_display (display_control_ptr^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        memory_command := memory_command^.link;
      WHILEND;

    PROCEND process_memory_commands;
?? OLDTITLE ??
?? NEWTITLE := '    GET_ASID', EJECT ??

    PROCEDURE get_asid
      (VAR asid: ost$asid);



      VAR
        i,
        f: integer,

        found: boolean,
        last_asid: ^oct$reserved_asids;



      found := TRUE;

      REPEAT
        i := v$asid_seed;
        v$asid_seed := v$asid_seed + 1;

        f := build_options.page_table_length DIV 32;
        asid := 0;

        WHILE i <> 0 DO
          IF (i MOD 2) <> 0 THEN
            asid := asid + f;
          IFEND;

          i := i DIV 2;
          f := f DIV 2;
        WHILEND;

        IF (asid <> nos_asid) AND (asid <> ssr_asid) THEN
          search_reserved_asids (asid, found, last_asid);
        IFEND;
      UNTIL NOT found;


    PROCEND get_asid;
?? OLDTITLE ??
?? NEWTITLE := '    PAD_PAGE_TABLE', EJECT ??

    PROCEDURE pad_page_table
      (    pad_size: integer;
           pad_asid: ost$asid;
       VAR status: ost$status);



      VAR
        next_free_page: ost$real_memory_address,
        page_table_overflow: boolean,
        pages: ^oct$page_descriptor,
        pte: ost$page_table_entry;



      IF pad_size <> 0 THEN
        next_free_page := v$real_memory_image.next_free_page;
        allocate_pages (0, pad_size, pages, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pte.pageid.asid := pad_asid;
        pte.v := TRUE;
        pte.c := FALSE;
        pte.u := FALSE;
        pte.m := TRUE;

        build_next_page_table_entry (0, pages, pte, page_table_overflow);
        IF page_table_overflow THEN
          osp$set_status_abnormal ('OC', oce$e_page_table_overflow, '', status);
          issue_diagnostic (status);
        IFEND;

        WHILE pages <> NIL DO
          v$real_memory_image.page^ [pages^.offset DIV build_options.page_size].reserved := FALSE;
          pages := pages^.link;
        WHILEND;

        v$real_memory_image.next_free_page := next_free_page;
      IFEND;

    PROCEND pad_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    REMOVE_PAGE_TABLE_PADS', EJECT ??

    PROCEDURE remove_page_table_pads;


      VAR
        i: integer,
        asid: ost$asid,
        fb_hash: -osc$max_page_table_entries .. osc$max_page_table_entries,
        current_index: -1 .. osc$max_page_table_entries,
        page_table_length: 512 .. osc$max_page_table_entries;


      page_table_length := build_options.page_table_length DIV 8;

      FOR i := 0 TO page_table_length - 1 DO
        asid := v$real_memory_image.page_table^ [i].pageid.asid;

        IF v$real_memory_image.page_table^ [i].v THEN
          IF (asid = nos_asid) OR (asid = ssr_asid) THEN
            generate_page_table_index (asid, v$real_memory_image.page_table^ [i].pageid.pagenum, fb_hash);

            v$real_memory_image.page_table^ [i].v := FALSE;
            v$real_memory_image.page_table^ [i].m := FALSE;
            v$real_memory_image.page_table^ [i].pageid.asid := 0;
            v$real_memory_image.page_table^ [i].pageid.pagenum := 0;
            v$real_memory_image.page_table^ [i].rma := 0;

            current_index := i;

            WHILE fb_hash <> current_index DO
              current_index := current_index - 1;
              IF current_index < 0 THEN
                current_index := page_table_length - 1;
              IFEND;

              v$real_memory_image.page^ [current_index].continue_bits := v$real_memory_image.
                    page^ [current_index].continue_bits - 1;
              IF v$real_memory_image.page^ [current_index].continue_bits = 0 THEN
                v$real_memory_image.page_table^ [current_index].c := FALSE;
                v$real_memory_image.pt_continue_bits := v$real_memory_image.pt_continue_bits - 1;
              IFEND;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;


    PROCEND remove_page_table_pads;
?? OLDTITLE ??
?? NEWTITLE := '    INSERT_NEXT_PAGE_TABLE_ENTRY', EJECT ??

    PROCEDURE insert_next_page_table_entry
      (    cbits: integer;
           pti: -osc$max_page_table_entries .. osc$max_page_table_entries;
           pagenum: ost$page_table_index;
           page_descriptor: ^oct$page_descriptor;
       VAR pte: ost$page_table_entry;
       VAR page_table_overflow: boolean);



      VAR
        old_pte: ost$page_table_entry;




      IF cbits = 32 THEN
        page_table_overflow := TRUE;
      ELSE
        old_pte := v$real_memory_image.page_table^ [pti];

        IF old_pte.v = TRUE THEN
          IF old_pte.c = FALSE THEN
            v$real_memory_image.page_table^ [pti].c := TRUE;
            v$real_memory_image.pt_continue_bits := v$real_memory_image.pt_continue_bits + 1;
          IFEND;

          v$real_memory_image.page^ [pti].continue_bits := v$real_memory_image.page^ [pti].continue_bits + 1;

          insert_next_page_table_entry ((cbits + 1), (pti + 1) MOD (build_options.page_table_length DIV 8),
                pagenum, page_descriptor, pte, page_table_overflow);

          IF page_table_overflow THEN
            v$real_memory_image.page_table^ [pti] := old_pte;
            IF old_pte.c = FALSE THEN
              v$real_memory_image.pt_continue_bits := v$real_memory_image.pt_continue_bits - 1;
            IFEND;
            v$real_memory_image.page^ [pti].continue_bits := v$real_memory_image.page^ [pti].continue_bits -
                  1;
          IFEND;
        ELSE
          v$real_memory_image.page_table^ [pti] := pte;
          build_next_page_table_entry (pagenum + 1, page_descriptor^.link, pte, page_table_overflow);

          IF page_table_overflow THEN
            v$real_memory_image.page_table^ [pti] := old_pte;
          IFEND;
        IFEND;
      IFEND;

    PROCEND insert_next_page_table_entry;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_NEXT_PAGE_TABLE_ENTRY', EJECT ??

    PROCEDURE build_next_page_table_entry
      (    pagenum: ost$page_table_index;
           page_descriptor: ^oct$page_descriptor;
       VAR pte: ost$page_table_entry;
       VAR page_table_overflow: boolean);



      VAR
        pti: -osc$max_page_table_entries .. osc$max_page_table_entries;



      IF page_descriptor = NIL THEN
        page_table_overflow := FALSE;
      ELSE
        pte.rma := page_descriptor^.offset DIV 512;
        pte.pageid.pagenum := (pagenum * build_options.page_size) DIV 512;

        generate_page_table_index (pte.pageid.asid, pte.pageid.pagenum, pti);

        insert_next_page_table_entry (0, pti, pagenum, page_descriptor, pte, page_table_overflow);
      IFEND;

    PROCEND build_next_page_table_entry;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_PAGE_TABLE', EJECT ??

    PROCEDURE build_page_table
      (    segment_descriptor_list: oct$segment_descriptor);




      VAR
        pte: ost$page_table_entry,

        segment_descriptor: ^oct$segment_descriptor,
        asid: ost$asid,

        page_table_overflow: boolean,
        retry_count: 0 .. occ$max_retries;


      segment_descriptor := segment_descriptor_list.link;

      WHILE segment_descriptor <> NIL DO
        IF segment_descriptor^.asid^.assigned THEN
          segment_descriptor := segment_descriptor^.link;
        ELSE
          retry_count := 0;

        /build_pt_entry/
          WHILE retry_count < occ$max_retries DO
            IF segment_descriptor^.asid^.predefined THEN
              asid := segment_descriptor^.asid^.active_segment_id;
            ELSE
              get_asid (asid);
            IFEND;

            pte.pageid.asid := asid;
            pte.v := TRUE;
            pte.c := FALSE;
            pte.u := FALSE;
            pte.m := TRUE;

            build_next_page_table_entry (0, segment_descriptor^.pages, pte, page_table_overflow);

            IF page_table_overflow THEN
              IF segment_descriptor^.asid^.predefined THEN
                osp$set_status_abnormal ('OC', oce$e_asid_wont_hash_in_pt, strng (1, l), status);
                issue_diagnostic (status);
                EXIT /build_pt_entry/;
              ELSE
                retry_count := retry_count + 1;
              IFEND;
            ELSE
              segment_descriptor^.asid^.assigned := TRUE;
              segment_descriptor^.asid^.active_segment_id := asid;
              EXIT /build_pt_entry/;
            IFEND;
          WHILEND /build_pt_entry/;

          IF retry_count = occ$max_retries THEN
            osp$set_status_abnormal ('OC', oce$e_page_table_retry_failed, '', status);
            issue_diagnostic (status);
          IFEND;

          segment_descriptor := segment_descriptor^.link;
        IFEND;
      WHILEND;

    PROCEND build_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    INITIALIZE_EXCHANGE_PACKAGE', EJECT ??

    PROCEDURE initialize_exchange_package
      (    exchange_info: oct$exchange_package_info;
       VAR status: ost$status);



      TYPE
        oct$dummy_exchange_package = packed record
          filler1: 0 .. 0ffff(16),
          p: ost$pva,
          filler2: 0 .. 0ffff(16),
          a0: ost$pva,
          filler3: 0 .. 0ffff(16),
          a1: ost$pva,
          filler4: 0 .. 0ffff(16),
          a2: ost$pva,
          filler5: 0 .. 0ffff(16),
          a3: ost$pva,
        recend;



      VAR
        ring_number: ost$valid_ring,
        segment_table: oct$half_word,
        segment_table_relative_address: ost$real_memory_address,

        segment_descriptor: ^oct$segment_descriptor,
        stack_segment_descriptor: ^oct$segment_descriptor,

        segment_table_entries: ^array [ * ] of record
          ste: ost$segment_descriptor,
          fill: 0 .. 0ffffff(16),
        recend,
        xcb: ^ost$execution_control_block,

        dummy_exchange_package: ^oct$dummy_exchange_package,
        valid_position: boolean,
        tos_pointer: ^cell,
        segment_found: boolean;



      IF exchange_info.exchange_address.address_space <> occ$null THEN
        search_for_segment (exchange_info.exchange_address.address_space,
              exchange_info.exchange_address.segment, segment_descriptor, segment_found);
        IF NOT segment_found THEN
          STRINGREP (strng, l, exchange_info.exchange_address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        IF (exchange_info.exchange_address.segment_offset + #SIZE (ost$exchange_package)) >
              segment_descriptor^.segment_length^ THEN
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, 'EXCHANGE PACKAGE', status);
          osp$append_status_integer (osc$status_parameter_delimiter, exchange_info.exchange_address.segment,
                16, FALSE, status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, exchange_info.rma,
              valid_position);

        NEXT xcb IN v$real_memory_image.segment.sequence_pointer;

        IF exchange_info.exchange_address.address_space = occ$mtr THEN
          xcb^.xp.x_registers [0] := v$pp_address_array_rma DIV 8;
        IFEND;

        segment_table.address_1 := xcb^.xp.segment_table_address_1;
        segment_table.address_2 := xcb^.xp.segment_table_address_2;

        segment_table_relative_address := segment_table.rma;
        segment_table.rma := segment_table.rma + segment_descriptor^.pages^.offset;
        xcb^.xp.segment_table_address_1 := segment_table.address_1;
        xcb^.xp.segment_table_address_2 := segment_table.address_2;

        IF exchange_info.p_address.ring <> 0 THEN
          dummy_exchange_package := #LOC (xcb^);
          dummy_exchange_package^.p := exchange_info.p_address;
          dummy_exchange_package^.a0.ring := xcb^.xp.p_register.pva.ring;
          dummy_exchange_package^.a1.ring := xcb^.xp.p_register.pva.ring;
          dummy_exchange_package^.a3 := exchange_info.binding_address;
        IFEND;

        FOR ring_number := osc$min_ring TO osc$max_ring DO
          tos_pointer := #ADDRESS (xcb^.xp.tos_registers [ring_number].
                pva.ring, xcb^.xp.tos_registers [ring_number].pva.seg, xcb^.xp.tos_registers [ring_number].
                pva.offset);
          IF tos_pointer <> NIL THEN
            xcb^.xp.tos_registers [ring_number].pva.ring := ring_number;

            search_for_segment (exchange_info.address_space, xcb^.xp.tos_registers [ring_number].pva.seg,
                  stack_segment_descriptor, segment_found);
            IF segment_found THEN
              stack_segment_descriptor^.ste.r1 := ring_number;
              stack_segment_descriptor^.ste.r2 := ring_number;
            IFEND;
          IFEND;
        FOREND;

        IF xcb^.xp.segment_table_length <= 0 THEN
          STRINGREP (strng, l, segment_descriptor^.segment_number);
          osp$set_status_abnormal ('OC', oce$e_invalid_xp_seg_table_leng, strng (1, l), status);
          issue_diagnostic (status);
        ELSE
          IF (segment_table_relative_address + (xcb^.xp.segment_table_length * 8)) >
                segment_descriptor^.segment_length^ THEN
            osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, 'SEGMENT TABLE', status);
            osp$append_status_integer (osc$status_parameter_delimiter, segment_descriptor^.segment_number, 16,
                  FALSE, status);
            issue_diagnostic (status);
            RETURN;
          IFEND;

          pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, segment_table.rma,
                valid_position);
          NEXT segment_table_entries: [0 .. xcb^.xp.segment_table_length - 1] IN
                v$real_memory_image.segment.sequence_pointer;


          segment_descriptor := exchange_info.segment_descriptor_list.link;
          WHILE segment_descriptor <> NIL DO
            IF segment_descriptor^.segment_number > xcb^.xp.segment_table_length - 1 THEN
              STRINGREP (strng, l, segment_descriptor^.segment_number);
              osp$set_status_abnormal ('OC', oce$e_segment_number_to_large, strng (1, l), status);
              RETURN;
            IFEND;

            segment_descriptor^.ste.asid := segment_descriptor^.asid^.active_segment_id;

            segment_table_entries^ [segment_descriptor^.segment_number].ste := segment_descriptor^.ste;

{           xcb^.sdtx_p^.sdtx_table [segment_descriptor^.segment_number].software_attribute_set :=
{                 segment_descriptor^.software_attributes;

            segment_descriptor := segment_descriptor^.link;
          WHILEND;
        IFEND;
      IFEND;

    PROCEND initialize_exchange_package;
?? OLDTITLE ??
?? NEWTITLE := '    INITIALIZE_HCS_ROOT', EJECT ??

    PROCEDURE initialize_hcs_root
      (    pages_loaded_name: oct$exchange_name;
           page_size_name: oct$exchange_name;
           bytes_loaded_address: oct$exchange_name;
       VAR status: ost$status);


      VAR
        address: oct$exchange_address,
        segment_descriptor: ^oct$segment_descriptor,
        found: boolean,
        valid_position: boolean,
        rma: ost$real_memory_address,
        value: ^integer,
        half_word: ^0 .. 0ffffffff(16);


      change_exchange_name_to_addr (pages_loaded_name, address);
      v$pages_loaded_pva := address;

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        search_for_offset (address.segment_offset, segment_descriptor^.pages, rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, rma, valid_position);
        NEXT value IN v$real_memory_image.segment.sequence_pointer;
        value^ := (v$real_memory_image.length - build_options.load_offset) DIV build_options.page_size;
      IFEND;

      change_exchange_name_to_addr (page_size_name, address);
      v$page_size_pva := address;

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        search_for_offset (address.segment_offset, segment_descriptor^.pages, rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, rma, valid_position);
        NEXT value IN v$real_memory_image.segment.sequence_pointer;
        value^ := build_options.page_size;
      IFEND;

      change_exchange_name_to_addr (bytes_loaded_address, address);

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        search_for_offset (address.segment_offset, segment_descriptor^.pages, rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, rma, valid_position);
        NEXT half_word IN v$real_memory_image.segment.sequence_pointer;
        half_word^ := (v$real_memory_image.length - build_options.load_offset);
      IFEND;


      IF NOT build_options.building_ei THEN

{ Remove kludge done in allocate_page_table to protect location of PP_ADDRESS_ARRAY pointer.

        v$real_memory_image.page_table^ [1].v := FALSE;
        v$real_memory_image.page_table^ [1].m := FALSE;
      IFEND;


    PROCEND initialize_hcs_root;
?? OLDTITLE ??
?? NEWTITLE := '    RELOCATE_PP_ADDRESS_ARRAY', EJECT ??

    PROCEDURE relocate_pp_address_array
      (    name: oct$exchange_name;
       VAR status: ost$status);


      VAR
        first_words_in_page_table: ^array [1 .. 4] of ost$halfword,
        address: oct$exchange_address,
        segment_descriptor: ^oct$segment_descriptor,
        found: boolean,
        valid_position: boolean,
        spaa: ^array [1 .. 40] of ost$spaa_entry,
        i: integer,
        base_in_words: ost$real_memory_address;


      change_exchange_name_to_addr (name, address);
      v$pp_address_array_pva := address;

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;


        search_for_offset (address.segment_offset, segment_descriptor^.pages, v$pp_address_array_rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;


        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, v$pp_address_array_rma,
              valid_position);
        NEXT spaa IN v$real_memory_image.segment.sequence_pointer;
        IF spaa = NIL THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        base_in_words := segment_descriptor^.pages^.offset DIV 8;

      /loop/
        FOR i := 1 TO UPPERBOUND (spaa^) DO
          IF spaa^ [i].address_type = 0 THEN
            EXIT /loop/;
          ELSEIF spaa^ [i].word_rma <> 0 THEN
            spaa^ [i].word_rma := spaa^ [i].word_rma + base_in_words;
          IFEND;
        FOREND /loop/;


        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
              build_options.page_table_address, valid_position);
        NEXT first_words_in_page_table IN v$real_memory_image.segment.sequence_pointer;
        first_words_in_page_table^ [4] := v$pp_address_array_rma DIV 8;
      IFEND;


    PROCEND relocate_pp_address_array;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_REAL_MEMORY_IMAGE', EJECT ??

    PROCEDURE build_real_memory_image
      (    load_offset: ost$segment_length;
       VAR status: ost$status);


      VAR
        length: ost$segment_length,
        filler: ^SEQ ( * ),
        old: ^SEQ ( * ),
        temp: ^SEQ ( * ),
        new: ^SEQ ( * ),
        header: ^pmt$memory_image_header;


      length := v$real_memory_image.length - load_offset;

      RESET v$real_memory_image.segment.sequence_pointer;

      IF load_offset > 0 THEN
        NEXT filler: [[REP load_offset OF cell]] IN v$real_memory_image.segment.sequence_pointer;
      IFEND;


      PUSH temp: [[REP length OF cell]];
      IF temp = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB99', status);
        RETURN;
      IFEND;

      NEXT old: [[REP length OF cell]] IN v$real_memory_image.segment.sequence_pointer;
      syp$advised_move_bytes (#LOC (old^), #LOC (temp^), length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      RESET v$real_memory_image.segment.sequence_pointer;
      NEXT header IN v$real_memory_image.segment.sequence_pointer;
      IF header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
        RETURN;
      IFEND;

      header^.version := pmc$real_memory_image_version;
      header^.length := length;
      header^.offset := load_offset;


      IF NOT build_options.building_ei THEN
        IF v$job_exchange_info.exchange_address.address_space <> occ$null THEN
          header^.processor_registers.jps := v$job_exchange_info.rma;
        ELSE
          header^.processor_registers.jps := 0;
        IFEND;
        IF v$mtr_exchange_info.exchange_address.address_space <> occ$null THEN
          header^.processor_registers.mps := v$mtr_exchange_info.rma;
        ELSE
          header^.processor_registers.mps := 0;
        IFEND;
        header^.processor_registers.pta := build_options.page_table_address;
        header^.processor_registers.ptl := (build_options.page_table_length DIV 4096) - 1;
        header^.processor_registers.psm := 128 - (build_options.page_size DIV 512);
        header^.processor_registers.eid := 0;
        header^.processor_registers.sit := 70000000(16);
        header^.processor_registers.pid := 0;
        header^.processor_registers.ptm := 0;
        header^.processor_registers.pfs := 0;
        header^.processor_registers.dec := 0;
        header^.processor_registers.vmcl := 8000(16);
        header^.processor_registers.ss := 20(16);
        header^.processor_registers.oi := 0;

        IF v$pp_address_array_pva.address_space <> occ$null THEN
          header^.initialization_values.pp_address_array_segment := v$pp_address_array_pva.segment;
          header^.initialization_values.pp_address_array_offset := v$pp_address_array_pva.segment_offset;
        ELSE
          header^.initialization_values.pages_loaded_segment := 0;
          header^.initialization_values.pages_loaded_offset := 0;
        IFEND;
        IF v$pages_loaded_pva.address_space <> occ$null THEN
          header^.initialization_values.pages_loaded_segment := v$pages_loaded_pva.segment;
          header^.initialization_values.pages_loaded_offset := v$pages_loaded_pva.segment_offset;
        ELSE
          header^.initialization_values.pages_loaded_segment := 0;
          header^.initialization_values.pages_loaded_offset := 0;
        IFEND;
        IF v$page_size_pva.address_space <> occ$null THEN
          header^.initialization_values.page_size_segment := v$page_size_pva.segment;
          header^.initialization_values.page_size_offset := v$page_size_pva.segment_offset;
        ELSE
          header^.initialization_values.page_size_segment := 0;
          header^.initialization_values.page_size_offset := 0;
        IFEND;
      IFEND;

      NEXT new: [[REP length OF cell]] IN v$real_memory_image.segment.sequence_pointer;
      IF new = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
        RETURN;
      IFEND;

      syp$advised_move_bytes (#LOC (temp^), #LOC (new^), length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      amp$set_segment_eoi (v$real_memory_image.id, v$real_memory_image.segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$close (v$real_memory_image.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND build_real_memory_image;
?? OLDTITLE ??
?? EJECT ??

    VAR
      page_number: 0 .. osc$max_page_table_entries,
      local_status: ost$status;


    VAR
      diagnostic_summary: [STATIC] string (49) := '     NON FATAL ERRORS ENCOUNTERED DURING GENERATE';






    setup_rmb_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_build_options (build_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT build_options.building_ei THEN
      allocate_page_table (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pad_page_table (build_options.c170_memory_size, nos_asid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pad_page_table (build_options.ssr_size, ssr_asid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /build_process/
    BEGIN
      process_define_segments (build_options.define_commands, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      build_symbol_table (build_options.monitor_symbol_tables, v$mtr_exchange_info, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      build_symbol_table (build_options.job_symbol_tables, v$job_exchange_info, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      change_exchange_name_to_addr (build_options.job_exchange_address, v$job_exchange_info.exchange_address);
      change_exchange_name_to_addr (build_options.monitor_exchange_address,
            v$mtr_exchange_info.exchange_address);

      process_load_files (build_options.load_files, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      process_segment_commands (build_options.segment_commands, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

{ Calculate Real Memory Image length.

      page_number := build_options.page_table_length DIV 8;

      REPEAT
        page_number := page_number - 1;
      UNTIL v$real_memory_image.page^ [page_number].reserved;

      v$real_memory_image.length := (page_number * build_options.page_size) + build_options.page_size;

      IF NOT build_options.building_ei THEN
        build_page_table (v$job_exchange_info.segment_descriptor_list);
        build_page_table (v$mtr_exchange_info.segment_descriptor_list);

        remove_page_table_pads;
      IFEND;

      IF build_options.pp_address_array_address.address_space <> occ$null THEN
        relocate_pp_address_array (build_options.pp_address_array_address, status);
        IF NOT status.normal THEN
          EXIT /build_process/;
        IFEND;
      IFEND;

      IF build_options.job_exchange_address.address_space <> occ$null THEN
        initialize_exchange_package (v$job_exchange_info, status);
        IF NOT status.normal THEN
          EXIT /build_process/;
        IFEND;
      IFEND;

      IF build_options.monitor_exchange_address.address_space <> occ$null THEN
        initialize_exchange_package (v$mtr_exchange_info, status);
        IF NOT status.normal THEN
          EXIT /build_process/;
        IFEND;
      IFEND;

      initialize_hcs_root (build_options.pages_loaded_address, build_options.page_size_address,
            build_options.bytes_loaded_address, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      process_memory_commands (build_options.memory_commands, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      build_real_memory_image (build_options.load_offset, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

    END /build_process/;

    IF v$diagnostic_count <> 0 THEN
      clp$new_display_line (v$display_control, 2, local_status);
      IF NOT local_status.normal THEN
        issue_diagnostic (local_status);
      IFEND;

      clp$convert_integer_to_rjstring (v$diagnostic_count, 10, FALSE, ' ', diagnostic_summary (1, 4),
            local_status);
      IF NOT local_status.normal THEN
        issue_diagnostic (local_status);
      IFEND;

      clp$put_partial_display (v$display_control, diagnostic_summary, clc$no_trim, amc$start, local_status);
      IF NOT local_status.normal THEN
        issue_diagnostic (local_status);
      IFEND;
    IFEND;


    clp$put_display (v$display_control, '  ', clc$no_trim, local_status);
    IF NOT local_status.normal THEN
      issue_diagnostic (local_status);
    IFEND;

    clp$close_display (v$display_control, local_status);
    IF NOT local_status.normal THEN
      issue_diagnostic (local_status);
    IFEND;

    IF status.normal THEN
      IF v$diagnostic_count = 0 THEN
        osp$set_status_abnormal ('OC', oce$i_generate_status, 'GENERATE completed - NO errors encountered',
              status);
      ELSE
        osp$set_status_abnormal ('OC', oce$w_generate_status,
              'GENERATE completed - NON FATAL errors encountered', status);
      IFEND;
    IFEND;


  PROCEND ocp$generate_real_memory;

MODEND ocm$real_memory_builder;
