?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Virtual Environment Linker' ??
MODULE ocm$virtual_environment_linker;

{ PURPOSE:
{   This module contains the routines for executing the VE Linker.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyc$default_heap_name
*copyc cyd$cybil_structure_definitions
*copyc dst$recovery_name_table
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc loe$map_malfunction
*copyc lot$loader_options
*copyc lot$loader_type_definitions
*copyc lot$task_services_entry_point
*copyc mmc$first_transient_segment
*copyc mmt$attribute_keyword
*copyc occ$initial_segment_number
*copyc occ$retain_all_common_blocks
*copyc occ$symbol_table_version
*copyc oce$library_generator_errors
*copyc oce$ve_linker_exceptions
*copyc oct$known_file_list
*copyc oct$link_parameters
*copyc oct$object_record_list
*copyc oct$output_segment_descriptor
*copyc oct$section_name_list
*copyc oct$segment_attributes
*copyc oct$task_services_entry_point
*copyc pmt$initialization_value
*copyc pmt$linker_debug_table_header
*copyc pmt$virtual_memory_image_header
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$convert_date_time_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_date_time
*copyc clp$convert_string_to_file_ref
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#build_adaptable_array_ptr
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$create_user_segment
*copyc mmp$preset_page_streaming
*copyc ocp$add_to_known_files
*copyc ocp$close_link_map
*copyc ocp$dtb_close_debug_table
*copyc ocp$dtb_define_entry_point
*copyc ocp$dtb_define_module
*copyc ocp$dtb_define_section
*copyc ocp$dtb_get_debug_table
*copyc ocp$dtb_initialize_debug_tables
*copyc ocp$dtb_redefine_module
*copyc ocp$dtb_terminate_module
*copyc ocp$duplicate_segment_number
*copyc ocp$generate_link_map_text
*copyc ocp$initialize_link_map
*copyc ocp$open_output_segment
*copyc ocp$search_modules_to_add
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_page_size
*copyc pmp$get_time
*copyc pmp$get_unique_name
*copyc pmp$position_object_library
*copyc pmp$zero_out_table
*copyc syp$advised_move_bytes
*copyc ocv$next_available_segment
*copyc ocv$predefined_segment_list
*copyc ocv$section_name_list
*copyc ocv$vel_scratch_seq
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    oct$actual_param_group = record
      nnext: ^oct$actual_param_group,
      name: pmt$program_name,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      link: ^oct$actual_param_group,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      list: ^oct$actual_param_list_item,
    recend;

  TYPE
    oct$actual_param_list_item = record
      nnext: ^oct$actual_param_list_item,
      definition: ^llt$actual_parameters,
    recend;

  TYPE
    oct$addresses = packed record
      case (occ$pva, occ$code_based_pointer, occ$mc68000_address, occ$mc68000_short_address) of
      = occ$pva =
        pva: ost$pva,

      = occ$code_based_pointer =
        cbp: oct$code_based_pointer,
        fill: 0 .. 0ffff(16),
        binding_section: ost$pva,

      = occ$mc68000_address =
        mc68000_offset: ost$segment_length,
        mc68000_binding_section: ost$segment_length,

      = occ$mc68000_short_address =
        mc68000_short_offset: 0 .. 0ffff(16),

      casend,
    recend;

  TYPE
    oct$array_pointer = packed record
      ring: ost$ring,
      seg: ost$segment,
      offset: 0 .. 0ffffffff(16),
      array_size: 0 .. 0ffffffff(16),
      lower_bound: 0 .. 0ffffffff(16),
      element_size: 0 .. 0ffffffff(16),
    recend;

  TYPE
    oct$code_based_pointer = packed record
      fill1: 0 .. 0f(16),
      vmid: ost$virtual_machine_identifier, { virtual machine id }
      epf: boolean, { external procedure flag }
      fill2: 0 .. 07(16),
      r3: ost$ring, { highest ring of execution }
      rn: ost$ring, { ring number }
      seg: ost$segment, { segment number }
      bn: ost$segment_offset, { byte number }
    recend;

  TYPE
    oct$common_block_item = record
      section_item: ^oct$section_table_item,
      link: ^oct$common_block_item,
    recend;

  TYPE
    oct$ext_reference_list = record
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      r1: ost$ring,
      r2: ost$ring,
      check_for_ring_violation: boolean,
      items: oct$external_items,
      modules_referencing: ^oct$program_name_list,
      link: ^oct$ext_reference_list,
    recend;

  TYPE
    oct$external_items = record
      kind: llt$address_kind,
      address: ^oct$addresses,
      offset_operand: ost$segment_offset,
      output: ^oct$output_segment_descriptor,
      link: ^oct$external_items,
    recend;

  TYPE
    oct$formal_param_definition = record
      l_link: ^oct$formal_param_definition,
      r_link: ^oct$formal_param_definition,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      defining_module: pmt$program_name,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      definition: ^llt$formal_parameters,
    recend;

  TYPE
    oct$heap_pointer = record
      pva: ost$pva,
      length: 0 .. 0ffffffff(16),
    recend;

  TYPE
    oct$library_entry_points = record
      name: pmt$program_name,
      r1: ost$ring,
      r3: ost$ring,
      object_library: ^oct$object_file_descriptor,
      load_module_header: REL (llt$object_library) ^llt$load_module_header,
      l_link: ^oct$library_entry_points,
      r_link: ^oct$library_entry_points,
    recend;

  TYPE
    oct$list_of_actual_param_group = array [1 .. * ] of oct$actual_param_group;

  TYPE
    oct$list_of_formal_definition = array [1 .. * ] of oct$formal_param_definition;

  TYPE
    oct$module_descriptor_table = record
      name: pmt$program_name,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      ring_of_execution: ost$ring,
      execute_attribute: ost$execute_privilege,
      binding_section_encountered: boolean,
      binding_section: ost$pva,
      default_sections: ^oct$default_sections,
      external_names: oct$program_name_list,
      section_table: oct$section_definition_table,
    recend;

  TYPE
    oct$param_matching_node = record
      nnext: ^oct$param_matching_node,
      name: pmt$program_name,
      definitions: ^oct$formal_param_definition,
      references: ^oct$actual_param_group,
    recend;

  TYPE
    oct$section_attributes = record
      read_default: ost$read_privilege,
      write_default: ost$write_privilege,
      execute_default: ost$execute_privilege,
      read_attribute: ost$read_privilege,
      write_attribute: ost$write_privilege,
      execute_attribute: ost$execute_privilege,
      cache_bypass: boolean,
      extensible: boolean,
    recend;

  TYPE
    oct$section_definition_table = array [0 .. * ] of oct$section_table_item,

    oct$section_table_item = record
      undefined: boolean,
      retained_common_block: boolean,
      deferred_common_block: boolean,
      unallocated_common_block: boolean,
      definition: llt$section_definition,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      section_name: pmt$program_name,
      common_block_name: pmt$program_name,
      pva: ost$pva,
      text: ^array [0 .. * ] of 0 .. 0ff(16),
      output: ^oct$output_segment_descriptor,
    recend;

  CONST
    oc = 'OC',
    occ$num_of_free_program_names = 50,
    occ$number_of_free_actual_param = 50,
    occ$number_of_free_entry_points = 50,
    occ$number_of_free_externals = 50,
    occ$number_of_free_formal_param = 50,
    occ$free_ext_item_increment = 25,
    occ$free_ext_name_increment = 25;

  VAR
    v$lm_asis_text: lot$load_map_data,
    v$lm_diagnostic_summary: lot$load_map_data,
    v$lm_entry_detail: lot$load_map_data,
    v$lm_issue_diagnostic: lot$load_map_data,
    v$lm_module_detail_1: lot$load_map_data,
    v$lm_module_detail_2: lot$load_map_data,
    v$lm_page_header: lot$load_map_data,
    v$lm_section_detail: lot$load_map_data,
    v$lm_segment_detail: lot$load_map_data,
    v$lm_transfer_detail: lot$load_map_data;

  VAR
    v$actual_param_groups: oct$actual_param_group,
    v$address_formulation_records: oct$object_record_list,
    v$binding_r1: ost$ring,
    v$binding_r2: ost$ring,
    v$common_block_table: oct$common_block_item,
    v$current_segment_number: integer,
    v$entry_points: oct$entry_points,
    v$formal_param_definitions: oct$formal_param_definition,
    v$free_actual_parameters: ^oct$list_of_actual_param_group,
    v$free_entry_points: ^oct$list_of_entry_points,
    v$free_external_items: ^oct$external_items,
    v$free_external_names: ^oct$program_name_list,
    v$free_external_references: ^oct$ext_reference_list,
    v$free_formal_parameters: ^oct$list_of_formal_definition,
    v$free_program_names: ^oct$program_name_list,
    v$generate_debug_tables: boolean,
    v$generate_status: ost$status,
    v$last_address_formulation: ^oct$object_record_list,
    v$last_entry_point: ^oct$entry_points,
    v$last_starting_procedure: pmt$program_name,
    v$library_list: oct$known_file_list,
    v$maximum_segment_number: integer,
    v$mdt: ^oct$module_descriptor_table,
    v$minimum_segment_number: integer,
    v$module_kind: llt$module_kind,
    v$modules_to_add: oct$program_name_list,
    v$next_free_actual_parameter: 1 .. occ$number_of_free_actual_param + 1,
    v$next_free_entry_point: 1 .. occ$number_of_free_entry_points + 1,
    v$next_free_formal_parameter: 1 .. occ$number_of_free_formal_param + 1,
    v$next_retained_cmnblk_seg_num: integer,
    v$number_of_libraries: integer,
    v$object_type_checking: [STATIC, READ] string (6) := 'OBJECT',
    v$outboard_symbol_table: ^oct$list_of_entry_points,
    v$output_segment_list: oct$output_segment_descriptor,
    v$page_size: integer,
    v$record_number: integer,
    v$retained_common_block_segment: amt$segment_pointer,
    v$section_name_list: oct$section_name_list,
    v$source_type_checking: [STATIC] boolean := TRUE,
    v$starting_entry_point: ^oct$entry_points,
    v$starting_procedure: pmt$program_name,
    v$symbol_table_id: ost$name,
    v$unsatisfied_actual_param: oct$actual_param_group,
    v$unsatisfied_externals: oct$ext_reference_list,
    v$vmid: [STATIC] ost$virtual_machine_identifier := osc$cyber_180_mode;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$execute_the_ve_linker', EJECT ??

  PROCEDURE [XDCL] ocp$execute_the_ve_linker
    (    link_parameters: oct$link_parameters;
     VAR status: ost$status);

?? NEWTITLE := 'link_map_malfunction', EJECT ??

    PROCEDURE link_map_malfunction
      (    condition: pmt$condition;
           error_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR local_status: ost$status);


      VAR
        malfunction: ^ost$status;


      malfunction := error_status;
      status := malfunction^;

      EXIT ocp$execute_the_ve_linker;


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

    PROCEDURE issue_diagnostic
      (    severity: ost$status_severity;
       VAR status: ost$status);


      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        v$lm_issue_diagnostic.diagnostic_status := status;

        space (1);
        ocp$generate_link_map_text (v$lm_issue_diagnostic);

        v$lm_diagnostic_summary.diagnostic_count [severity] :=
              v$lm_diagnostic_summary.diagnostic_count [severity] + 1;
      IFEND;

      IF severity < osc$fatal_status THEN
        status.normal := TRUE;
        osp$set_status_abnormal (oc, oce$w_generate_status,
              'GENERATE completed - NON FATAL errors encountered', v$generate_status);
      ELSE
        osp$set_status_abnormal (oc, oce$e_generate_status,
              'GENERATE not completed - FATAL error encountered', v$generate_status);
      IFEND;


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

    PROCEDURE build_adaptable_array_pointer
      (    ring: 0 .. 0f(16);
           seg: 0 .. 0fff(16);
           offset: 0 .. 80000000(16);
           array_size: 0 .. 0ffffffff(16);
           lower_bound: 0 .. 0ffffffff(16);
           element_size: 0 .. 0ffffffff(16);
           array_pointer: ^oct$array_pointer);


      array_pointer^.ring := ring;
      array_pointer^.seg := seg;
      array_pointer^.offset := offset;
      array_pointer^.array_size := array_size;
      array_pointer^.lower_bound := lower_bound;
      array_pointer^.element_size := element_size;


    PROCEND build_adaptable_array_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'build_adaptable_sequence_pointer', EJECT ??

    PROCEDURE build_adaptable_seq_pointer
      (    ring: 0 .. 0f(16);
           seg: 0 .. 0fff(16);
           offset: 0 .. 80000000(16);
           size: 0 .. 0ffffffff(16);
           sequence_pointer: ^cell);

      VAR
        pointer: ^packed record
          ring: 0 .. 0f(16),
          seg: 0 .. 0fff(16),
          offset: 0 .. 0ffffffff(16),
          limit: 0 .. 0ffffffff(16),
          avail: 0 .. 0ffffffff(16),
        recend;

      pointer := sequence_pointer;
      pointer^.ring := ring;
      pointer^.seg := seg;
      pointer^.offset := offset;
      pointer^.limit := size;
      pointer^.avail := 0;


    PROCEND build_adaptable_seq_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'output', EJECT ??

    PROCEDURE output
      (    filler: string ( * );
           strng: string ( * );
           size: 0 .. 256;
           flush_the_output_buffer: boolean);


      v$output_buffer (v$output_pos, * ) := filler;
      v$output_pos := v$output_pos + STRLENGTH (filler);
      v$output_buffer (v$output_pos, * ) := strng (1, size);
      v$output_pos := v$output_pos + size;

      IF flush_the_output_buffer THEN
        v$lm_asis_text.text := v$output_buffer (1, (v$output_pos - 1));
        ocp$generate_link_map_text (v$lm_asis_text);

        v$output_pos := 1;
      IFEND;


    PROCEND output;
?? OLDTITLE ??
?? NEWTITLE := 'space', EJECT ??

    PROCEDURE space
      (    number_of_lines: integer);


      VAR
        i: integer;


      v$lm_asis_text.text := '  ';

      FOR i := 1 TO number_of_lines DO
        ocp$generate_link_map_text (v$lm_asis_text);
      FOREND;


    PROCEND space;
?? OLDTITLE ??
?? NEWTITLE := 'convert_hex_pva_to_ascii', EJECT ??

    PROCEDURE convert_hex_pva_to_ascii
      (    pva: ost$pva;
       VAR strng: string ( * ));


      VAR
        dummy: ost$status;


      strng := '0 000 00000000';

      clp$convert_integer_to_rjstring (pva.ring, 16, FALSE, ' ', strng (1, 1), dummy);
      clp$convert_integer_to_rjstring (pva.seg, 16, FALSE, ' ', strng (3, 3), dummy);
      clp$convert_integer_to_rjstring (pva.offset, 16, FALSE, ' ', strng (7, 8), dummy);


    PROCEND convert_hex_pva_to_ascii;
?? OLDTITLE ??
?? NEWTITLE := 'convert_segment_access_control', EJECT ??

    PROCEDURE convert_segment_access_control
      (    attributes: oct$segment_attributes;
       VAR access_control: ost$segment_access_control);


      access_control.cache_bypass := (occ$sa_cache_bypass IN attributes);

      IF occ$sa_non_privileged IN attributes THEN
        access_control.execute_privilege := osc$non_privileged;
      ELSEIF occ$sa_local_privilege IN attributes THEN
        access_control.execute_privilege := osc$local_privilege;
      ELSEIF occ$sa_global_privilege IN attributes THEN
        access_control.execute_privilege := osc$global_privilege;
      ELSE
        access_control.execute_privilege := osc$non_executable;
      IFEND;

      IF occ$sa_read IN attributes THEN
        access_control.read_privilege := osc$read_uncontrolled;
      ELSEIF occ$sa_read_kl IN attributes THEN
        access_control.read_privilege := osc$read_key_lock_controlled;
      ELSEIF occ$sa_binding IN attributes THEN
        access_control.read_privilege := osc$binding_segment;
      ELSE
        access_control.read_privilege := osc$non_readable;
      IFEND;

      IF occ$sa_write IN attributes THEN
        access_control.write_privilege := osc$write_uncontrolled;
      ELSEIF occ$sa_write_kl IN attributes THEN
        access_control.write_privilege := osc$write_key_lock_controlled;
      ELSE
        access_control.write_privilege := osc$non_writable;
      IFEND;


    PROCEND convert_segment_access_control;
?? OLDTITLE ??
?? NEWTITLE := 'convert_key_lock', EJECT ??

    PROCEDURE convert_key_lock
      (    global_key: ost$key_lock_value;
           local_key: ost$key_lock_value;
       VAR key_lock: ost$key_lock);


      key_lock.value := 0;

      IF global_key <> 0 THEN
        key_lock.global := TRUE;
        key_lock.value := global_key;
      ELSE
        key_lock.global := FALSE;
      IFEND;

      IF local_key <> 0 THEN
        key_lock.local := TRUE;
        key_lock.value := local_key;
      ELSE
        key_lock.local := FALSE;
      IFEND;


    PROCEND convert_key_lock;
?? OLDTITLE ??
?? NEWTITLE := 'get_binding_rings_1_and_2', EJECT ??

    PROCEDURE get_binding_rings_1_and_2
      (VAR r1: ost$ring;
       VAR r2: ost$ring);




      VAR
        file_descriptor: ^oct$object_file_descriptor;


      r1 := osc$max_ring;
      r2 := osc$invalid_ring;

      file_descriptor := link_parameters.object_files_to_add.link;

      WHILE file_descriptor <> NIL DO
        IF file_descriptor^.r1 < r1 THEN
          r1 := file_descriptor^.r1;
        IFEND;

        IF file_descriptor^.r2 > r2 THEN
          r2 := file_descriptor^.r2;
        IFEND;

        file_descriptor := file_descriptor^.link;
      WHILEND;

      file_descriptor := link_parameters.object_libraries_to_use.link;

      WHILE file_descriptor <> NIL DO
        IF file_descriptor^.r1 < r1 THEN
          r1 := file_descriptor^.r1;
        IFEND;

        IF file_descriptor^.r2 > r2 THEN
          r2 := file_descriptor^.r2;
        IFEND;

        file_descriptor := file_descriptor^.link;
      WHILEND;


    PROCEND get_binding_rings_1_and_2;
?? OLDTITLE ??
?? NEWTITLE := 'get_modules_to_add', EJECT ??

    PROCEDURE get_modules_to_add
      (VAR modules_to_add: oct$program_name_list;
       VAR status: ost$status);


      VAR
        old_module: ^oct$program_name_list,
        new_module: ^oct$program_name_list;


      old_module := link_parameters.modules_to_add.link;
      new_module := ^modules_to_add;

      WHILE old_module <> NIL DO
        NEXT new_module^.link IN ocv$vel_scratch_seq;
        new_module := new_module^.link;
        IF new_module = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL1', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        new_module^.name := old_module^.name;
        old_module := old_module^.link;

      WHILEND;

      new_module^.link := NIL;


    PROCEND get_modules_to_add;
?? OLDTITLE ??
?? NEWTITLE := 'add_externals_to_satisfy', EJECT ??

    PROCEDURE add_externals_to_satisfy
      (VAR unsatisfied_externals: oct$ext_reference_list;
       VAR status: ost$status);

?? NEWTITLE := 'add_external', EJECT ??

      PROCEDURE add_external
        (    name: pmt$program_name;
         VAR status: ost$status);


        VAR
          defaults: [STATIC] oct$ext_reference_list := [ * , * , FALSE, * , osc$invalid_ring, osc$max_ring,
                FALSE, [ * , * , * , NIL, NIL], NIL, * ],
          external: ^oct$ext_reference_list;


        get_next_free_external (external, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        external^ := defaults;
        external^.name := name;
        external^.link := unsatisfied_externals.link;
        unsatisfied_externals.link := external;


      PROCEND add_external;
?? OLDTITLE ??
?? EJECT ??


      VAR
        current_message_module: ^oct$message_module_list,
        variable: ^oct$program_name_list,
        pointer: ^oct$pointer_list;


      IF v$starting_procedure <> osc$null_name THEN
        add_external (v$starting_procedure, status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      pointer := link_parameters.heap_pointers.link;

      WHILE pointer <> NIL DO
        add_external (pointer^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pointer := pointer^.link;
      WHILEND;

      pointer := link_parameters.debug_table_pointers.link;

      WHILE pointer <> NIL DO
        add_external (pointer^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pointer := pointer^.link;
      WHILEND;

      IF link_parameters.symbol_table_id_variable <> osc$null_name THEN
        add_external (link_parameters.symbol_table_id_variable, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF link_parameters.exchange_package_variable <> osc$null_name THEN
        add_external (link_parameters.exchange_package_variable, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      variable := link_parameters.build_level_variables.link;

      WHILE variable <> NIL DO
        add_external (variable^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        variable := variable^.link;
      WHILEND;

      current_message_module := link_parameters.message_module_list;

      WHILE pointer <> NIL DO
        add_external (current_message_module^.pointer_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        current_message_module := current_message_module^.link;
      WHILEND;


    PROCEND add_externals_to_satisfy;

?? OLDTITLE ??
?? NEWTITLE := 'get_segment_number', EJECT ??

    PROCEDURE get_segment_number
      (    retained_common_block: boolean;
           segment_number_predefined: boolean;
       VAR segment_number: oct$segment;
       VAR status: ost$status);


      IF retained_common_block THEN
        IF v$next_retained_cmnblk_seg_num > UPPERVALUE (ost$segment) THEN
          osp$set_status_condition (oce$e_segment_number_overflow, status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
        segment_number := v$next_retained_cmnblk_seg_num;
        v$next_retained_cmnblk_seg_num := v$next_retained_cmnblk_seg_num + 1;
        RETURN; { ---->
      IFEND;

      IF NOT segment_number_predefined THEN
        segment_number := occ$null_seg_value;

        WHILE segment_number = occ$null_seg_value DO
          IF v$current_segment_number > v$maximum_segment_number THEN
            osp$set_status_condition (oce$e_segment_number_overflow, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          IF NOT ocp$duplicate_segment_number (v$current_segment_number) THEN
            segment_number := v$current_segment_number;
          IFEND;

          v$current_segment_number := v$current_segment_number + 1;
        WHILEND;
      IFEND;

      IF (segment_number < v$minimum_segment_number) THEN
        osp$set_status_condition (oce$e_segment_number_underflow, status);
        issue_diagnostic (osc$fatal_status, status);
      ELSEIF (segment_number > v$maximum_segment_number) THEN
        osp$set_status_condition (oce$e_segment_number_overflow, status);
        issue_diagnostic (osc$fatal_status, status);
      IFEND;


    PROCEND get_segment_number;
?? OLDTITLE ??
?? NEWTITLE := 'open_temporary_segment', EJECT ??

    PROCEDURE open_temporary_segment
      (    section_item: oct$section_table_item;
           preset_value: pmt$initialization_value;
       VAR temporary: ^oct$output_segment_descriptor;
       VAR status: ost$status);

      VAR
        segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;

      status.normal := TRUE;
      get_segment_number (temporary^.retained_common_block, temporary^.number_predefined, temporary^.number,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (section_item.retained_common_block) AND (section_item.definition.kind <>
            llc$extensible_common_block) THEN
        temporary^.segment.kind := amc$sequence_pointer;
        IF (section_item.definition.length = 0) THEN

{ It just doesn't matter where, but we need a valid pointer.

          NEXT temporary^.segment.sequence_pointer: [[REP 1 OF cell]] IN ocv$vel_scratch_seq;
        ELSE

{ Add the allocation alignment size to allow for the text to be aligned when it is copied into the area.

          NEXT temporary^.segment.sequence_pointer: [[REP (section_item.definition.length +
                section_item.definition.allocation_alignment) OF cell]] IN
                v$retained_common_block_segment.sequence_pointer;
        IFEND;

        IF (temporary^.segment.sequence_pointer = NIL) THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL_OTS', status);
        IFEND;

      ELSE
        PUSH segment_attributes_p: [1 .. 1];
        segment_attributes_p^ [1].keyword := mmc$ua_preset_value;
        segment_attributes_p^ [1].preset_value := preset_value;
        mmp$create_user_segment (segment_attributes_p, amc$sequence_pointer, mmc$as_sequential,
              temporary^.segment, status);
        RESET temporary^.segment.sequence_pointer;
      IFEND;

      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      temporary^.sections_allocated.link := NIL;


    PROCEND open_temporary_segment;
?? OLDTITLE ??
?? NEWTITLE := 'validate_section', EJECT ??

    PROCEDURE validate_section
      (    section_ordinal: llt$section_ordinal;
           offset: ost$segment_offset;
       VAR status: ost$status);


      IF section_ordinal > UPPERBOUND (v$mdt^.section_table) THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid section ordinal encountered',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF v$mdt^.section_table [section_ordinal].undefined THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Undefined section ordinal encountered',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF offset > v$mdt^.section_table [section_ordinal].definition.length THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'Reference outside of section encountered', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;


    PROCEND validate_section;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_destination_address', EJECT ??

    PROCEDURE obtain_destination_address
      (    mdt: ^oct$module_descriptor_table;
           address_kind: llt$address_kind;
           dest_section: llt$section_ordinal;
           dest_offset: ost$segment_offset;
       VAR address_pointer: ^oct$addresses;
       VAR status: ost$status);


      VAR
        alignment_cy180: [STATIC] array [llt$address_kind] of 0 .. 7 := [2, 0, 0, 0, 2, 2],
        alignment_mc68000: [STATIC] array [llt$address_kind] of 0 .. 7 := [0, 0, 0, 0, 0, 0],
        address_size_cy180: [STATIC] array [llt$address_kind] of 0 .. 16 := [6, 8, 8, 16, 6, 6],
        address_size_mc68000: [STATIC] array [llt$address_kind] of 0 .. 16 := [4, 2, 2, 8, 4, 4];

      CASE link_parameters.mode OF
      = occ$template, occ$product =
        IF (dest_offset + address_size_cy180 [address_kind]) > mdt^.section_table [dest_section].
              definition.length THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Referencing outside of section',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        IF NOT mdt^.section_table [dest_section].output^.inhibit_binding_check THEN
          IF (address_kind = llc$internal_proc) OR (address_kind = llc$short_address) OR
                (address_kind = llc$external_proc) THEN
            IF mdt^.section_table [dest_section].definition.kind <> llc$binding_section THEN
              osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'Code base pointer not in binding section', status);
              issue_diagnostic (osc$fatal_status, status);
              RETURN;
            IFEND;
          IFEND;

          IF occ$sa_binding IN mdt^.section_table [dest_section].output^.used_attributes THEN
            IF ((mdt^.section_table [dest_section].pva.offset + dest_offset) MOD 8) <>
                  alignment_cy180 [address_kind] THEN
              osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid pointer alignment_cy180',
                    status);
              issue_diagnostic (osc$fatal_status, status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        address_pointer := #LOC (mdt^.section_table [dest_section].text^ [dest_offset]);

      = occ$mc68000 =
        IF (dest_offset + address_size_mc68000 [address_kind]) > mdt^.section_table [dest_section].
              definition.length THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Referencing outside of section',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        IF occ$sa_binding IN mdt^.section_table [dest_section].output^.used_attributes THEN
          IF ((mdt^.section_table [dest_section].pva.offset + dest_offset) MOD 2) <>
                alignment_mc68000 [address_kind] THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid pointer alignment_mc68000',
                  status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;
        IFEND;

        address_pointer := #LOC (mdt^.section_table [dest_section].text^ [dest_offset]);
      CASEND;


    PROCEND obtain_destination_address;
?? OLDTITLE ??
?? NEWTITLE := 'rings_overlap', EJECT ??

    FUNCTION rings_overlap
      (    x_lower: ost$ring;
           x_upper: ost$ring;
           y_lower: ost$ring;
           y_upper: ost$ring): boolean;

      rings_overlap := ((x_lower <= y_upper) AND (x_upper >= y_lower));

    FUNCEND rings_overlap;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_program_name', EJECT ??

    PROCEDURE get_next_free_program_name
      (VAR program_name: ^oct$program_name_list;
       VAR status: ost$status);


      VAR
        free_program_names: ^array [1 .. occ$num_of_free_program_names] of oct$program_name_list,
        i: 1 .. occ$num_of_free_program_names;


      IF v$free_program_names = NIL THEN
        NEXT free_program_names IN ocv$vel_scratch_seq;
        IF free_program_names = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL29292', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$free_program_names := ^free_program_names^ [1];

        FOR i := 1 TO (occ$num_of_free_program_names - 1) DO
          free_program_names^ [i].link := ^free_program_names^ [i + 1];
        FOREND;

        free_program_names^ [occ$num_of_free_program_names].link := NIL;
      IFEND;

      program_name := v$free_program_names;
      v$free_program_names := v$free_program_names^.link;


    PROCEND get_next_free_program_name;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_entry_point', EJECT ??

    PROCEDURE get_next_free_entry_point
      (VAR entry_point: ^oct$entry_points;
       VAR status: ost$status);


      IF v$next_free_entry_point > occ$number_of_free_entry_points THEN
        NEXT v$free_entry_points: [1 .. occ$number_of_free_entry_points] IN ocv$vel_scratch_seq;
        IF v$free_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL2', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$next_free_entry_point := 1;
      IFEND;

      entry_point := ^v$free_entry_points^ [v$next_free_entry_point];
      v$next_free_entry_point := v$next_free_entry_point + 1;


    PROCEND get_next_free_entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'is_entry_point_deferred', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if an entry point is to be deferred.
{ DESIGN:
{   If all entry points are to be deferred or if non retained entry points are to be
{   deferred and the entry point is not retained the entry point is to be deferred.
{   Otherwise the list of names specified will be searched.  If the list of names
{   represents those not to be deferred and the entry point is not in it or if the
{   list of names represents those to be deferred and the entry point is in it the
{   entry point will be deferred.

    PROCEDURE is_entry_point_deferred
      (    retained: boolean;
           name: pmt$program_name;
       VAR deferred: boolean);

      VAR
        entry_point: ^oct$defer_list;


      deferred := FALSE;

      IF link_parameters.defer_entry_points <> NIL THEN
        IF link_parameters.defer_entry_points^.defer = occ$defer_all THEN
          deferred := TRUE;

        ELSEIF link_parameters.defer_entry_points^.defer = occ$defer_non_retained THEN
          deferred := NOT retained;

        ELSEIF link_parameters.defer_entry_points^.defer = occ$defer THEN
          entry_point := link_parameters.defer_entry_points^.name_list;
          WHILE entry_point <> NIL DO
            IF entry_point^.name = name THEN
              deferred := TRUE;
              entry_point^.name_found := TRUE;
              RETURN;
            IFEND;
            entry_point := entry_point^.link;
          WHILEND;

        ELSEIF link_parameters.defer_entry_points^.defer = occ$defer_all_except THEN
          entry_point := link_parameters.defer_entry_points^.name_list;
          WHILE entry_point <> NIL DO
            IF entry_point^.name = name THEN
              entry_point^.name_found := TRUE;
              RETURN;
            IFEND;
            entry_point := entry_point^.link;
          WHILEND;
          deferred := TRUE;

        IFEND;
      IFEND;


    PROCEND is_entry_point_deferred;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_entry_point', EJECT ??

    PROCEDURE initialize_entry_point
      (    entry_definition: ^llt$entry_definition;
       VAR entry_point: ^oct$entry_points);

      entry_point^.name := entry_definition^.name;
      entry_point^.ring_violation := FALSE;
      entry_point^.inboard_symbol := FALSE;
      is_entry_point_deferred ((llc$retain_entry_point IN entry_definition^.attributes), entry_point^.name,
            entry_point^.deferred);
      entry_point^.gated := (llc$gated_entry_point IN entry_definition^.attributes);
      entry_point^.attributes := entry_definition^.attributes;
      entry_point^.language := entry_definition^.language;
      entry_point^.declaration_matching_required := entry_definition^.declaration_matching_required;
      entry_point^.declaration_matching := entry_definition^.declaration_matching;

      entry_point^.pva.ring := v$mdt^.ring_of_execution;
      entry_point^.pva.seg := v$mdt^.section_table [entry_definition^.section_ordinal].pva.seg;
      entry_point^.pva.offset := v$mdt^.section_table [entry_definition^.section_ordinal].pva.offset +
            entry_definition^.offset;
      entry_point^.binding_section := v$mdt^.binding_section;

      entry_point^.r1 := v$mdt^.r1;
      entry_point^.r2 := v$mdt^.r2;

      IF entry_point^.gated THEN
        entry_point^.r3 := v$mdt^.r3;
      ELSE
        entry_point^.r3 := v$mdt^.r2;
      IFEND;

      IF entry_point^.name = 'SYP$SYSTEM_CORE_TRAP_HANDLER' THEN { JFS - Kludge }
        entry_point^.r3 := 0d(16);
      IFEND;

      entry_point^.global_key := v$mdt^.global_key;
      entry_point^.local_key := v$mdt^.local_key;

      entry_point^.l_link := NIL;
      entry_point^.r_link := NIL;
      entry_point^.link := NIL;


    PROCEND initialize_entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'search_entry_point_tree', EJECT ??

    PROCEDURE search_entry_point_tree
      (    name: pmt$program_name;
           r1: ost$ring;
           r2: ost$ring;
       VAR entry_point: ^oct$entry_points);


      entry_point := ^v$entry_points;

      WHILE entry_point <> NIL DO
        IF (name = entry_point^.name) AND (rings_overlap (r1, r2, entry_point^.r1, entry_point^.r3)) THEN
          RETURN;

        ELSEIF name < entry_point^.name THEN
          entry_point := entry_point^.l_link;
        ELSE
          entry_point := entry_point^.r_link;
        IFEND;

      WHILEND;


    PROCEND search_entry_point_tree;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_entry_points', EJECT ??

    PROCEDURE add_to_entry_points
      (    entry_point: ^oct$entry_points);


      VAR
        ept: ^oct$entry_points;


      v$last_entry_point^.link := entry_point;
      v$last_entry_point := v$last_entry_point^.link;

      ept := ^v$entry_points;

      WHILE TRUE DO

        IF entry_point^.name < ept^.name THEN
          IF ept^.l_link = NIL THEN
            ept^.l_link := entry_point;
            RETURN;
          ELSE
            ept := ept^.l_link;
          IFEND;

        ELSE
          IF ept^.r_link = NIL THEN
            ept^.r_link := entry_point;
            RETURN;
          ELSE
            ept := ept^.r_link;
          IFEND;
        IFEND;

      WHILEND;


    PROCEND add_to_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_external', EJECT ??

    PROCEDURE get_next_free_external
      (VAR external: ^oct$ext_reference_list;
       VAR status: ost$status);


      VAR
        free_externals: ^array [1 .. occ$number_of_free_externals] of oct$ext_reference_list,
        i: 1 .. occ$number_of_free_externals;


      IF v$free_external_references = NIL THEN
        NEXT free_externals IN ocv$vel_scratch_seq;
        IF free_externals = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL3', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$free_external_references := ^free_externals^ [1];

        FOR i := 1 TO (occ$number_of_free_externals - 1) DO
          free_externals^ [i].link := ^free_externals^ [i + 1];
        FOREND;

        free_externals^ [occ$number_of_free_externals].link := NIL;
      IFEND;

      external := v$free_external_references;
      v$free_external_references := v$free_external_references^.link;


    PROCEND get_next_free_external;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_external_item', EJECT ??

    PROCEDURE get_next_free_external_item
      (VAR item: ^oct$external_items;
       VAR status: ost$status);


      VAR
        item_array: ^array [1 .. occ$free_ext_item_increment] of oct$external_items,
        i: 1 .. occ$free_ext_item_increment;


      IF v$free_external_items = NIL THEN
        NEXT item_array IN ocv$vel_scratch_seq;
        IF item_array = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL4', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$free_external_items := ^item_array^ [1];

        FOR i := 1 TO (occ$free_ext_item_increment - 1) DO
          item_array^ [i].link := ^item_array^ [i + 1];
        FOREND;

        item_array^ [occ$free_ext_item_increment].link := NIL;
      IFEND;

      item := v$free_external_items;
      v$free_external_items := v$free_external_items^.link;


    PROCEND get_next_free_external_item;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_external_items', EJECT ??

    PROCEDURE add_to_external_items
      (    external_linkage_item: array [1 .. * ] of llt$external_linkage_item;
           external: ^oct$ext_reference_list;
           mod_name: pmt$program_name;
       VAR status: ost$status);


      VAR
        module_name: ^oct$program_name_list,
        i: integer,
        item: ^oct$external_items,
        address: ^oct$addresses;


      get_next_free_program_name (module_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      module_name^.name := mod_name;
      module_name^.link := external^.modules_referencing;
      external^.modules_referencing := module_name;

      FOR i := 1 TO UPPERBOUND (external_linkage_item) DO
        validate_section (external_linkage_item [i].section_ordinal, 0, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF external_linkage_item [i].kind > UPPERVALUE (llt$address_kind) THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid address kind encountered',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        obtain_destination_address (v$mdt, external_linkage_item [i].kind,
              external_linkage_item [i].section_ordinal, external_linkage_item [i].offset, address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        get_next_free_external_item (item, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        item^.kind := external_linkage_item [i].kind;
        item^.address := address;
        item^.offset_operand := external_linkage_item [i].offset_operand;
        item^.output := v$mdt^.section_table [external_linkage_item [i].section_ordinal].output;
        item^.link := external^.items.link;
        external^.items.link := item;
      FOREND;


    PROCEND add_to_external_items;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_external_reference', EJECT ??

    PROCEDURE initialize_external_reference
      (    external_linkage: ^llt$external_linkage;
       VAR external: ^oct$ext_reference_list);

      external^.name := external_linkage^.name;
      external^.language := external_linkage^.language;
      external^.declaration_matching_required := external_linkage^.declaration_matching_required;
      external^.declaration_matching := external_linkage^.declaration_matching;

      external^.r1 := v$mdt^.r1;
      external^.r2 := v$mdt^.r2;

      external^.items.link := NIL;
      external^.check_for_ring_violation := TRUE;
      external^.modules_referencing := NIL;

      external^.link := NIL;


    PROCEND initialize_external_reference;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_external_names', EJECT ??

    PROCEDURE add_to_external_names
      (    name: pmt$program_name;
       VAR status: ost$status);


      VAR
        external: ^oct$program_name_list,
        free_names: ^array [1 .. occ$free_ext_name_increment] of oct$program_name_list,
        i: integer;


      external := ^v$mdt^.external_names;

      WHILE (external^.link <> NIL) AND (external^.link^.name <> name) DO
        external := external^.link;
      WHILEND;

      IF external^.link = NIL THEN
        IF v$free_external_names = NIL THEN
          NEXT free_names IN ocv$vel_scratch_seq;
          IF free_names = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL5', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          v$free_external_names := ^free_names^ [1];
          FOR i := 1 TO (occ$free_ext_name_increment - 1) DO
            free_names^ [i].link := ^free_names^ [i + 1];
          FOREND;
          free_names^ [occ$free_ext_name_increment].link := NIL;
        IFEND;

        external^.link := v$free_external_names;
        v$free_external_names := v$free_external_names^.link;

        external := external^.link;
        external^.name := name;
        external^.link := NIL;
      IFEND;


    PROCEND add_to_external_names;
?? OLDTITLE ??
?? NEWTITLE := 'print_external_names', EJECT ??

    PROCEDURE print_external_names
      (VAR external_names: oct$program_name_list);


      VAR
        external: ^oct$program_name_list,
        flush_it: boolean;


      IF external_names.link <> NIL THEN
        space (2);
        output ('', '   EXTERNAL ENTRY POINTS REFERENCED', 35, flush);
        output ('', '   -----------------------------------------------------------------', 68, flush);
        flush_it := FALSE;

        REPEAT
          external := external_names.link;
          external_names.link := external_names.link^.link;
          external^.link := v$free_external_names;
          v$free_external_names := external;

          output ('   ', external^.name, STRLENGTH (external^.name), flush_it);
          flush_it := NOT flush_it;

        UNTIL external_names.link = NIL;

        IF flush_it THEN
          output (' ', ' ', 1, flush);
        IFEND;
      IFEND;


    PROCEND print_external_names;
?? OLDTITLE ??
?? NEWTITLE := 'add_adr_to_products_adr_list', EJECT ??

    PROCEDURE add_adr_to_products_adr_list
      (    adr: ^llt$address_formulation;
       VAR status: ost$status);


      VAR
        i: integer,
        dest_relocation: ost$segment_length,
        value_relocation: ost$segment_length;


      NEXT v$last_address_formulation^.link IN ocv$vel_scratch_seq;
      v$last_address_formulation := v$last_address_formulation^.link;
      IF v$last_address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT v$last_address_formulation^.address_formulation: [1 .. UPPERBOUND (adr^.item)] IN
            ocv$vel_scratch_seq;
      IF v$last_address_formulation^.address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$last_address_formulation^.link := NIL;
      v$last_address_formulation^.address_formulation^ := adr^;
      v$last_address_formulation^.address_formulation^.dest_section := v$mdt^.
            section_table [adr^.dest_section].pva.seg;
      v$last_address_formulation^.address_formulation^.value_section := v$mdt^.
            section_table [adr^.value_section].pva.seg;

      dest_relocation := #OFFSET (v$mdt^.section_table [adr^.dest_section].text);
      IF v$mdt^.section_table [adr^.value_section].text <> NIL THEN
        value_relocation := #OFFSET (v$mdt^.section_table [adr^.value_section].text);
      ELSE
        value_relocation := 0;
      IFEND;

      FOR i := 1 TO UPPERBOUND (v$last_address_formulation^.address_formulation^.item) DO
        v$last_address_formulation^.address_formulation^.item [i].dest_offset :=
              v$last_address_formulation^.address_formulation^.item [i].dest_offset + dest_relocation;
        v$last_address_formulation^.address_formulation^.item [i].value_offset :=
              v$last_address_formulation^.address_formulation^.item [i].value_offset + value_relocation;
      FOREND;


    PROCEND add_adr_to_products_adr_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_item_to_products_adr_list', EJECT ??

    PROCEDURE add_item_to_products_adr_list
      (    dest_segment: ost$segment;
           dest_offset: ost$segment_offset;
           kind: llt$address_kind;
           value_segment: ost$segment;
           value_offset: ost$segment_offset;
       VAR status: ost$status);


      NEXT v$last_address_formulation^.link IN ocv$vel_scratch_seq;
      v$last_address_formulation := v$last_address_formulation^.link;
      IF v$last_address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT v$last_address_formulation^.address_formulation: [1 .. 1] IN ocv$vel_scratch_seq;
      IF v$last_address_formulation^.address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$last_address_formulation^.link := NIL;
      v$last_address_formulation^.address_formulation^.dest_section := dest_segment;
      v$last_address_formulation^.address_formulation^.value_section := value_segment;
      v$last_address_formulation^.address_formulation^.item [1].kind := kind;
      v$last_address_formulation^.address_formulation^.item [1].dest_offset := dest_offset;
      v$last_address_formulation^.address_formulation^.item [1].value_offset := value_offset;


    PROCEND add_item_to_products_adr_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_segments_rel_list', EJECT ??

    PROCEDURE add_to_segments_rel_list
      (    address: ^oct$addresses;
       VAR segments_rel_list: oct$segment_relocation_list;
       VAR status: ost$status);

      VAR
        relocation_value: ^oct$segment_relocation_list;


      NEXT relocation_value IN ocv$vel_scratch_seq;
      IF relocation_value = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL1112', status);
        RETURN;
      IFEND;

      relocation_value^.pva := #ADDRESS (#RING (address), #SEGMENT (address), (#OFFSET (address) + 0));
      relocation_value^.link := segments_rel_list.link;
      segments_rel_list.link := relocation_value;


    PROCEND add_to_segments_rel_list;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] update_number_of_bytes_written', EJECT ??

    PROCEDURE [INLINE] update_number_of_bytes_written
      (    offset: ost$segment_length;
       VAR number_of_bytes_written: ost$segment_length);


      IF offset > number_of_bytes_written THEN
        number_of_bytes_written := offset;
      IFEND;


    PROCEND update_number_of_bytes_written;
?? OLDTITLE ??
?? NEWTITLE := 'setup_link', EJECT ??

    PROCEDURE setup_link
      (VAR status: ost$status);


      VAR
        i: ost$status_severity,
        page_size: ost$page_size,
        segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;


{ Set up link map variables.

      v$lm_asis_text.code := loc$lm_asis_text;
      v$lm_issue_diagnostic.code := loc$lm_issue_diagnostic;

      v$lm_diagnostic_summary.code := loc$lm_diagnostic_summary;
      FOR i := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
        v$lm_diagnostic_summary.diagnostic_count [i] := 0;
      FOREND;

      v$lm_module_detail_1.code := loc$lm_module_detail_1;
      v$lm_module_detail_2.code := loc$lm_module_detail_2;
      v$lm_section_detail.code := loc$lm_section_detail;
      v$lm_entry_detail.code := loc$lm_entry_detail;
      v$lm_transfer_detail.code := loc$lm_transfer_detail;
      v$lm_segment_detail.code := loc$lm_segment_detail;
      v$lm_page_header.code := loc$lm_page_header;

{ Set up product variables

      IF link_parameters.mode = occ$product THEN
        v$number_of_libraries := 0;
        v$library_list.link := NIL;
        v$last_address_formulation := ^v$address_formulation_records;
        v$last_address_formulation^.link := NIL;
      IFEND;

{ Set up global link variables.

      pmp$get_page_size (page_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      v$page_size := page_size;

      v$output_buffer := '  ';
      v$output_pos := 1;

      v$output_segment_list.link := NIL;
      v$section_name_list.link := NIL;

      IF link_parameters.starting_segment = occ$null_seg_value THEN
        IF link_parameters.mode <> occ$product THEN
          v$current_segment_number := occ$initial_segment_number;
        ELSE
          v$current_segment_number := mmc$first_loader_predefined_seg;
        IFEND;
      ELSE
        v$current_segment_number := link_parameters.starting_segment;
      IFEND;

      IF link_parameters.mode <> occ$product THEN
        v$minimum_segment_number := LOWERVALUE (ost$segment);
        v$maximum_segment_number := UPPERVALUE (ost$segment);
      ELSE
        v$minimum_segment_number := mmc$first_loader_predefined_seg;
        v$maximum_segment_number := mmc$first_loader_predefined_seg + mmc$num_loader_predefined_segs - 1;
      IFEND;
      v$next_retained_cmnblk_seg_num := v$maximum_segment_number + 1;

      v$common_block_table.link := NIL;

      v$next_free_formal_parameter := occ$number_of_free_formal_param + 1;
      v$formal_param_definitions.defining_module := osc$null_name;
      v$formal_param_definitions.r_link := NIL;
      v$formal_param_definitions.l_link := NIL;

      v$next_free_actual_parameter := occ$number_of_free_actual_param + 1;
      v$actual_param_groups.name := osc$null_name;
      v$actual_param_groups.link := NIL;
      v$next_free_entry_point := occ$number_of_free_entry_points + 1;
      v$free_program_names := NIL;
      v$free_entry_points := NIL;
      v$entry_points.name := osc$null_name;
      v$entry_points.r_link := NIL;
      v$entry_points.l_link := NIL;
      v$entry_points.link := NIL;
      v$last_entry_point := ^v$entry_points;

      v$unsatisfied_externals.link := NIL;
      v$unsatisfied_actual_param.link := NIL;
      v$free_external_references := NIL;
      v$free_external_items := NIL;
      v$free_external_names := NIL;

      v$starting_procedure := link_parameters.starting_procedure;
      v$last_starting_procedure := osc$null_name;
      v$starting_entry_point := NIL;

      PUSH segment_attributes_p: [1 .. 1];
      segment_attributes_p^ [1].keyword := mmc$ua_preset_value;
      segment_attributes_p^ [1].preset_value := link_parameters.preset_value;
      mmp$create_user_segment (segment_attributes_p, amc$sequence_pointer, mmc$as_sequential,
            v$retained_common_block_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET v$retained_common_block_segment.sequence_pointer;

      get_binding_rings_1_and_2 (v$binding_r1, v$binding_r2);

      get_modules_to_add (v$modules_to_add, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      add_externals_to_satisfy (v$unsatisfied_externals, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND setup_link;
?? OLDTITLE ??
?? NEWTITLE := 'process_predefined_segments', EJECT ??

    PROCEDURE process_predefined_segments
      (    predefined_segment_list: oct$output_segment_descriptor;
       VAR status: ost$status);


      VAR
        old_segment: ^oct$output_segment_descriptor,
        new_segment: ^oct$output_segment_descriptor,

        old_section: ^oct$section_name_list,
        new_section: ^oct$section_name_list;


      old_segment := predefined_segment_list.link;
      new_segment := ^v$output_segment_list;

      WHILE old_segment <> NIL DO
        NEXT new_segment^.link IN ocv$vel_scratch_seq;
        new_segment := new_segment^.link;
        IF new_segment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL6', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        new_segment^ := old_segment^;
        new_segment^.link := NIL;

        get_segment_number (new_segment^.retained_common_block, new_segment^.number_predefined,
              new_segment^.number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        old_segment := old_segment^.link;
      WHILEND;

      old_section := ocv$section_name_list.link;
      new_section := ^v$section_name_list;

      WHILE old_section <> NIL DO
        NEXT new_section^.link IN ocv$vel_scratch_seq;
        new_section := new_section^.link;
        IF new_section = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL7', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        new_section^ := old_section^;

        old_segment := predefined_segment_list.link;
        new_segment := v$output_segment_list.link;

        WHILE old_segment <> old_section^.segment_descriptor DO
          old_segment := old_segment^.link;
          new_segment := new_segment^.link;
        WHILEND;

        new_section^.segment_descriptor := new_segment;

        old_section := old_section^.link;
      WHILEND;

      new_section^.link := NIL;


    PROCEND process_predefined_segments;
?? OLDTITLE ??
?? NEWTITLE := 'process_inboard_symbol_tables', EJECT ??

    PROCEDURE process_inboard_symbol_tables
      (    symbol_tables_to_use: oct$symbol_table_descriptor;
       VAR status: ost$status);


      VAR
        next_symbol_table: ^oct$symbol_table_descriptor,
        inboard_symbol_table: ^oct$list_of_entry_points,
        linker_symbol_table: ^oct$list_of_entry_points,
        i: integer;


      next_symbol_table := symbol_tables_to_use.link;

      WHILE next_symbol_table <> NIL DO
        IF next_symbol_table^.header^.number_of_symbols > 0 THEN
          NEXT linker_symbol_table: [1 .. next_symbol_table^.header^.number_of_symbols] IN
                ocv$vel_scratch_seq;
          IF linker_symbol_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL8', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          linker_symbol_table^ := next_symbol_table^.symbol_table^;

          FOR i := 1 TO next_symbol_table^.header^.number_of_symbols DO
            linker_symbol_table^ [i].inboard_symbol := TRUE;
            linker_symbol_table^ [i].l_link := NIL;
            linker_symbol_table^ [i].r_link := NIL;
            linker_symbol_table^ [i].link := NIL;

            add_to_entry_points (^linker_symbol_table^ [i]);
          FOREND;
        IFEND;

        next_symbol_table := next_symbol_table^.link;
      WHILEND;


    PROCEND process_inboard_symbol_tables;
?? OLDTITLE ??
?? NEWTITLE := 'process_identification_record', EJECT ??

    PROCEDURE process_identification_record
      (    object_file: ^oct$object_file_descriptor;
       VAR module_kind: llt$module_kind;
       VAR status: ost$status);


      VAR
        date_time: clt$date_time,
        identification: ^llt$identification,
        i: llt$section_ordinal,
        local_status: ost$status,
        object_text_descriptor: ^llt$object_text_descriptor,
        parsed_file_reference: fst$parsed_file_reference,
        str: ost$string;


      status.normal := TRUE;
      local_status.normal := TRUE;

      NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_file^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF object_text_descriptor^.kind <> llc$identification THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_on_file, object_file^.name^, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Identification record expected',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT identification IN object_file^.segment.sequence_pointer;
      IF identification = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_file^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF (pmc$block_map IN link_parameters.map_options) OR
            (pmc$entry_point_map IN link_parameters.map_options) THEN
        v$lm_module_detail_1.module_name := identification^.name;

        clp$convert_string_to_file_ref (object_file^.name^, parsed_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        v$lm_module_detail_1.file_name := parsed_file_reference.
              path (parsed_file_reference.last_name.index, parsed_file_reference.last_name.size);
        v$lm_module_detail_1.loaded_ring := object_file^.r2;
        v$lm_module_detail_1.call_bracket := object_file^.r3;
        v$lm_module_detail_1.module_global_key_lock := object_file^.global_key;
        v$lm_module_detail_1.module_local_key_lock := object_file^.local_key;
        v$lm_module_detail_1.execute_privilege := object_file^.execute_privilege;

        IF object_file^.is_a_library THEN
          v$lm_module_detail_1.file_type := 'LIBRARY';
        ELSE
          v$lm_module_detail_1.file_type := '  FILE ';
        IFEND;

        ocp$generate_link_map_text (v$lm_module_detail_1);

        v$lm_module_detail_2.date := '**********';

        CASE identification^.date_created.date_format OF
        = osc$month_date =
          clp$convert_string_to_date_time (identification^.date_created.month, 'MONTH', date_time,
                local_status);

        = osc$mdy_date =
          clp$convert_string_to_date_time (identification^.date_created.mdy, 'MDY', date_time, local_status);

        = osc$iso_date =
          v$lm_module_detail_2.date := identification^.date_created.iso;

        = osc$ordinal_date =
          clp$convert_string_to_date_time (identification^.date_created.ordinal, 'ORDINAL', date_time,
                local_status);

        = osc$dmy_date =
          clp$convert_string_to_date_time (identification^.date_created.dmy, 'DMY', date_time, local_status);

        ELSE
          ;
        CASEND;

        IF local_status.normal AND (identification^.date_created.date_format <> osc$iso_date) THEN
          clp$convert_date_time_to_string (date_time, 'ISOD', str, local_status);
          IF local_status.normal THEN
            v$lm_module_detail_2.date := str.value (1, str.size);
          IFEND;
        IFEND;

        v$lm_module_detail_2.generator := identification^.generator_name_vers;
        v$lm_module_detail_2.commentary := identification^.commentary;

        ocp$generate_link_map_text (v$lm_module_detail_2);
      IFEND;

      IF identification^.object_text_version <> llc$object_text_version THEN
        osp$set_status_abnormal (oc, oce$e_invalid_obj_text_version, identification^.object_text_version,
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT v$mdt: [0 .. identification^.greatest_section_ordinal] IN ocv$vel_scratch_seq;
      IF v$mdt = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL9', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$mdt^.name := identification^.name;
      v$mdt^.r1 := object_file^.r1;
      v$mdt^.r2 := object_file^.r2;
      v$mdt^.r3 := object_file^.r3;
      v$mdt^.global_key := object_file^.global_key;
      v$mdt^.local_key := object_file^.local_key;

      v$mdt^.ring_of_execution := object_file^.r1;
      v$mdt^.execute_attribute := object_file^.execute_privilege;

      v$mdt^.binding_section_encountered := FALSE;
      v$mdt^.binding_section.ring := osc$max_ring;
      v$mdt^.binding_section.seg := 0;
      v$mdt^.binding_section.offset := 0;

      v$mdt^.default_sections := object_file^.default_sections;

      FOR i := 0 TO identification^.greatest_section_ordinal DO
        v$mdt^.section_table [i].undefined := TRUE;
      FOREND;

      v$mdt^.external_names.link := NIL;

      IF llc$object_cybil_checking IN identification^.attributes THEN
        v$source_type_checking := FALSE;
      IFEND;

      module_kind := identification^.kind;

      IF v$generate_debug_tables THEN
        ocp$dtb_define_module (identification, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
        IFEND;
      IFEND;


    PROCEND process_identification_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_ppu_absolute_record', EJECT ??

    PROCEDURE process_ppu_absolute_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        ppu_absolute: ^llt$ppu_absolute;


      NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF object_text_descriptor^.kind <> llc$ppu_absolute THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'PPU absolute record expected', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT ppu_absolute: [0 .. (object_text_descriptor^.number_of_words - 1)] IN
            object_file^.segment.sequence_pointer;
      IF ppu_absolute = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      osp$set_status_abnormal (oc, oce$w_module_not_included, v$mdt^.name, status);
      issue_diagnostic (osc$warning_status, status);


    PROCEND process_ppu_absolute_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_libraries_record', EJECT ??

    PROCEDURE process_libraries_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_libraries: 1 .. llc$max_libraries;
       VAR status: ost$status);


      VAR
        libraries: ^llt$libraries,
        library: ^oct$object_file_descriptor,
        lib: ^oct$known_file_list,
        i: 1 .. llc$max_libraries,
        parsed_file_reference: fst$parsed_file_reference;


      NEXT libraries: [1 .. number_of_libraries] IN object_file^.segment.sequence_pointer;
      IF libraries = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_libraries DO
        library := link_parameters.object_libraries_to_use.link;

      /find_library/
        WHILE (library <> NIL) DO
          clp$convert_string_to_file_ref (library^.name^, parsed_file_reference, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (parsed_file_reference.path (parsed_file_reference.last_name.index,
                parsed_file_reference.last_name.size) = libraries^ [i]) THEN
            EXIT /find_library/;
          IFEND;

          library := library^.link;
        WHILEND /find_library/;

        IF library = NIL THEN
          osp$set_status_abnormal (oc, oce$w_required_library_missing, libraries^ [i], status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        IF link_parameters.mode = occ$product THEN
          lib := ^v$library_list;

          WHILE (lib^.link <> NIL) AND (lib^.link^.name^ <> libraries^ [i]) DO
            lib := lib^.link;
          WHILEND;

          IF lib^.link = NIL THEN
            v$number_of_libraries := v$number_of_libraries + 1;
            ocp$add_to_known_files (libraries^ [i], lib^, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;


    PROCEND process_libraries_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_application_id_record', EJECT ??

    PROCEDURE process_application_id_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        application_identifier: ^llt$application_identifier;


      NEXT application_identifier IN object_file^.segment.sequence_pointer;
      IF application_identifier = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

    PROCEND process_application_id_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_section_definition', EJECT ??

    PROCEDURE process_section_definition
      (    object_file: ^oct$object_file_descriptor;
           unallocated_common_block: boolean;
           allotted_section: ost$relative_pointer;
       VAR status: ost$status);

?? NEWTITLE := 'obtain_section_attributes', EJECT ??

      PROCEDURE obtain_section_attributes
        (    section_item: oct$section_table_item;
         VAR attributes: oct$section_attributes);


        IF (v$mdt^.global_key <> 0) OR (v$mdt^.local_key <> 0) THEN
          attributes.read_default := osc$read_key_lock_controlled;
          attributes.write_default := osc$write_key_lock_controlled;
        ELSE
          attributes.read_default := osc$read_uncontrolled;
          attributes.write_default := osc$write_uncontrolled;
        IFEND;

        attributes.execute_default := v$mdt^.execute_attribute;

        attributes.cache_bypass := FALSE;

        attributes.extensible := (section_item.definition.kind = llc$extensible_working_storage) OR
              (section_item.definition.kind = llc$extensible_common_block);

        IF llc$binding IN section_item.definition.access_attributes THEN
          attributes.read_attribute := osc$binding_segment;
        ELSEIF llc$read IN section_item.definition.access_attributes THEN
          attributes.read_attribute := attributes.read_default;
        ELSE
          attributes.read_attribute := osc$non_readable;
        IFEND;

        IF llc$write IN section_item.definition.access_attributes THEN
          attributes.write_attribute := attributes.write_default;
        ELSE
          attributes.write_attribute := osc$non_writable;
        IFEND;

        IF llc$execute IN section_item.definition.access_attributes THEN
          attributes.execute_attribute := attributes.execute_default;
        ELSE
          attributes.execute_attribute := osc$non_executable;
        IFEND;


      PROCEND obtain_section_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'convert_section_attributes', EJECT ??

      PROCEDURE convert_section_attributes
        (    section_attributes: oct$section_attributes;
         VAR segment_attributes: oct$segment_attributes);


        VAR
          read_attributes: [STATIC] array [ost$read_privilege] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_read_kl],
                $oct$segment_attributes [occ$sa_read], $oct$segment_attributes [occ$sa_binding]],

          write_attributes: [STATIC] array [ost$write_privilege] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_write_kl],
                $oct$segment_attributes [occ$sa_write], $oct$segment_attributes []],

          execute_attributes: [STATIC] array [ost$execute_privilege] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_non_privileged],
                $oct$segment_attributes [occ$sa_local_privilege],
                $oct$segment_attributes [occ$sa_global_privilege]],

          cache_bypass_attributes: [STATIC] array [boolean] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_cache_bypass]],

          extensible_attributes: [STATIC] array [boolean] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_extensible]];


        segment_attributes := read_attributes [section_attributes.read_attribute] +
              write_attributes [section_attributes.write_attribute] +
              execute_attributes [section_attributes.execute_attribute] +
              cache_bypass_attributes [section_attributes.cache_bypass] +
              extensible_attributes [section_attributes.extensible];


      PROCEND convert_section_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'find_section_name_to_allocate', EJECT ??

      PROCEDURE find_section_name_to_allocate
        (    access_attributes: llt$section_access_attributes;
             default_sections: ^oct$default_sections;
         VAR section_name_to_allocate: pmt$program_name);


        VAR
          i: integer;


        IF default_sections <> NIL THEN

          FOR i := 1 TO UPPERBOUND (default_sections^) DO
            IF access_attributes = default_sections^ [i].attributes THEN
              section_name_to_allocate := default_sections^ [i].name;
              RETURN;
            IFEND;
          FOREND;

        IFEND;


      PROCEND find_section_name_to_allocate;
?? OLDTITLE ??
?? NEWTITLE := 'print_section_definition', EJECT ??

      PROCEDURE print_section_definition
        (    section_name: pmt$program_name;
             section_item: oct$section_table_item);


        v$lm_section_detail.section_kind := section_item.definition.kind;
        v$lm_section_detail.section_access_attributes := section_item.definition.access_attributes;
        v$lm_section_detail.section_address.ring := section_item.pva.ring;
        v$lm_section_detail.section_address.segment := section_item.pva.seg;
        v$lm_section_detail.section_address.offset := section_item.pva.offset;
        v$lm_section_detail.section_length := section_item.definition.length;
        v$lm_section_detail.section_name := section_item.section_name;

        ocp$generate_link_map_text (v$lm_section_detail);

        IF (section_item.definition.kind = llc$common_block) OR
              (section_item.definition.kind = llc$extensible_common_block) THEN
          output ('    NAME: ', section_item.common_block_name, #SIZE (section_item.common_block_name),
                flush);
        ELSEIF section_name <> osc$null_name THEN
          output ('    NAME: ', section_name, #SIZE (section_name), flush);
        IFEND;


      PROCEND print_section_definition;
?? OLDTITLE ??
?? NEWTITLE := 'create_segment_for_section', EJECT ??

      PROCEDURE create_segment_for_section
        (    section_item: oct$section_table_item;
             segment_attributes: oct$segment_attributes;
         VAR segment: ^oct$output_segment_descriptor;
         VAR status: ost$status);

        TYPE
          section_kinds = set of llt$section_kind;

        VAR
          last_segment: ^oct$output_segment_descriptor,
          preset_value: pmt$initialization_value;

        status.normal := TRUE;
        IF link_parameters.mode = occ$mc68000 THEN
          osp$set_status_abnormal (oc, oce$e_add_undefined_68000_seq, 'VEL157', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        NEXT segment IN ocv$vel_scratch_seq;
        IF segment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL10', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        segment^.used_attributes := segment_attributes;
        segment^.unused_attributes := $oct$segment_attributes [];

        IF occ$sa_extensible IN segment_attributes THEN
          segment^.extensible_attribute := occ$unallocated_extensible;
        ELSE
          segment^.extensible_attribute := occ$non_extensible;
        IFEND;

        segment^.r1 := section_item.r1;
        segment^.r2 := section_item.r2;
        segment^.r3 := section_item.r3;
        segment^.global_key := section_item.global_key;
        segment^.local_key := section_item.local_key;
        segment^.retained_common_block := section_item.retained_common_block;
        segment^.number_predefined := FALSE;
        segment^.sections_allocated.link := NIL;
        segment^.inhibit_binding_check := FALSE;
        segment^.binding_section_encountered := FALSE;
        segment^.binding_section_segment := 0;
        segment^.binding_section_offset := 0;
        segment^.number_of_bytes_written := 0;
        segment^.relocation_list.link := NIL;
        segment^.link := NIL;
        segment^.cybil_default_heap := (section_item.common_block_name = cyc$default_heap_name);

        IF section_item.definition.kind IN $section_kinds [llc$working_storage_section, llc$common_block,
              llc$extensible_working_storage, llc$extensible_common_block] THEN
          preset_value := link_parameters.preset_value;
        ELSE
          preset_value := pmc$initialize_to_zero;
        IFEND;

        open_temporary_segment (section_item, preset_value, segment, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        last_segment := ^v$output_segment_list;

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

        last_segment^.link := segment;


      PROCEND create_segment_for_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_section_in_segment', EJECT ??

      PROCEDURE allocate_section_in_segment
        (VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        VAR
          valid_position: boolean,
          current_sequence_position: ost$segment_offset;


        status.normal := TRUE;
        current_sequence_position := i#current_sequence_position
              (section_item.output^.segment.sequence_pointer);

        WHILE (current_sequence_position MOD section_item.definition.allocation_alignment) <>
              section_item.definition.allocation_offset DO
          current_sequence_position := current_sequence_position + 1;
        WHILEND;

        pmp$position_object_library (section_item.output^.segment.sequence_pointer, current_sequence_position,
              valid_position);
        IF NOT valid_position THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL11', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        section_item.pva.offset := current_sequence_position;

        IF section_item.definition.length = 0 THEN
          section_item.text := NIL;

        ELSE
          NEXT section_item.text: [0 .. (section_item.definition.length - 1)] IN
                section_item.output^.segment.sequence_pointer;
          IF section_item.text = NIL THEN
            osp$set_status_condition (oce$e_sec_overflow_in_segment, status);
            osp$append_status_integer (osc$status_parameter_delimiter, section_item.output^.number, 10, FALSE,
                  status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;
        IFEND;

        IF section_item.output^.extensible_attribute = occ$unallocated_extensible THEN
          section_item.output^.extensible_attribute := occ$allocated_extensible;
        IFEND;

        section_item.r1 := section_item.output^.r1;
        section_item.r2 := section_item.output^.r2;
        section_item.r3 := section_item.output^.r3;


      PROCEND allocate_section_in_segment;
?? OLDTITLE ??
?? NEWTITLE := 'get_segment_for_unnamed_section', EJECT ??

      PROCEDURE get_segment_for_unnamed_section
        (VAR section_item: oct$section_table_item;
             segment_attributes: oct$segment_attributes;
         VAR status: ost$status);


        VAR
          extensible_attribute: oct$extensible_attributes,
          segment: ^oct$output_segment_descriptor;


        IF occ$sa_extensible IN segment_attributes THEN
          extensible_attribute := occ$unallocated_extensible;
        ELSE
          extensible_attribute := occ$non_extensible;
        IFEND;

        IF ((link_parameters.mode = occ$product) AND (section_item.definition.kind = llc$code_section)) OR
              ((section_item.retained_common_block) AND (NOT section_item.deferred_common_block)) THEN
          segment := NIL;
        ELSE
          segment := v$output_segment_list.link;

          WHILE (segment <> NIL) AND (NOT ((segment^.extensible_attribute = extensible_attribute) AND
                (segment^.used_attributes = segment_attributes) AND (segment^.r1 = section_item.r1) AND
                (segment^.r2 = section_item.r2) AND (segment^.r3 = section_item.r3) AND
                (segment^.global_key = section_item.global_key) AND
                (segment^.local_key = section_item.local_key) AND (NOT segment^.retained_common_block))) DO

            segment := segment^.link;

          WHILEND;
        IFEND;

        IF segment = NIL THEN

{ Common block cannot be deferred if the segment has not already been defined.

          section_item.deferred_common_block := FALSE;

          create_segment_for_section (section_item, segment_attributes, segment, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        section_item.output := segment;
        section_item.pva.seg := segment^.number;


      PROCEND get_segment_for_unnamed_section;
?? OLDTITLE ??
?? NEWTITLE := 'get_segment_for_named_section', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if a named section is already
{   known to the linker and, if it is not, to determine whether to create a
{   segment for it or not.  If the named section is already known or a segment is
{   created, then the segment description is added to the section information and,
{   if necessary, the name of the section allocated is added to the segment
{   description.

      PROCEDURE get_segment_for_named_section
        (VAR section_item: oct$section_table_item;
             segment_attributes: oct$segment_attributes;
         VAR status: ost$status);


        VAR
          extensible_attribute: oct$extensible_attributes,
          section_name: ^oct$section_name_list,
          section_names: ^oct$program_name_list;


        IF occ$sa_extensible IN segment_attributes THEN
          extensible_attribute := occ$unallocated_extensible;
        ELSE
          extensible_attribute := occ$non_extensible;
        IFEND;

        section_name := v$section_name_list.link;

        WHILE (section_name <> NIL) AND ((section_name^.name <> section_item.section_name) OR
              (extensible_attribute <> section_name^.segment_descriptor^.extensible_attribute)) DO

          section_name := section_name^.link;

        WHILEND;

        IF section_name = NIL THEN
          IF link_parameters.create_only_predefined_segments THEN
            osp$set_status_abnormal (oc, oce$e_seg_not_defined_for_sect, section_item.section_name, status);
            issue_diagnostic (osc$error_status, status);
          IFEND;

          NEXT section_name IN ocv$vel_scratch_seq;
          IF section_name = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL12', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          section_name^.name := section_item.section_name;
          section_name^.link := v$section_name_list.link;
          v$section_name_list.link := section_name;

          create_segment_for_section (section_item, segment_attributes, section_name^.segment_descriptor,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        section_item.output := section_name^.segment_descriptor;
        section_item.pva.seg := section_name^.segment_descriptor^.number;

        section_names := ^section_name^.segment_descriptor^.sections_allocated;

        WHILE (section_names^.link <> NIL) AND (section_names^.link^.name <> section_item.section_name) DO
          section_names := section_names^.link;
        WHILEND;

        IF section_names^.link = NIL THEN
          NEXT section_names^.link IN ocv$vel_scratch_seq;
          section_names := section_names^.link;
          IF section_names = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL13', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          section_names^.name := section_item.section_name;
          section_names^.link := NIL;
        IFEND;


      PROCEND get_segment_for_named_section;
?? OLDTITLE ??
?? NEWTITLE := 'assign_section_to_a_segment', EJECT ??

      PROCEDURE assign_section_to_a_segment
        (VAR section_item: oct$section_table_item;
             section_attributes: oct$section_attributes;
         VAR status: ost$status);


        VAR
          segment_attributes: oct$segment_attributes;


        convert_section_attributes (section_attributes, segment_attributes);

        IF (section_item.section_name = osc$null_name) OR (link_parameters.ignore_section_names) THEN
          get_segment_for_unnamed_section (section_item, segment_attributes, status);
        ELSE
          get_segment_for_named_section (section_item, segment_attributes, status);
        IFEND;

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        allocate_section_in_segment (section_item, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;


      PROCEND assign_section_to_a_segment;
?? OLDTITLE ??
?? NEWTITLE := 'assign_common_block_to_section', EJECT ??

      PROCEDURE assign_common_block_to_section
        (    common_block: ^oct$common_block_item;
         VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        IF common_block^.section_item^.definition.access_attributes <>
              section_item.definition.access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_conflicting_common_attr,
                common_block^.section_item^.common_block_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        CASE section_item.definition.kind OF
        = llc$extensible_common_block =
          IF common_block^.section_item^.definition.kind = llc$common_block THEN
            osp$set_status_abnormal (oc, oce$w_conflicting_common_attr,
                  common_block^.section_item^.common_block_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

          IF common_block^.section_item^.definition.length < section_item.definition.length THEN
            IF common_block^.section_item^.definition.kind = llc$extensible_common_block THEN
              RESET common_block^.section_item^.output^.segment.sequence_pointer TO common_block^.
                    section_item^.text;
              NEXT common_block^.section_item^.text: [0 .. (section_item.definition.length - 1)] IN
                    common_block^.section_item^.output^.segment.sequence_pointer;
              IF common_block^.section_item^.text = NIL THEN
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL14', status);
                issue_diagnostic (osc$fatal_status, status);
                RETURN;
              IFEND;

              common_block^.section_item^.definition.length := section_item.definition.length;
            IFEND;
          IFEND;

        = llc$common_block =
          IF common_block^.section_item^.definition.kind = llc$extensible_common_block THEN
            osp$set_status_abnormal (oc, oce$w_conflicting_common_attr,
                  common_block^.section_item^.common_block_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

          IF common_block^.section_item^.definition.length < section_item.definition.length THEN
            osp$set_status_abnormal (oc, oce$w_conflicting_common_lngth,
                  common_block^.section_item^.common_block_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

        CASEND;

        section_item := common_block^.section_item^;
        section_item.pva.ring := v$mdt^.r1;
        section_item.r1 := v$mdt^.r2;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r2;


      PROCEND assign_common_block_to_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_common_block', EJECT ??

      PROCEDURE allocate_common_block
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        VAR
          maximum_heap_size: [STATIC] ost$segment_length := 07fffffff(16),
          common_block: ^oct$common_block_item;


        IF llc$binding IN section_item.definition.access_attributes THEN
          section_attributes.read_attribute := section_attributes.read_default;
        IFEND;

        section_item.r1 := v$mdt^.r2;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r2;
        section_item.pva.ring := v$mdt^.r1;

        assign_section_to_a_segment (section_item, section_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (link_parameters.mode = occ$mc68000) AND (section_item.common_block_name = cyc$default_heap_name)
              THEN
          IF link_parameters.heap_size_specified THEN
            i#move (#LOC (section_item.definition.length), #LOC (section_item.text^), 4);
          ELSE
            i#move (#LOC (maximum_heap_size), #LOC (section_item.text^), 4);
          IFEND;
          update_number_of_bytes_written ((#OFFSET (section_item.text) + 4),
                section_item.output^.number_of_bytes_written);
        IFEND;

        IF (NOT section_item.output^.inhibit_binding_check) AND
              (llc$binding IN section_item.definition.access_attributes) THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'Binding attribute specified in non binding section', status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        NEXT common_block IN ocv$vel_scratch_seq;
        IF common_block = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL15', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        common_block^.section_item := ^section_item;
        common_block^.link := v$common_block_table.link;
        v$common_block_table.link := common_block;


      PROCEND allocate_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_code_section', EJECT ??

      PROCEDURE allocate_code_section
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        IF (section_item.definition.access_attributes - $llt$section_access_attributes
              [llc$read, llc$execute]) <> $llt$section_access_attributes [] THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid code section attributes',
                status);
          issue_diagnostic (osc$error_status, status);

          section_attributes.read_attribute := section_attributes.read_default;
          section_attributes.write_attribute := osc$non_writable;
          section_attributes.execute_attribute := section_attributes.execute_default;
        IFEND;

        section_item.r1 := v$mdt^.r1;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r3;
        section_item.pva.ring := v$mdt^.ring_of_execution;

        assign_section_to_a_segment (section_item, section_attributes, status);


      PROCEND allocate_code_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_binding_section', EJECT ??

      PROCEDURE allocate_binding_section
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        IF v$mdt^.binding_section_encountered THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'Multiple binding sections encountered', status);
          issue_diagnostic (osc$error_status, status);
        ELSE
          v$mdt^.binding_section_encountered := TRUE;
        IFEND;

        IF (section_item.definition.access_attributes - $llt$section_access_attributes
              [llc$binding, llc$read]) <> $llt$section_access_attributes [] THEN
          section_attributes.read_attribute := osc$binding_segment;
          section_attributes.write_attribute := osc$non_writable;
          section_attributes.execute_attribute := osc$non_executable;
        IFEND;

        section_item.r1 := v$binding_r1;
        section_item.r2 := v$binding_r2;
        section_item.r3 := v$binding_r2;
        section_item.pva.ring := v$mdt^.ring_of_execution;
        section_item.global_key := 0; { master key }
        section_item.local_key := 0; { master key }

        assign_section_to_a_segment (section_item, section_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        v$mdt^.binding_section := section_item.pva;

        IF NOT section_item.output^.inhibit_binding_check THEN
          IF (section_item.definition.access_attributes - $llt$section_access_attributes
                [llc$binding, llc$read]) <> $llt$section_access_attributes [] THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid binding section attributes',
                  status);
            issue_diagnostic (osc$error_status, status);
          IFEND;

          IF ((section_item.definition.allocation_alignment + section_item.definition.allocation_offset) MOD
                8) <> 0 THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid binding section alignment',
                  status);
            issue_diagnostic (osc$error_status, status);
          IFEND;
        IFEND;


      PROCEND allocate_binding_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_working_storage_sec', EJECT ??

      PROCEDURE allocate_working_storage_sec
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        IF llc$binding IN section_item.definition.access_attributes THEN
          section_attributes.read_attribute := section_attributes.read_default;
        IFEND;

        section_item.r1 := v$mdt^.r2;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r2;
        section_item.pva.ring := v$mdt^.r1;

        assign_section_to_a_segment (section_item, section_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT section_item.output^.inhibit_binding_check THEN
          IF llc$binding IN section_item.definition.access_attributes THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'Binding attribute specified in non binding section', status);
            issue_diagnostic (osc$error_status, status);
          IFEND;
        IFEND;


      PROCEND allocate_working_storage_sec;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] is_this_a_retained_common_block', EJECT ??

      PROCEDURE [INLINE] is_this_a_retained_common_block
        (    section_item: oct$section_table_item;
         VAR this_is_a_retained_common_block: boolean);


        VAR
          retained_common_blocks: ^oct$program_name_list;


        IF (link_parameters.mode = occ$product) THEN
          IF (section_item.unallocated_common_block) OR (link_parameters.common_blocks_to_retain.name =
                occ$retain_all_common_blocks) OR (section_item.common_block_name = cyc$default_heap_name) THEN
            this_is_a_retained_common_block := TRUE;
            RETURN; { ---->
          IFEND;

          retained_common_blocks := link_parameters.common_blocks_to_retain.link;

          WHILE (retained_common_blocks <> NIL) DO
            IF (retained_common_blocks^.name = section_item.common_block_name) THEN
              this_is_a_retained_common_block := TRUE;
              RETURN; { ---->
            IFEND;

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

        this_is_a_retained_common_block := FALSE;


      PROCEND is_this_a_retained_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'is_common_block_deferred', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if a common block is to be deferred.
{ DESIGN:
{   If all common blocks are to be deferred the common block is to be deferred.
{   Otherwise the list of names specified will be searched.  If the list of names
{   represents those not to be deferred and the common block is not in it or if the
{   list of names represents those to be deferred and the common block is in it the
{   common block is to be deferred.
{ NOTE:
{   Unallocated common blocks are not deferred.

      PROCEDURE is_common_block_deferred
        (    section_item: oct$section_table_item;
         VAR deferred: boolean);

        VAR
          common_block: ^oct$defer_list,
          status: ost$status;


        deferred := FALSE;
        IF link_parameters.defer_common_blocks <> NIL THEN
          IF link_parameters.defer_common_blocks^.defer = occ$defer_all THEN
            IF NOT section_item.unallocated_common_block THEN
              deferred := TRUE;
            ELSE
              osp$set_status_abnormal (oc, oce$cannot_defer_unalloc_common, section_item.common_block_name,
                    status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;

          ELSEIF link_parameters.defer_common_blocks^.defer = occ$defer THEN
            common_block := link_parameters.defer_common_blocks^.name_list;
            WHILE common_block <> NIL DO
              IF common_block^.name = section_item.common_block_name THEN
                common_block^.name_found := TRUE;
                IF NOT section_item.unallocated_common_block THEN
                  deferred := TRUE;
                ELSE
                  osp$set_status_abnormal (oc, oce$cannot_defer_unalloc_common,
                        section_item.common_block_name, status);
                  issue_diagnostic (osc$warning_status, status);
                IFEND;
                RETURN;
              IFEND;
              common_block := common_block^.link;
            WHILEND;

          ELSEIF link_parameters.defer_common_blocks^.defer = occ$defer_all_except THEN
            common_block := link_parameters.defer_common_blocks^.name_list;
            WHILE common_block <> NIL DO
              IF common_block^.name = section_item.common_block_name THEN
                common_block^.name_found := TRUE;
                RETURN;
              IFEND;
              common_block := common_block^.link;
            WHILEND;
            IF NOT section_item.unallocated_common_block THEN
              deferred := TRUE;
            ELSE
              osp$set_status_abnormal (oc, oce$cannot_defer_unalloc_common, section_item.common_block_name,
                    status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;

          IFEND;
        IFEND;
      PROCEND is_common_block_deferred;
?? OLDTITLE ??
?? NEWTITLE := 'process_common_block', EJECT ??

      PROCEDURE process_common_block
        (VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        VAR
          common_block: ^oct$common_block_item,
          section_attributes: oct$section_attributes;


        section_item.section_name := osc$null_name;
        section_item.common_block_name := section_item.definition.name;

        IF section_item.common_block_name = cyc$default_heap_name THEN
          IF link_parameters.heap_size_specified THEN
            section_item.definition.length := link_parameters.heap_size;
          ELSEIF section_item.definition.length > 1000(16) THEN
            section_item.definition.length := 1000(16);
          IFEND;
          IF section_item.definition.length < 4 THEN
            section_item.definition.length := 4;
          IFEND;
        IFEND;

        common_block := v$common_block_table.link;

        WHILE (common_block <> NIL) AND (common_block^.section_item^.common_block_name <>
              section_item.common_block_name) DO
          common_block := common_block^.link;
        WHILEND;

        IF common_block <> NIL THEN
          assign_common_block_to_section (common_block, section_item, status);

        ELSE
          is_this_a_retained_common_block (section_item, section_item.retained_common_block);
          is_common_block_deferred (section_item, section_item.deferred_common_block);
          obtain_section_attributes (section_item, section_attributes);

          IF section_item.definition.kind <> llc$extensible_common_block THEN
            find_section_name_to_allocate (section_item.definition.access_attributes, v$mdt^.default_sections,
                  section_item.section_name);
          IFEND;

          allocate_common_block (section_item, section_attributes, status);
        IFEND;


      PROCEND process_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'process_non_common_block', EJECT ??

      PROCEDURE process_non_common_block
        (VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        VAR
          section_attributes: oct$section_attributes;


        section_item.section_name := section_item.definition.name;
        section_item.common_block_name := osc$null_name;

        obtain_section_attributes (section_item, section_attributes);

        IF section_item.definition.kind = llc$code_section THEN
          section_item.section_name := osc$null_name;
        IFEND;

        IF (section_item.section_name = osc$null_name) AND (section_item.definition.kind <>
              llc$extensible_working_storage) THEN
          find_section_name_to_allocate (section_item.definition.access_attributes, v$mdt^.default_sections,
                section_item.section_name);
        IFEND;

        CASE section_item.definition.kind OF
        = llc$code_section =
          allocate_code_section (section_item, section_attributes, status);

        = llc$binding_section =
          allocate_binding_section (section_item, section_attributes, status);

        = llc$working_storage_section, llc$extensible_working_storage, llc$lts_reserved =
          allocate_working_storage_sec (section_item, section_attributes, status);

        ELSE
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid section kind encountered',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        CASEND;


      PROCEND process_non_common_block;
?? OLDTITLE ??
?? EJECT ??

      CONST
        debug_section_1 = 'DBB$NEW_PROC_ENCOUNTERED',
        debug_section_2 = 'DBB$NEW_LINE_ENCOUNTERED';

      VAR
        section_definition: ^llt$section_definition,
        section_item: pmt$section_item,
        s: integer,

        valid_position: boolean,
        reset_value: ^SEQ ( * ),
        text: ^array [0 .. * ] of 0 .. 0ff(16);


      NEXT section_definition IN object_file^.segment.sequence_pointer;
      IF section_definition = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      s := section_definition^.section_ordinal;

      IF s > UPPERBOUND (v$mdt^.section_table) THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid section ordinal encountered',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [s].undefined THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'Duplicate section definition encountered', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF section_definition^.allocation_alignment = 0 THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Allocation alignment can not be ZERO',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$mdt^.section_table [s].undefined := FALSE;
      v$mdt^.section_table [s].retained_common_block := FALSE;
      v$mdt^.section_table [s].deferred_common_block := FALSE;
      v$mdt^.section_table [s].unallocated_common_block := unallocated_common_block;
      v$mdt^.section_table [s].definition := section_definition^;
      v$mdt^.section_table [s].global_key := v$mdt^.global_key;
      v$mdt^.section_table [s].local_key := v$mdt^.local_key;

      IF (section_definition^.kind = llc$common_block) OR (section_definition^.kind =
            llc$extensible_common_block) THEN
        process_common_block (v$mdt^.section_table [s], status);
      ELSE
        process_non_common_block (v$mdt^.section_table [s], status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pmc$block_map IN link_parameters.map_options THEN
        print_section_definition (section_definition^.name, v$mdt^.section_table [s]);
      IFEND;

      IF allotted_section <> 0 THEN
        IF section_definition^.length <> 0 THEN
          reset_value := object_file^.segment.sequence_pointer;

          pmp$position_object_library (object_file^.segment.sequence_pointer, allotted_section,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;
          NEXT text: [0 .. (section_definition^.length - 1)] IN object_file^.segment.sequence_pointer;
          IF v$mdt^.section_table [s].text = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          v$mdt^.section_table [s].text^ := text^;
          object_file^.segment.sequence_pointer := reset_value;

          IF link_parameters.mode = occ$product THEN
            update_number_of_bytes_written ((#OFFSET (v$mdt^.section_table [s].text) +
                  section_definition^.length), v$mdt^.section_table [s].output^.number_of_bytes_written);
          IFEND;
        IFEND;
      IFEND;

      IF (link_parameters.mode = occ$template) THEN
        IF (section_definition^.name = debug_section_1) OR (section_definition^.name = debug_section_2) THEN
          osp$set_status_abnormal (oc, oce$w_module_compiled_opt_debug, v$mdt^.name, status);
          issue_diagnostic (osc$error_status, status);

        ELSEIF (section_definition^.name = cyc$default_heap_name) THEN
          osp$set_status_abnormal (oc, oce$w_default_heap_in_system, v$mdt^.name, status);
          issue_diagnostic (osc$error_status, status);
        IFEND;
      IFEND;

      IF v$generate_debug_tables THEN
        section_item.kind := section_definition^.kind;
        section_item.section_ordinal := section_definition^.section_ordinal;
        section_item.address := (v$mdt^.section_table [s].pva.seg *
              100000000(16)) + v$mdt^.section_table [s].pva.offset;
        section_item.length := section_definition^.length;
        convert_segment_access_control (v$mdt^.section_table [s].output^.used_attributes,
              section_item.segment_access_control);
        section_item.ring.r1 := v$mdt^.section_table [s].r1;
        section_item.ring.r2 := v$mdt^.section_table [s].r2;
        section_item.ring.r3 := v$mdt^.section_table [s].r3;
        convert_key_lock (v$mdt^.section_table [s].global_key, v$mdt^.section_table [s].local_key,
              section_item.key_lock);
        section_item.name := section_definition^.name;

        ocp$dtb_define_section (section_item, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;


    PROCEND process_section_definition;
?? OLDTITLE ??
?? NEWTITLE := 'process_text_record', EJECT ??

    PROCEDURE process_text_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_bytes: 1 .. osc$max_segment_length;
       VAR status: ost$status);


      VAR
        text: ^llt$text;


      NEXT text: [1 .. number_of_bytes] IN object_file^.segment.sequence_pointer;
      IF text = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (text^.section_ordinal, (text^.offset + number_of_bytes), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [text^.section_ordinal].output^.inhibit_binding_check THEN
        IF llc$binding IN v$mdt^.section_table [text^.section_ordinal].definition.access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_data_in_binding, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;
      IFEND;

      IF (number_of_bytes <= (2 * v$page_size)) THEN
        i#move (#LOC (text^.byte [1]), #LOC (v$mdt^.section_table [text^.section_ordinal].
              text^ [text^.offset]), number_of_bytes);
      ELSE
        syp$advised_move_bytes (#LOC (text^.byte [1]), #LOC (v$mdt^.section_table [text^.section_ordinal].
              text^ [text^.offset]), number_of_bytes, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;

      IF link_parameters.mode = occ$product THEN
        update_number_of_bytes_written ((#OFFSET (#LOC (v$mdt^.section_table [text^.section_ordinal].
              text^ [text^.offset])) + number_of_bytes), v$mdt^.section_table [text^.section_ordinal].output^.
              number_of_bytes_written);
      IFEND;


    PROCEND process_text_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_replication_record', EJECT ??

    PROCEDURE process_replication_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_bytes: 1 .. osc$max_segment_length;
       VAR status: ost$status);


      VAR
        replication: ^llt$replication,
        i: 1 .. osc$max_segment_length,
        offset: integer;


      NEXT replication: [1 .. number_of_bytes] IN object_file^.segment.sequence_pointer;
      IF replication = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (replication^.section_ordinal, (replication^.offset +
            ((replication^.count - 1) * replication^.increment) + number_of_bytes), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [replication^.section_ordinal].output^.inhibit_binding_check THEN
        IF llc$binding IN v$mdt^.section_table [replication^.section_ordinal].definition.
              access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_data_in_binding, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;
      IFEND;

      offset := replication^.offset;
      FOR i := 1 TO replication^.count DO
        i#move (#LOC (replication^.byte [1]), #LOC (v$mdt^.section_table [replication^.section_ordinal].
              text^ [offset]), number_of_bytes);
        offset := offset + replication^.increment;
      FOREND;

      IF link_parameters.mode = occ$product THEN
        offset := offset - replication^.increment;
        update_number_of_bytes_written ((#OFFSET (#LOC (v$mdt^.section_table [replication^.section_ordinal].
              text^ [offset])) + number_of_bytes), v$mdt^.section_table [replication^.section_ordinal].
              output^.number_of_bytes_written);
      IFEND;


    PROCEND process_replication_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_bit_insertion_record', EJECT ??

    PROCEDURE process_bit_insertion_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        bit_insertion: ^llt$bit_string_insertion,
        i: 1 .. osc$max_segment_length,
        bit_string: ^packed array [1 .. 70] of 0 .. 1;


      NEXT bit_insertion IN object_file^.segment.sequence_pointer;
      IF bit_insertion = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (bit_insertion^.section_ordinal, (bit_insertion^.offset +
            ((bit_insertion^.bit_offset + bit_insertion^.bit_length + 7) DIV 8)), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [bit_insertion^.section_ordinal].output^.inhibit_binding_check THEN
        IF llc$binding IN v$mdt^.section_table [bit_insertion^.section_ordinal].definition.
              access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_data_in_binding, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;
      IFEND;

      bit_string := #LOC (v$mdt^.section_table [bit_insertion^.section_ordinal].
            text^ [bit_insertion^.offset]);

      FOR i := 1 TO bit_insertion^.bit_length DO
        bit_string^ [i + bit_insertion^.bit_offset] := bit_insertion^.bit_string [i];
      FOREND;

      IF link_parameters.mode = occ$product THEN
        update_number_of_bytes_written ((#OFFSET (#LOC (v$mdt^.section_table [bit_insertion^.section_ordinal].
              text^ [bit_insertion^.offset])) + 8), v$mdt^.section_table [bit_insertion^.section_ordinal].
              output^.number_of_bytes_written);
      IFEND;


    PROCEND process_bit_insertion_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_address_formulation_rec', EJECT ??

    PROCEDURE process_address_formulation_rec
      (    object_file: ^oct$object_file_descriptor;
       VAR number_of_adr_items: 1 .. llc$max_adr_items;
       VAR status: ost$status);


      VAR
        address: ^oct$addresses,
        address_formulation: ^llt$address_formulation,
        d: integer,
        i: 0 .. llc$max_adr_items,
        entry_point: ^oct$entry_points,
        v: integer;


      NEXT address_formulation: [1 .. number_of_adr_items] IN object_file^.segment.sequence_pointer;
      IF address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      d := address_formulation^.dest_section;
      validate_section (d, 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      v := address_formulation^.value_section;
      validate_section (v, 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (link_parameters.mode = occ$product) AND (v$mdt^.section_table [v].retained_common_block) AND
            (NOT v$mdt^.section_table [v].deferred_common_block) THEN
        add_adr_to_products_adr_list (address_formulation, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RETURN; { ---->
      IFEND;

      FOR i := 1 TO number_of_adr_items DO
        IF address_formulation^.item [i].kind > UPPERVALUE (llt$internal_address_kind) THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid address kind encountered',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        obtain_destination_address (v$mdt, address_formulation^.item [i].
              kind, d, address_formulation^.item [i].dest_offset, address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE link_parameters.mode OF

        = occ$mc68000 =

          CASE address_formulation^.item [i].kind OF
          = llc$address =
            address^.mc68000_offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

          = llc$short_address, llc$internal_proc =
            address^.mc68000_short_offset := v$mdt^.section_table [v].
                  pva.offset + address_formulation^.item [i].value_offset;

          = llc$external_proc =
            address^.mc68000_offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;
            address^.mc68000_binding_section := v$mdt^.binding_section.offset;


          CASEND;

        = occ$template =

          CASE address_formulation^.item [i].kind OF
          = llc$address =
            address^.pva.ring := v$mdt^.section_table [v].pva.ring;
            address^.pva.seg := v$mdt^.section_table [v].pva.seg;
            address^.pva.offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

          = llc$short_address, llc$internal_proc =
            address^.cbp.vmid := v$vmid;
            address^.cbp.epf := (address_formulation^.item [i].kind = llc$short_address);
            address^.cbp.r3 := v$mdt^.section_table [v].r3;
            address^.cbp.rn := v$mdt^.section_table [v].r1;
            address^.cbp.seg := v$mdt^.section_table [v].pva.seg;
            address^.cbp.bn := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

          = llc$external_proc =
            address^.cbp.vmid := v$vmid;
            address^.cbp.epf := TRUE;
            address^.cbp.r3 := v$mdt^.section_table [v].r3;
            address^.cbp.rn := v$mdt^.section_table [v].r1;
            address^.cbp.seg := v$mdt^.section_table [v].pva.seg;
            address^.cbp.bn := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;
            address^.binding_section := v$mdt^.binding_section;

          CASEND;

        = occ$product =

          CASE address_formulation^.item [i].kind OF
          = llc$address =
            address^.pva.ring := v$mdt^.section_table [v].pva.ring;
            address^.pva.seg := v$mdt^.section_table [v].pva.seg;
            address^.pva.offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

            update_number_of_bytes_written ((#OFFSET (address) + 6), v$mdt^.section_table [d].
                  output^.number_of_bytes_written);

            add_to_segments_rel_list (address, v$mdt^.section_table [d].output^.relocation_list, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          ELSE
            add_item_to_products_adr_list (v$mdt^.section_table [d].pva.seg, #OFFSET (address),
                  address_formulation^.item [i].kind, v$mdt^.section_table [v].
                  pva.seg, v$mdt^.section_table [v].pva.offset + address_formulation^.item [i].value_offset,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          CASEND;

        CASEND;
      FOREND;


    PROCEND process_address_formulation_rec;
?? OLDTITLE ??
?? NEWTITLE := 'process_entry_definition_record', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize an entry point record, determine if
{   the entry point is a duplicate, and satisfy and free any matching externals in the
{   external list.

    PROCEDURE process_entry_definition_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);

      VAR
        module_referencing: ^oct$program_name_list,
        entry_definition: ^llt$entry_definition,
        entry_point: ^oct$entry_points,
        duplicate_entry_point: ^oct$entry_points,
        external: ^oct$ext_reference_list,
        external_before: ^oct$ext_reference_list,
        item: ^oct$external_items,
        address: ^oct$addresses,
        deferred_attribute: [STATIC] array [boolean] of string (8) := ['        ', 'DEFERRED'],
        gate_attributes: [STATIC] array [boolean] of string (5) := ['     ', 'GATED'];


      NEXT entry_definition IN object_file^.segment.sequence_pointer;
      IF entry_definition = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (entry_definition^.section_ordinal, entry_definition^.offset, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      get_next_free_entry_point (entry_point, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initialize_entry_point (entry_definition, entry_point);

      IF pmc$entry_point_map IN link_parameters.map_options THEN
        v$lm_entry_detail.entry_name := entry_point^.name;
        v$lm_entry_detail.entry_address.segment := entry_point^.pva.seg;
        v$lm_entry_detail.entry_address.offset := entry_point^.pva.offset;
        v$lm_entry_detail.entry_attribute := gate_attributes [entry_point^.gated];
        v$lm_entry_detail.deferred := deferred_attribute [entry_point^.deferred];

        ocp$generate_link_map_text (v$lm_entry_detail);
      IFEND;

      IF v$generate_debug_tables THEN
        ocp$dtb_define_entry_point (entry_point^.name, entry_point^.pva, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      search_entry_point_tree (entry_point^.name, entry_point^.r1, entry_point^.r3, duplicate_entry_point);

      IF duplicate_entry_point <> NIL THEN
        osp$set_status_abnormal (oc, oce$w_duplicate_entry_points, entry_point^.name, status);
        issue_diagnostic (osc$warning_status, status);
      IFEND;

      add_to_entry_points (entry_point);

{ Satisfy and free any matching externals in the external list

      external_before := ^v$unsatisfied_externals;

      WHILE external_before^.link <> NIL DO
        external := external_before^.link;

        IF (external^.name = entry_point^.name) AND (rings_overlap
              (external^.r1, external^.r2, entry_point^.r1, entry_point^.r3)) THEN
          IF external^.check_for_ring_violation THEN
            entry_point^.ring_violation := (external^.r1 < entry_point^.r1) OR
                  (external^.r2 > entry_point^.r3);
          IFEND;

          IF (external^.declaration_matching_required AND entry_point^.declaration_matching_required) THEN
            IF (external^.language = entry_point^.language) THEN
              IF (entry_point^.language = llc$cybil) THEN
                IF (link_parameters.cybil_parameter_checking = v$object_type_checking) THEN
                  IF (external^.declaration_matching.object_encryption <>
                        entry_point^.declaration_matching.object_encryption) THEN
                    WHILE external^.modules_referencing <> NIL DO
                      module_referencing := external^.modules_referencing;
                      external^.modules_referencing := external^.modules_referencing^.link;
                      osp$set_status_abnormal (oc, oce$f_ext_param_verification, entry_point^.name, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter, module_referencing^.name,
                            status);
                      issue_diagnostic (osc$fatal_status, status);
                      module_referencing^.link := v$free_program_names;
                      v$free_program_names := module_referencing;
                    WHILEND;
                  IFEND;
                ELSE { source type checking
                  IF (external^.declaration_matching.source_encryption <>
                        entry_point^.declaration_matching.source_encryption) THEN
                    WHILE external^.modules_referencing <> NIL DO
                      module_referencing := external^.modules_referencing;
                      external^.modules_referencing := external^.modules_referencing^.link;
                      osp$set_status_abnormal (oc, oce$w_ext_param_verification, entry_point^.name, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter, module_referencing^.name,
                            status);
                      issue_diagnostic (osc$warning_status, status);
                      module_referencing^.link := v$free_program_names;
                      v$free_program_names := module_referencing;
                    WHILEND;
                  IFEND;
                IFEND;
              ELSE { generator is not CYBIL
                IF (external^.declaration_matching.language_dependent_value <>
                      entry_point^.declaration_matching.language_dependent_value) THEN
                  WHILE external^.modules_referencing <> NIL DO
                    module_referencing := external^.modules_referencing;
                    external^.modules_referencing := external^.modules_referencing^.link;
                    osp$set_status_abnormal (oc, oce$w_ext_param_verification, entry_point^.name, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, module_referencing^.name,
                          status);
                    issue_diagnostic (osc$warning_status, status);
                    module_referencing^.link := v$free_program_names;
                    v$free_program_names := module_referencing;
                  WHILEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;

          WHILE external^.items.link <> NIL DO
            item := external^.items.link;
            address := item^.address;
            CASE link_parameters.mode OF
            = occ$template =
              CASE item^.kind OF
              = llc$address =
                address^.pva := entry_point^.pva;

              = llc$short_address, llc$internal_proc =
                address^.cbp.vmid := v$vmid;
                address^.cbp.epf := (item^.kind = llc$short_address);
                address^.cbp.r3 := entry_point^.r3;
                address^.cbp.rn := entry_point^.r1;
                address^.cbp.seg := entry_point^.pva.seg;
                address^.cbp.bn := entry_point^.pva.offset;

              = llc$external_proc =
                address^.cbp.vmid := v$vmid;
                address^.cbp.epf := TRUE;
                address^.cbp.r3 := entry_point^.r3;
                address^.cbp.rn := entry_point^.r1;
                address^.cbp.seg := entry_point^.pva.seg;
                address^.cbp.bn := entry_point^.pva.offset;
                address^.binding_section := entry_point^.binding_section;

              = llc$address_addition =
                address^.pva := entry_point^.pva;
                address^.pva.offset := entry_point^.pva.offset + item^.offset_operand;

              = llc$address_subtraction =
                address^.pva := entry_point^.pva;
                address^.pva.offset := entry_point^.pva.offset - item^.offset_operand;

              CASEND;

            = occ$product =
              CASE item^.kind OF
              = llc$address, llc$address_addition, llc$address_subtraction =
                address^.pva := entry_point^.pva;

                IF (item^.kind = llc$address_addition) THEN
                  address^.pva.offset := address^.pva.offset + item^.offset_operand;
                ELSEIF (item^.kind = llc$address_subtraction) THEN
                  address^.pva.offset := address^.pva.offset - item^.offset_operand;
                IFEND;

                update_number_of_bytes_written ((#OFFSET (address) + 6),
                      item^.output^.number_of_bytes_written);

                add_to_segments_rel_list (address, item^.output^.relocation_list, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

              ELSE
                add_item_to_products_adr_list (item^.output^.number, #OFFSET (address), item^.kind,
                      entry_point^.pva.seg, entry_point^.pva.offset, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              CASEND;

            = occ$mc68000 =
              CASE item^.kind OF
              = llc$address =
                address^.mc68000_offset := entry_point^.pva.offset;

              = llc$short_address, llc$internal_proc =
                address^.mc68000_short_offset := entry_point^.pva.offset;

              = llc$external_proc =
                address^.mc68000_offset := entry_point^.pva.offset;
                address^.mc68000_binding_section := entry_point^.binding_section.offset;

              = llc$address_addition =
                address^.mc68000_offset := entry_point^.pva.offset + item^.offset_operand;

              = llc$address_subtraction =
                address^.mc68000_offset := entry_point^.pva.offset - item^.offset_operand;

              CASEND;
            CASEND;

            external^.items.link := external^.items.link^.link;
            item^.link := v$free_external_items;
            v$free_external_items := item;
          WHILEND;

          external_before^.link := external_before^.link^.link;
          external^.link := v$free_external_references;
          v$free_external_references := external;

        ELSE
          external_before := external_before^.link;
        IFEND;

      WHILEND;


    PROCEND process_entry_definition_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_external_linkage_record', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add the name of an external reference to the
{   list of known externals, satisfy it from the known entry points if possible, and,
{   if not, add the external to the list to be satisfied.

    PROCEDURE process_external_linkage_record
      (    object_file: ^oct$object_file_descriptor;
       VAR number_of_ext_items: 1 .. llc$max_ext_items;
       VAR status: ost$status);


      VAR
        declaration_matching_passes: boolean,
        external_linkage: ^llt$external_linkage,
        entry_point: ^oct$entry_points,
        external: ^oct$ext_reference_list,
        d: llt$section_ordinal,
        i: integer,
        address: ^oct$addresses;


      NEXT external_linkage: [1 .. number_of_ext_items] IN object_file^.segment.sequence_pointer;
      IF external_linkage = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      add_to_external_names (external_linkage^.name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      search_entry_point_tree (external_linkage^.name, v$mdt^.r1, v$mdt^.r2, entry_point);

      IF entry_point <> NIL THEN
        entry_point^.ring_violation := (v$mdt^.r1 < entry_point^.r1) OR (v$mdt^.r2 > entry_point^.r3);

        IF (entry_point^.declaration_matching_required AND external_linkage^.declaration_matching_required)
              THEN
          IF (entry_point^.language = external_linkage^.language) THEN
            IF (entry_point^.language = llc$cybil) THEN
              IF (link_parameters.cybil_parameter_checking = v$object_type_checking) THEN
                IF (entry_point^.declaration_matching.object_encryption <>
                      external_linkage^.declaration_matching.object_encryption) THEN
                  osp$set_status_abnormal (oc, oce$f_ext_param_verification, external_linkage^.name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
                  issue_diagnostic (osc$fatal_status, status);
                IFEND;
              ELSE { source type checking
                IF (entry_point^.declaration_matching.source_encryption <>
                      external_linkage^.declaration_matching.source_encryption) THEN
                  osp$set_status_abnormal (oc, oce$w_ext_param_verification, external_linkage^.name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
                  issue_diagnostic (osc$warning_status, status);
                IFEND;
              IFEND;
            ELSE { language is not CYBIL
              IF (entry_point^.declaration_matching.language_dependent_value <>
                    external_linkage^.declaration_matching.language_dependent_value) THEN
                osp$set_status_abnormal (oc, oce$w_ext_param_verification, external_linkage^.name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
                issue_diagnostic (osc$warning_status, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        FOR i := 1 TO number_of_ext_items DO
          d := external_linkage^.item [i].section_ordinal;
          validate_section (d, 0, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF external_linkage^.item [i].kind > UPPERVALUE (llt$address_kind) THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid address kind encountered',
                  status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          obtain_destination_address (v$mdt, external_linkage^.item [i].kind, d,
                external_linkage^.item [i].offset, address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE link_parameters.mode OF
          = occ$mc68000 =
            CASE external_linkage^.item [i].kind OF
            = llc$address =
              address^.mc68000_offset := entry_point^.pva.offset;

            = llc$short_address, llc$internal_proc =
              address^.mc68000_short_offset := entry_point^.pva.offset;

            = llc$external_proc =
              address^.mc68000_offset := entry_point^.pva.offset;
              address^.mc68000_binding_section := entry_point^.binding_section.offset;

            = llc$address_addition =
              address^.mc68000_offset := entry_point^.pva.offset + external_linkage^.item [i].offset_operand;

            = llc$address_subtraction =
              address^.mc68000_offset := entry_point^.pva.offset - external_linkage^.item [i].offset_operand;

            CASEND;

          = occ$template =
            CASE external_linkage^.item [i].kind OF
            = llc$address =
              address^.pva := entry_point^.pva;

            = llc$short_address, llc$internal_proc =
              address^.cbp.vmid := v$vmid;
              address^.cbp.epf := (external_linkage^.item [i].kind = llc$short_address);
              address^.cbp.r3 := entry_point^.r3;
              address^.cbp.rn := entry_point^.r1;
              address^.cbp.seg := entry_point^.pva.seg;
              address^.cbp.bn := entry_point^.pva.offset;

            = llc$external_proc =
              address^.cbp.vmid := v$vmid;
              address^.cbp.epf := TRUE;
              address^.cbp.r3 := entry_point^.r3;
              address^.cbp.rn := entry_point^.r1;
              address^.cbp.seg := entry_point^.pva.seg;
              address^.cbp.bn := entry_point^.pva.offset;
              address^.binding_section := entry_point^.binding_section;

            = llc$address_addition =
              address^.pva := entry_point^.pva;
              address^.pva.offset := entry_point^.pva.offset + external_linkage^.item [i].offset_operand;

            = llc$address_subtraction =
              address^.pva := entry_point^.pva;
              address^.pva.offset := entry_point^.pva.offset - external_linkage^.item [i].offset_operand;

            CASEND;

          = occ$product =
            CASE external_linkage^.item [i].kind OF
            = llc$address, llc$address_addition, llc$address_subtraction =
              address^.pva := entry_point^.pva;

              IF (external_linkage^.item [i].kind = llc$address_addition) THEN
                address^.pva.offset := address^.pva.offset + external_linkage^.item [i].offset_operand;
              ELSEIF (external_linkage^.item [i].kind = llc$address_subtraction) THEN
                address^.pva.offset := address^.pva.offset - external_linkage^.item [i].offset_operand;
              IFEND;

              update_number_of_bytes_written ((#OFFSET (address) + 6), v$mdt^.section_table [d].
                    output^.number_of_bytes_written);

              add_to_segments_rel_list (address, v$mdt^.section_table [d].output^.relocation_list, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

            ELSE
              add_item_to_products_adr_list (v$mdt^.section_table [d].pva.seg, #OFFSET (address),
                    external_linkage^.item [i].kind, entry_point^.pva.seg, entry_point^.pva.offset, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            CASEND;

          CASEND;

        FOREND;

      ELSE { Entry point not yet defined }
        external := ^v$unsatisfied_externals;

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

          declaration_matching_passes := FALSE;

        /check_declaration_matching/
          BEGIN
            IF external^.language = external_linkage^.language THEN
              IF NOT (external^.declaration_matching_required AND
                    external_linkage^.declaration_matching_required) THEN
                declaration_matching_passes := TRUE;
                EXIT /check_declaration_matching/;
              IFEND;
              IF external^.language = llc$cybil THEN
                IF link_parameters.cybil_parameter_checking = v$object_type_checking THEN
                  IF external^.declaration_matching.object_encryption =
                        external_linkage^.declaration_matching.object_encryption THEN
                    declaration_matching_passes := TRUE;
                  IFEND;
                ELSE { source type checking
                  IF external^.declaration_matching.source_encryption =
                        external_linkage^.declaration_matching.source_encryption THEN
                    declaration_matching_passes := TRUE;
                  IFEND;
                IFEND;
              ELSE { language is not CYBIL
                IF external^.declaration_matching.language_dependent_value =
                      external_linkage^.declaration_matching.language_dependent_value THEN
                  declaration_matching_passes := TRUE;
                IFEND;
              IFEND;
            IFEND;
          END /check_declaration_matching/;
          IF (external^.name = external_linkage^.name) AND ((external^.r1 = v$mdt^.r1) AND
                (external^.r2 = v$mdt^.r2)) AND (declaration_matching_passes) THEN
            add_to_external_items (external_linkage^.item, external, v$mdt^.name, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            RETURN; { Normal return when this external has been added to an existing external }
          IFEND;
        WHILEND;

        get_next_free_external (external^.link, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        external := external^.link;
        initialize_external_reference (external_linkage, external);

        add_to_external_items (external_linkage^.item, external, v$mdt^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Normal return when a new external has been added to the list

      IFEND;


    PROCEND process_external_linkage_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_relocation_record', EJECT ??

    PROCEDURE process_relocation_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_rel_items: llt$number_of_info_elements;
       VAR status: ost$status);


      VAR
        relocation: ^llt$relocation;


      NEXT relocation: [1 .. number_of_rel_items] IN object_file^.segment.sequence_pointer;
      IF relocation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_relocation_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_binding_template_record', EJECT ??

    PROCEDURE process_binding_template_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        binding_template: ^llt$binding_template;


      NEXT binding_template IN object_file^.segment.sequence_pointer;
      IF binding_template = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_binding_template_record;
?? OLDTITLE ??
?? NEWTITLE := 'proc_obsolete_formal_param_rec', EJECT ??

    PROCEDURE proc_obsolete_formal_param_rec
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters;


      NEXT obsolete_formal_parameters: [[REP sequence_length OF cell]] IN
            object_file^.segment.sequence_pointer;
      IF obsolete_formal_parameters = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND proc_obsolete_formal_param_rec;

?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_formal_parameter', EJECT ??

    PROCEDURE get_next_free_formal_parameter
      (VAR formal_param_definition: ^oct$formal_param_definition;
       VAR status: ost$status);

      IF v$next_free_formal_parameter > occ$number_of_free_formal_param THEN
        NEXT v$free_formal_parameters: [1 .. occ$number_of_free_formal_param] IN ocv$vel_scratch_seq;
        IF v$free_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL2', status);
          RETURN;
        IFEND;

        v$next_free_formal_parameter := 1;
      IFEND;

      formal_param_definition := ^v$free_formal_parameters^ [v$next_free_formal_parameter];
      v$next_free_formal_parameter := v$next_free_formal_parameter + 1;

    PROCEND get_next_free_formal_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_formal_parameters', EJECT ??


    PROCEDURE initialize_formal_parameters
      (    formal_parameters: ^llt$formal_parameters;
       VAR formal_param_definition: ^oct$formal_param_definition);

      VAR
        entry_point: ^oct$entry_points;


      search_entry_point_tree (formal_parameters^.procedure_name, v$mdt^.r1, v$mdt^.r2, entry_point);
      IF entry_point = NIL THEN
        osp$set_status_abnormal (oc, oce$w_duplicate_entry_points, formal_parameters^.procedure_name, status);
        issue_diagnostic (osc$warning_status, status);
        RETURN;
      IFEND;

      formal_param_definition^.defining_module := v$mdt^.name;
      formal_param_definition^.r1 := v$mdt^.r1;
      formal_param_definition^.r2 := v$mdt^.r2;

      IF entry_point^.gated THEN
        formal_param_definition^.r3 := v$mdt^.r3
      ELSE
        formal_param_definition^.r3 := v$mdt^.r2;
      IFEND;

      IF formal_param_definition^.defining_module = 'SYP$SYSTEM_CORE_TRAP_HANDLER' THEN { JFS - Kludge}
        formal_param_definition^.r3 := 0d(16);
      IFEND;

      formal_param_definition^.global_key := v$mdt^.global_key;
      formal_param_definition^.local_key := v$mdt^.local_key;
      formal_param_definition^.l_link := NIL;
      formal_param_definition^.r_link := NIL;
      formal_param_definition^.definition := formal_parameters;

    PROCEND initialize_formal_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'search_formal_param_tree', EJECT ??

    PROCEDURE search_formal_param_tree
      (    name: pmt$program_name;
           r1: ost$ring;
           r2: ost$ring;
       VAR formal_param_definition: ^oct$formal_param_definition);

      formal_param_definition := ^v$formal_param_definitions;

      WHILE formal_param_definition <> NIL DO
        IF (name = formal_param_definition^.defining_module) AND
              (rings_overlap (r1, r2, v$mdt^.r1, v$mdt^.r3)) THEN
          RETURN;

        ELSEIF name < formal_param_definition^.defining_module THEN
          formal_param_definition := formal_param_definition^.l_link;
        ELSE
          formal_param_definition := formal_param_definition^.r_link;
        IFEND;

      WHILEND;
    PROCEND search_formal_param_tree;

?? OLDTITLE ??
?? NEWTITLE := 'add_to_formal_param_tree', EJECT ??

    PROCEDURE add_to_formal_param_tree
      (    formal_param_definition: ^oct$formal_param_definition);

      VAR
        fpd: ^oct$formal_param_definition;


      fpd := ^v$formal_param_definitions;

      WHILE TRUE DO
        IF formal_param_definition^.defining_module < fpd^.defining_module THEN
          IF fpd^.l_link = NIL THEN
            fpd^.l_link := formal_param_definition;
            RETURN;
          ELSE
            fpd := fpd^.l_link;
          IFEND;
        ELSE
          IF fpd^.r_link = NIL THEN
            fpd^.r_link := formal_param_definition;
            RETURN;
          ELSE
            fpd := fpd^.r_link;
          IFEND;
        IFEND;
      WHILEND;

    PROCEND add_to_formal_param_tree;

?? OLDTITLE ??
?? NEWTITLE := 'process_formal_parameter_record', EJECT ??

    PROCEDURE process_formal_parameter_record
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        formal_parameters: ^llt$formal_parameters,
        formal_param_definition: ^oct$formal_param_definition,
        actual_param_before: ^oct$actual_param_group,
        actual: ^oct$actual_param_group,
        list_ptr: ^oct$actual_param_list_item;


      NEXT formal_parameters: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF formal_parameters = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      get_next_free_formal_parameter (formal_param_definition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initialize_formal_parameters (formal_parameters, formal_param_definition);

      add_to_formal_param_tree (formal_param_definition);

{ Satisfy and free any matching externals in the external list

      actual_param_before := ^v$unsatisfied_actual_param;

      WHILE actual_param_before^.link <> NIL DO
        actual := actual_param_before^.link;

        IF (actual^.name = formal_param_definition^.defining_module) AND
              (rings_overlap (actual^.r1, actual^.r2, formal_param_definition^.r1,
              formal_param_definition^.r3)) THEN
          list_ptr := actual^.list;
          WHILE list_ptr <> NIL DO
            fortran_argument_checking (list_ptr^.definition, formal_param_definition);
            list_ptr := list_ptr^.nnext;
          WHILEND;
          actual_param_before^.link := actual^.link;
        ELSE
          actual_param_before := actual;
        IFEND;

      WHILEND;
    PROCEND process_formal_parameter_record;

?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_actual_parameter', EJECT ??

    PROCEDURE get_next_free_actual_parameter
      (VAR actual_param_group: ^oct$actual_param_group;
       VAR status: ost$status);

      IF v$next_free_actual_parameter > occ$number_of_free_actual_param THEN
        NEXT v$free_actual_parameters: [1 .. occ$number_of_free_actual_param] IN ocv$vel_scratch_seq;
        IF v$free_actual_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL2', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$next_free_actual_parameter := 1;
      IFEND;
      actual_param_group := ^v$free_actual_parameters^ [v$next_free_actual_parameter];
      v$next_free_actual_parameter := v$next_free_actual_parameter + 1;

    PROCEND get_next_free_actual_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_actual_parameters', EJECT ??

    PROCEDURE initialize_actual_parameters
      (    actual_parameters: ^llt$actual_parameters;
       VAR actual_param_group: ^oct$actual_param_group);

      VAR
        entry_point: ^oct$entry_points;

      actual_param_group^.name := actual_parameters^.callee_name;
      actual_param_group^.r1 := v$mdt^.r1;
      actual_param_group^.r2 := v$mdt^.r2;

      actual_param_group^.global_key := v$mdt^.global_key;
      actual_param_group^.local_key := v$mdt^.local_key;
      actual_param_group^.link := NIL;
      actual_param_group^.list := NIL;

    PROCEND initialize_actual_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_actual_param_tree', EJECT ??

    PROCEDURE add_to_actual_param_tree
      (    actual_param_group: ^oct$actual_param_group);

      VAR
        apd: ^oct$actual_param_group;

      apd := ^v$actual_param_groups;

      WHILE TRUE DO
        IF actual_param_group^.name < apd^.name THEN
          IF apd^.link = NIL THEN
            apd^.link := actual_param_group;
            RETURN;
          ELSE
            apd := apd^.link;
          IFEND;
        IFEND;
      WHILEND;

    PROCEND add_to_actual_param_tree;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_actual_list', EJECT ??

    PROCEDURE add_to_actual_list
      (    actual_parameters: ^llt$actual_parameters;
       VAR linkage: ^oct$actual_param_list_item;
       VAR status: ost$status);

      VAR
        new_reference: ^oct$actual_param_list_item,
        abort_status: ^ost$status;


      NEXT new_reference IN ocv$vel_scratch_seq;
      IF new_reference = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      new_reference^.definition := actual_parameters;
      new_reference^.nnext := linkage;
      linkage := new_reference;
    PROCEND add_to_actual_list;

?? OLDTITLE ??
?? NEWTITLE := 'process_actual_parameter_record', EJECT ??

    PROCEDURE process_actual_parameter_record
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        actual_parameters: ^llt$actual_parameters,
        duplicate_entry_point: ^oct$entry_points,
        actual_param_group: ^oct$actual_param_group,
        actual_param_group_before: ^oct$actual_param_group,
        linkage: ^oct$param_matching_node,
        formal_param_definition: ^oct$formal_param_definition,
        actual: ^oct$actual_param_group,
        actual_list: ^oct$actual_param_list_item;


      NEXT actual_parameters: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF actual_parameters = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      search_formal_param_tree (actual_parameters^.callee_name, v$mdt^.r1, v$mdt^.r2,
            formal_param_definition);
      IF formal_param_definition <> NIL THEN
        fortran_argument_checking (actual_parameters, formal_param_definition);
      IFEND;

      actual_param_group_before := ^v$unsatisfied_actual_param;

      WHILE actual_param_group_before^.link <> NIL DO
        actual_param_group := actual_param_group_before^.link;

        IF (actual_param_group^.name = actual_parameters^.callee_name) AND
              (actual_param_group^.r1 = v$mdt^.r1) AND (actual_param_group^.r2 = v$mdt^.r2) THEN
          add_to_actual_list (actual_parameters, actual_param_group^.list, status);
          RETURN;
        IFEND;
        actual_param_group_before := actual_param_group;
      WHILEND;

      get_next_free_actual_parameter (actual_param_group, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initialize_actual_parameters (actual_parameters, actual_param_group);

      add_to_actual_list (actual_parameters, actual_param_group^.list, status);

      actual_param_group_before^.link := actual_param_group;

    PROCEND process_actual_parameter_record;
?? OLDTITLE ??
?? NEWTITLE := 'fortran_argument_checking', EJECT ??

    PROCEDURE fortran_argument_checking
      (VAR actual_parameters: ^llt$actual_parameters;
           formal_parameters: ^oct$formal_param_definition);

      TYPE
        formal_type_array = array [llt$fortran_argument_type] of boolean,
        actual_type_array = array [llt$fortran_argument_type] of formal_type_array,
        formal_kind_array = array [llt$fortran_argument_kind] of boolean,
        actual_kind_array = array [llc$fortran_variable .. llc$fortran_array_element] of formal_kind_array,
        formal_usage_array = array [llt$argument_usage] of boolean,
        actual_usage_array = array [llt$argument_usage] of formal_usage_array;

?? FMT (FORMAT := OFF) ??


      VAR
        fortran_argument_type_checking: [STATIC, READ] actual_type_array := [
                    {  L      I      R      DR    COMP   CHAR    B      NT     SL     HR     BIT  }
        {    L   }  [ TRUE,  FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    I   }  [ FALSE, TRUE,  FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    R   }  [ FALSE, FALSE, TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    DR  }  [ FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {   COMP }  [ FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {   CHAR }  [ FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    B   }  [ TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    NT  }  [ TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    SL  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE ],
        {    HR  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE ],
        {   BIT  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE ]];


      VAR
        fortran_argument_kind_checking: [STATIC, READ] actual_kind_array := [
                  {  V      A      X      AE     U    }
        {  V  }   [ TRUE,  FALSE, FALSE, FALSE, TRUE  ],
        {  A  }   [ FALSE, TRUE,  FALSE, FALSE, FALSE ],
        {  X  }   [ FALSE, FALSE, TRUE,  FALSE, TRUE  ],
        {  AE }   [ TRUE,  TRUE,  FALSE, FALSE, TRUE ]];


      VAR
        fortran_argument_usage_checking: [STATIC, READ] actual_usage_array := [

                  {  W      NW  }
        {  W   }  [ TRUE,  TRUE ],
        {  NW  }  [ FALSE, TRUE ]];

  ?? FMT (FORMAT := ON) ??

      VAR
        actual_seq: ^SEQ ( * ),
        formal_seq: ^SEQ ( * ),
        actual_parameter_descriptor: ^llt$fortran_argument_desc,
        formal_parameter_descriptor: ^llt$fortran_argument_desc,
        parameter_number: 0 .. llc$max_fortran_arguments,
        type_valid: boolean,
        kind_valid: boolean,
        usage_valid: boolean,
        valid: boolean,
        actual_length: integer,
        formal_length: integer;


      actual_seq := ^actual_parameters^.specification;
      formal_seq := ^formal_parameters^.definition^.specification;
      RESET actual_seq;
      RESET formal_seq;

      parameter_number := 0;
      NEXT actual_parameter_descriptor IN actual_seq;
      NEXT formal_parameter_descriptor IN formal_seq;

      WHILE (actual_parameter_descriptor <> NIL) AND (formal_parameter_descriptor <> NIL) DO
        type_valid := fortran_argument_type_checking [actual_parameter_descriptor^.argument_type]
              [formal_parameter_descriptor^.argument_type];

        IF NOT type_valid THEN
          osp$set_status_abnormal (oc, oce$invalid_type_matching, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        ELSE
          kind_valid := fortran_argument_kind_checking [actual_parameter_descriptor^.argument_kind]
                [formal_parameter_descriptor^.argument_kind];
          IF NOT kind_valid THEN
            osp$set_status_abnormal (oc, oce$invalid_kind_matching, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          ELSE
            usage_valid := fortran_argument_usage_checking [actual_parameter_descriptor^.mode]
                  [formal_parameter_descriptor^.mode];
            IF NOT usage_valid THEN
              osp$set_status_abnormal (oc, oce$invalid_mode_matching, v$mdt^.name, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND;
        IFEND;

        IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_boolean) THEN
          valid := actual_parameter_descriptor^.string_length.number_of_characters >= 8;
          IF NOT valid THEN
            osp$set_status_abnormal (oc, oce$bad_char_length, actual_parameters^.callee_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  actual_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  formal_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;
        IFEND;

        IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.attributes))
              THEN
          valid := actual_parameter_descriptor^.string_length.number_of_characters >=
                formal_parameter_descriptor^.string_length.number_of_characters;
          IF NOT valid THEN
            osp$set_status_abnormal (oc, oce$bad_char_length, actual_parameters^.callee_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  actual_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  formal_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;
        IFEND;

        IF ((actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_char)) THEN
          IF (((actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                (NOT (llc$fortran_adaptable_array IN actual_parameter_descriptor^.array_size.attributes) AND
                NOT (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.attributes)) OR
                (actual_parameter_descriptor^.argument_kind = llc$fortran_array_element) AND
                (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.
                attributes))) AND (formal_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                (NOT (llc$fortran_adaptable_array IN formal_parameter_descriptor^.array_size.attributes) AND
                NOT (llc$fortran_assumed_len_array IN formal_parameter_descriptor^.array_size.attributes)))
                THEN
            IF actual_parameter_descriptor^.argument_kind = llc$fortran_array THEN
              actual_length := actual_parameter_descriptor^.array_size.number_of_elements *
                    actual_parameter_descriptor^.string_length.number_of_characters;
            ELSE
              actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
            IFEND;

            IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
              formal_length := formal_parameter_descriptor^.array_size.number_of_elements *
                    formal_parameter_descriptor^.string_length.number_of_characters;
            ELSE
              formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
            IFEND;
            valid := actual_length >= formal_length;
            IF NOT valid THEN
              osp$set_status_abnormal (oc, oce$actual_less_than_formal, actual_parameters^.callee_name,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
              osp$append_status_integer (osc$status_parameter_delimiter, actual_length, 10, FALSE, status);
              osp$append_status_integer (osc$status_parameter_delimiter, formal_length, 10, FALSE, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND;
        IFEND;

        IF (actual_parameter_descriptor^.argument_type = llc$fortran_integer) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_integer) THEN

{ The purpose of the following code is to maintain compatibility with binary files
{ compiled before INTEGER*N code is available in FORTRAN.

          IF actual_parameter_descriptor^.string_length.number_of_characters = 0 THEN
            actual_length := 8;
          ELSE
            actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
          IFEND;
          IF formal_parameter_descriptor^.string_length.number_of_characters = 0 THEN
            formal_length := 8;
          ELSE
            formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
          IFEND;

{ End of code to maintain compatibility

          valid := actual_length = formal_length;
          IF NOT valid THEN
            osp$set_status_abnormal (oc, oce$bad_integer_length, v$mdt^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, formal_parameters^.defining_module,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, actual_parameters^.callee_name,
                  status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;
        IFEND;

        IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
          IF llc$fortran_assumed_shape_array IN formal_parameter_descriptor^.array_size.attributes THEN
            IF ((actual_parameter_descriptor^.argument_kind <> llc$fortran_array) OR
                  (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.attributes) OR
                  (formal_parameter_descriptor^.array_size.rank <>
                  actual_parameter_descriptor^.array_size.rank)) THEN
              osp$set_status_abnormal (oc, oce$fortran_array_type_mismatch, v$mdt^.name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, actual_parameters^.callee_name,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          ELSE
            IF (actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                  ((llc$fortran_assumed_shape_array IN actual_parameter_descriptor^.array_size.attributes) OR
                  (llc$fortran_array_section IN actual_parameter_descriptor^.array_size.attributes)) THEN
              osp$set_status_abnormal (oc, oce$fortran_array_type_mismatch, v$mdt^.name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, actual_parameters^.callee_name,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND;
        IFEND;

        NEXT actual_parameter_descriptor IN actual_seq;
        NEXT formal_parameter_descriptor IN formal_seq;
        parameter_number := parameter_number + 1;
      WHILEND;
      IF (actual_parameter_descriptor = NIL) AND (formal_parameter_descriptor <> NIL) THEN
        osp$set_status_abnormal (oc, oce$invalid_mode_matching, 'INVALID_PARAMETERS', status);
        issue_diagnostic (osc$warning_status, status);
      IFEND;
    PROCEND fortran_argument_checking;
?? OLDTITLE ??
?? NEWTITLE := 'process_cybil_symbol_table', EJECT ??

    PROCEDURE process_cybil_symbol_table
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        debug_table_fragment: ^llt$debug_table_fragment;


      NEXT debug_table_fragment: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF debug_table_fragment = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_cybil_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'process_obsolete_line_table', EJECT ??

    PROCEDURE process_obsolete_line_table
      (    object_file: ^oct$object_file_descriptor;
           number_of_line_items: 1 .. llc$max_line_adr_table_size;
       VAR status: ost$status);


      VAR
        obsolete_line_address_table: ^llt$obsolete_line_address_table;


      NEXT obsolete_line_address_table: [1 .. number_of_line_items] IN object_file^.segment.sequence_pointer;
      IF obsolete_line_address_table = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ no further processing is required

    PROCEND process_obsolete_line_table;
?? OLDTITLE ??
?? NEWTITLE := 'process_symbol_table_record', EJECT ??

    PROCEDURE process_symbol_table_record
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        symbol_table: ^llt$symbol_table;


      NEXT symbol_table: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF symbol_table = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_symbol_table_record;

?? OLDTITLE ??
?? NEWTITLE := 'process_supplemental_dtables', EJECT ??

    PROCEDURE process_supplemental_dtables
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        supplemental_debug_tables: ^llt$supplemental_debug_tables;


      NEXT supplemental_debug_tables: [[REP sequence_length OF cell]] IN
            object_file^.segment.sequence_pointer;
      IF supplemental_debug_tables = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_supplemental_dtables;

?? OLDTITLE ??
?? NEWTITLE := 'process_form_def_record', EJECT ??

    PROCEDURE process_form_def_record
      (VAR status: ost$status);

      VAR
        module_name: pmt$program_name;

      osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, v$mdt^.name, status);
      issue_diagnostic (osc$fatal_status, status);
      RETURN;
    PROCEND process_form_def_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_line_table_record', EJECT ??

    PROCEDURE process_line_table_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_line_items: 1 .. llc$max_line_adr_table_size;
       VAR status: ost$status);


      VAR
        line_address_table: ^llt$line_address_table;


      NEXT line_address_table: [1 .. number_of_line_items] IN object_file^.segment.sequence_pointer;
      IF line_address_table = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ no further processing is required

    PROCEND process_line_table_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_68000_absolute', EJECT ??

    PROCEDURE process_68000_absolute
      (    object_file: ^oct$object_file_descriptor;
           number_of_68000_bytes: 1 .. llc$maximum_68000_address;
       VAR status: ost$status);


      VAR
        m68000_absolute: ^llt$68000_absolute;


      NEXT m68000_absolute: [[REP number_of_68000_bytes OF cell]] IN object_file^.segment.sequence_pointer;
      IF m68000_absolute = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ no further process is required

    PROCEND process_68000_absolute;
?? OLDTITLE ??
?? NEWTITLE := 'process_transfer_symbol_record', EJECT ??

    PROCEDURE process_transfer_symbol_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        transfer_symbol: ^llt$transfer_symbol,
        i: integer;


      NEXT transfer_symbol IN object_file^.segment.sequence_pointer;
      IF transfer_symbol = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF transfer_symbol^.name <> osc$null_name THEN
        v$last_starting_procedure := transfer_symbol^.name;
      IFEND;

      IF v$generate_debug_tables THEN
        ocp$dtb_terminate_module (status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;

{ Store module's binding section offset with each code segment

      IF (link_parameters.mode = occ$product) AND (v$mdt^.binding_section_encountered) THEN
        FOR i := 0 TO UPPERBOUND (v$mdt^.section_table) DO
          IF (v$mdt^.section_table [i].definition.kind = llc$code_section) THEN
            v$mdt^.section_table [i].output^.binding_section_encountered := TRUE;
            v$mdt^.section_table [i].output^.binding_section_segment := v$mdt^.binding_section.seg;
            v$mdt^.section_table [i].output^.binding_section_offset := v$mdt^.binding_section.offset;
          IFEND;
        FOREND;
      IFEND;


    PROCEND process_transfer_symbol_record;
?? OLDTITLE ??
?? NEWTITLE := 'include_object_module', EJECT ??

    PROCEDURE include_object_module
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        module_kind: llt$module_kind;


      v$record_number := 1;

      process_identification_record (object_file, module_kind, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF module_kind = llc$iou THEN
        v$record_number := v$record_number + 1;

        process_ppu_absolute_record (object_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
        CASE link_parameters.mode OF
        = occ$template, occ$product =
          IF (module_kind = llc$vector_virtual_state) OR (module_kind = llc$vector_extended_state) THEN
            v$module_kind := module_kind;
          IFEND;
        = occ$mc68000 =
          ;
        CASEND;

        REPEAT
          v$record_number := v$record_number + 1;

          NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          CASE object_text_descriptor^.kind OF
          = llc$identification =
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'Duplicate identification record encountered', status);
            issue_diagnostic (osc$fatal_status, status);
          = llc$ppu_absolute =
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'PPU absolute recored encountered in CPU object module', status);
            issue_diagnostic (osc$fatal_status, status);
          = llc$application_identifier =
            process_application_id_record (object_file, status);
          = llc$libraries =
            process_libraries_record (object_file, object_text_descriptor^.number_of_libraries, status);
          = llc$section_definition =
            process_section_definition (object_file, FALSE, 0, status);
          = llc$unallocated_common_block =
            IF (link_parameters.mode = occ$product) THEN
              process_section_definition (object_file, TRUE, 0, status);
            ELSE
              osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'Unallocated common block in non-product link', status);
              issue_diagnostic (osc$fatal_status, status);
            IFEND;
          = llc$allotted_section_definition =
            process_section_definition (object_file, FALSE, object_text_descriptor^.allotted_section, status);
          = llc$text =
            process_text_record (object_file, object_text_descriptor^.number_of_bytes, status);
          = llc$replication =
            process_replication_record (object_file, object_text_descriptor^.number_of_bytes, status);
          = llc$bit_string_insertion =
            process_bit_insertion_record (object_file, status);
          = llc$address_formulation =
            process_address_formulation_rec (object_file, object_text_descriptor^.number_of_adr_items,
                  status);
          = llc$entry_definition =
            process_entry_definition_record (object_file, status);
          = llc$external_linkage =
            process_external_linkage_record (object_file, object_text_descriptor^.number_of_ext_items,
                  status);
          = llc$relocation =
            process_relocation_record (object_file, object_text_descriptor^.number_of_rel_items, status);
          = llc$binding_template =
            process_binding_template_record (object_file, status);
          = llc$obsolete_formal_parameters =
            proc_obsolete_formal_param_rec (object_file, object_text_descriptor^.sequence_length, status);
          = llc$formal_parameters =
            process_formal_parameter_record (object_file, object_text_descriptor^.sequence_length, status);
          = llc$actual_parameters =
            process_actual_parameter_record (object_file, object_text_descriptor^.sequence_length, status);
          = llc$cybil_symbol_table_fragment =
            process_cybil_symbol_table (object_file, object_text_descriptor^.sequence_length, status);
          = llc$obsolete_line_table =
            process_obsolete_line_table (object_file, object_text_descriptor^.number_of_line_items, status);
          = llc$symbol_table =
            process_symbol_table_record (object_file, object_text_descriptor^.sequence_length, status);
          = llc$line_table =
            process_line_table_record (object_file, object_text_descriptor^.number_of_line_items, status);
          = llc$supplemental_debug_tables =
            process_supplemental_dtables (object_file, object_text_descriptor^.sequence_length, status);
          = llc$form_definition =
            process_form_def_record (status);
          = llc$68000_absolute =
            process_68000_absolute (object_file, object_text_descriptor^.number_of_68000_bytes, status);
          = llc$transfer_symbol =
            process_transfer_symbol_record (object_file, status);
          ELSE
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Unknown object record kind',
                  status);
            issue_diagnostic (osc$fatal_status, status);
          CASEND;

          IF NOT status.normal THEN
            RETURN;
          IFEND;

        UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

      IFEND;
      IF pmc$entry_point_map IN link_parameters.map_options THEN
        print_external_names (v$mdt^.external_names);
      IFEND;


    PROCEND include_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'include_load_module', EJECT ??

    PROCEDURE include_load_module
      (    object_library: ^oct$object_file_descriptor;
           module_header: REL (llt$object_library) ^llt$load_module_header;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        load_module_header: ^llt$load_module_header,
        info_element_header: ^llt$info_element_header;


      load_module_header := #PTR (module_header, object_library^.segment.sequence_pointer^);
      IF load_module_header = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_library^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      object_text_descriptor := #PTR (load_module_header^.interpretive_element,
            object_library^.segment.sequence_pointer^);
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_library^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      RESET object_library^.segment.sequence_pointer TO object_text_descriptor;

      include_object_module (object_library, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF v$generate_debug_tables THEN
        IF llc$information_element IN load_module_header^.elements_defined THEN
          info_element_header := #PTR (load_module_header^.information_element,
                object_library^.segment.sequence_pointer^);

          IF ((info_element_header <> NIL) AND (info_element_header^.version = llc$info_element_version) AND
                (info_element_header^.number_of_section_maps <> 0)) THEN
            ocp$dtb_redefine_module (info_element_header, object_library^.segment.sequence_pointer, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;


    PROCEND include_load_module;
?? OLDTITLE ??
?? NEWTITLE := 'include_object_file', EJECT ??

    PROCEDURE include_object_file
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor;


      RESET object_file^.segment.sequence_pointer;

      NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$w_no_modules_on_file, object_file^.name^, status);
        issue_diagnostic (osc$warning_status, status);
        RETURN;
      IFEND;

      REPEAT
        RESET object_file^.segment.sequence_pointer TO object_text_descriptor;

        include_object_module (object_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;

      UNTIL object_text_descriptor = NIL;


    PROCEND include_object_file;
?? OLDTITLE ??
?? NEWTITLE := 'include_object_library', EJECT ??

    PROCEDURE include_object_library
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        i: 0 .. llc$max_modules_in_library;


      IF object_file^.module_dictionary <> NIL THEN
        FOR i := 1 TO UPPERBOUND (object_file^.module_dictionary^) DO
          IF object_file^.module_dictionary^ [i].kind <> llc$load_module THEN
            IF object_file^.module_dictionary^ [i].kind <> llc$message_module THEN
              osp$set_status_abnormal (oc, oce$w_module_not_included, object_file^.module_dictionary^ [i].
                    name, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          ELSE
            include_load_module (object_file, object_file^.module_dictionary^ [i].module_header, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          IFEND;
        FOREND;
      IFEND;


    PROCEND include_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'add_object_files', EJECT ??

    PROCEDURE add_object_files
      (    object_files_to_add: oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_file: ^oct$object_file_descriptor;


      object_file := object_files_to_add.link;

      WHILE object_file <> NIL DO
        IF object_file^.is_a_library THEN
          include_object_library (object_file, status);
        ELSE
          include_object_file (object_file, status);
        IFEND;

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        object_file := object_file^.link;
      WHILEND;


    PROCEND add_object_files;
?? OLDTITLE ??
?? NEWTITLE := 'add_object_modules', EJECT ??

    PROCEDURE add_object_modules
      (    modules_to_add: oct$program_name_list;
           object_libraries_to_use: oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_library: ^oct$object_file_descriptor,
        module_found: boolean,
        new_module: ^oct$program_name_list,
        module_before: ^oct$program_name_list,
        i: 0 .. llc$max_modules_in_library;


      IF modules_to_add.link = NIL THEN
        RETURN;
      IFEND;


      object_library := object_libraries_to_use.link;

      WHILE object_library <> NIL DO

        IF object_library^.module_dictionary <> NIL THEN
          FOR i := 1 TO UPPERBOUND (object_library^.module_dictionary^) DO
            IF object_library^.module_dictionary^ [i].kind = llc$load_module THEN
              ocp$search_modules_to_add (v$modules_to_add, object_library^.module_dictionary^ [i].name,
                    module_found, module_before);
              IF module_found THEN
                include_load_module (object_library, object_library^.module_dictionary^ [i].module_header,
                      status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                module_before^.link := module_before^.link^.link;
                IF modules_to_add.link = NIL THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

        object_library := object_library^.link;
      WHILEND;

    PROCEND add_object_modules;
?? OLDTITLE ??
?? NEWTITLE := 'satisfy_externals', EJECT ??

    PROCEDURE satisfy_externals
      (    object_libraries_to_use: oct$object_file_descriptor;
       VAR status: ost$status);


?? NEWTITLE := 'add_to_library_entry_points', EJECT ??

      PROCEDURE add_to_library_entry_points
        (    entry_point: ^oct$library_entry_points;
         VAR library_entry_points: oct$library_entry_points);


        VAR
          ept: ^oct$library_entry_points;


        ept := ^library_entry_points;

        WHILE TRUE DO
          IF entry_point^.name < ept^.name THEN
            IF ept^.l_link = NIL THEN
              ept^.l_link := entry_point;
              RETURN;
            ELSE
              ept := ept^.l_link;
            IFEND;

          ELSE
            IF ept^.r_link = NIL THEN
              ept^.r_link := entry_point;
              RETURN;
            ELSE
              ept := ept^.r_link;
            IFEND;

          IFEND;
        WHILEND;


      PROCEND add_to_library_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'collect_library_entry_points', EJECT ??

      PROCEDURE collect_library_entry_points
        (    object_library_to_use: oct$object_file_descriptor;
         VAR library_entry_points: oct$library_entry_points;
         VAR status: ost$status);


        VAR
          r3: ost$ring,
          i: llt$entry_point_index,
          object_library: ^oct$object_file_descriptor,
          entry_point: ^oct$library_entry_points;


        library_entry_points.name := osc$null_name;
        library_entry_points.l_link := NIL;
        library_entry_points.r_link := NIL;

        object_library := object_libraries_to_use.link;

        WHILE object_library <> NIL DO
          IF object_library^.entry_point_dictionary <> NIL THEN
            FOR i := 1 TO UPPERBOUND (object_library^.entry_point_dictionary^) DO
              IF object_library^.entry_point_dictionary^ [i].module_kind = llc$load_module THEN
                NEXT entry_point IN ocv$vel_scratch_seq;
                IF entry_point = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL16', status);
                  RETURN;
                IFEND;

                entry_point^.name := object_library^.entry_point_dictionary^ [i].name;
                entry_point^.r1 := object_library^.r1;

                IF object_library^.entry_point_dictionary^ [i].kind = llc$gate THEN
                  entry_point^.r3 := object_library^.r3;
                ELSE
                  entry_point^.r3 := object_library^.r2;
                IFEND;

                entry_point^.object_library := object_library;
                entry_point^.load_module_header := object_library^.entry_point_dictionary^ [i].module_header;
                entry_point^.l_link := NIL;
                entry_point^.r_link := NIL;

                add_to_library_entry_points (entry_point, library_entry_points);
              IFEND;
            FOREND;
          IFEND;

          object_library := object_library^.link;
        WHILEND;
      PROCEND collect_library_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'search_library_entry_points', EJECT ??

      PROCEDURE search_library_entry_points
        (    external: ^oct$ext_reference_list;
         VAR library_entry_points: oct$library_entry_points;
         VAR entry_point: ^oct$library_entry_points);


        entry_point := ^library_entry_points;

        WHILE entry_point <> NIL DO
          IF (external^.name = entry_point^.name) AND (rings_overlap
                (external^.r1, external^.r2, entry_point^.r1, entry_point^.r3)) THEN
            RETURN;

          ELSEIF external^.name < entry_point^.name THEN
            entry_point := entry_point^.l_link;
          ELSE
            entry_point := entry_point^.r_link;
          IFEND;

        WHILEND;


      PROCEND search_library_entry_points;
?? OLDTITLE ??
?? EJECT ??

      VAR
        library_entry_points: oct$library_entry_points,
        entry_point: ^oct$library_entry_points,
        external: ^oct$ext_reference_list,
        external_found: boolean;


      collect_library_entry_points (object_libraries_to_use, library_entry_points, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      external := ^v$unsatisfied_externals;

      WHILE external^.link <> NIL DO
        search_library_entry_points (external^.link, library_entry_points, entry_point);

        IF entry_point <> NIL THEN
          include_load_module (entry_point^.object_library, entry_point^.load_module_header, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          external := external^.link;
        IFEND;
      WHILEND;

    PROCEND satisfy_externals;
?? OLDTITLE ??
?? NEWTITLE := 'clean_up_residue_diagnostics', EJECT ??

    PROCEDURE clean_up_residue_diagnostics;


      VAR
        defer_common_blocks: ^oct$defer_list,
        defer_entry_points: ^oct$defer_list,
        entry_point: ^oct$entry_points,
        external: ^oct$ext_reference_list,
        header_printed: boolean,
        modules: ^oct$program_name_list;


      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        header_printed := FALSE;

        entry_point := ^v$entry_points;

        WHILE entry_point <> NIL DO
          IF entry_point^.ring_violation THEN
            IF NOT header_printed THEN
              ocp$generate_link_map_text (v$lm_page_header);
              space (2);
            IFEND;
            osp$set_status_abnormal (oc, oce$w_ring_violation, entry_point^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

          entry_point := entry_point^.link;
        WHILEND;

        IF v$modules_to_add.link <> NIL THEN
          IF NOT header_printed THEN
            ocp$generate_link_map_text (v$lm_page_header);
            space (2);
          IFEND;

          modules := v$modules_to_add.link;

          WHILE modules <> NIL DO
            osp$set_status_abnormal (oc, oce$w_unsatisfied_module, modules^.name, status);
            issue_diagnostic (osc$warning_status, status);

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


        IF v$unsatisfied_externals.link <> NIL THEN
          IF NOT header_printed THEN
            ocp$generate_link_map_text (v$lm_page_header);
            space (2);
          IFEND;

          external := v$unsatisfied_externals.link;

          WHILE external <> NIL DO
            osp$set_status_abnormal (oc, oce$w_unsatisfied_external, external^.name, status);
            issue_diagnostic (osc$warning_status, status);

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

        IF (link_parameters.defer_entry_points <> NIL) THEN
          IF (link_parameters.defer_entry_points^.defer = occ$defer) OR
                (link_parameters.defer_entry_points^.defer = occ$defer_all_except) THEN
            defer_entry_points := link_parameters.defer_entry_points^.name_list;
            WHILE defer_entry_points <> NIL DO
              IF NOT defer_entry_points^.name_found THEN
                osp$set_status_abnormal (oc, oce$deferred_entry_pt_not_found, defer_entry_points^.name,
                      status);
                issue_diagnostic (osc$warning_status, status);
              IFEND;
              defer_entry_points := defer_entry_points^.link;
            WHILEND;
          IFEND;
        IFEND;

        IF (link_parameters.defer_common_blocks <> NIL) THEN
          IF (link_parameters.defer_common_blocks^.defer = occ$defer) OR
                (link_parameters.defer_common_blocks^.defer = occ$defer_all_except) THEN
            defer_common_blocks := link_parameters.defer_common_blocks^.name_list;
            WHILE defer_common_blocks <> NIL DO
              IF NOT defer_common_blocks^.name_found THEN
                osp$set_status_abnormal (oc, oce$deferred_com_blk_not_found, defer_common_blocks^.name,
                      status);
                issue_diagnostic (osc$warning_status, status);
              IFEND;
              defer_common_blocks := defer_common_blocks^.link;
            WHILEND;
          IFEND;
        IFEND;
      IFEND;

      search_entry_point_tree (v$starting_procedure, osc$invalid_ring, osc$max_ring, v$starting_entry_point);

      IF v$starting_entry_point = NIL THEN
        space (2);

        osp$set_status_condition (oce$w_no_starting_procedure, status);
        issue_diagnostic (osc$warning_status, status);

        v$starting_entry_point := ^v$entry_points;
        v$starting_entry_point^.name := osc$null_name;
        v$starting_entry_point^.pva.ring := osc$invalid_ring;
        v$starting_entry_point^.pva.seg := 0;
        v$starting_entry_point^.pva.offset := 0;
        v$starting_entry_point^.binding_section.ring := osc$invalid_ring;
        v$starting_entry_point^.binding_section.seg := 0;
        v$starting_entry_point^.binding_section.offset := 0;
      IFEND;


    PROCEND clean_up_residue_diagnostics;
?? OLDTITLE ??
?? NEWTITLE := 'generate_outboard_symbol_table', EJECT ??

    PROCEDURE generate_outboard_symbol_table
      (VAR status: ost$status);


      VAR
        symbol_table: ^SEQ ( * ),
        number_of_outboard_symbols: integer,
        outboard_symbol: ^oct$entry_points,
        entry_point: ^oct$entry_points;


      symbol_table := ocv$vel_scratch_seq;
      number_of_outboard_symbols := 0;
      entry_point := v$entry_points.link;

      WHILE entry_point <> NIL DO
        IF (link_parameters.linked_symbols = 'ALL ') OR ((entry_point^.gated) AND
              (entry_point^.r3 >= link_parameters.gate_ring_level)) THEN
          NEXT outboard_symbol IN symbol_table;
          IF outboard_symbol = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL19', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          outboard_symbol^ := entry_point^;
          number_of_outboard_symbols := number_of_outboard_symbols + 1;
        IFEND;

        entry_point := entry_point^.link;
      WHILEND;

      IF number_of_outboard_symbols <> 0 THEN
        NEXT v$outboard_symbol_table: [1 .. number_of_outboard_symbols] IN ocv$vel_scratch_seq;
      ELSE
        v$outboard_symbol_table := NIL;
      IFEND;


    PROCEND generate_outboard_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'get_pointer_location', EJECT ??

    PROCEDURE get_pointer_location
      (    name: pmt$program_name;
       VAR location: ^cell);


      VAR
        valid_position: boolean,
        entry_point: ^oct$entry_points,
        output: ^oct$output_segment_descriptor,
        segment: ^SEQ ( * ),
        sequence_pointer: ost$segment_offset;


      search_entry_point_tree (name, osc$invalid_ring, osc$max_ring, entry_point);

      IF entry_point = NIL THEN
        location := NIL;

      ELSE
        output := v$output_segment_list.link;

        WHILE output^.number <> entry_point^.pva.seg DO
          output := output^.link;
        WHILEND;

        segment := output^.segment.sequence_pointer;
        pmp$position_object_library (segment, entry_point^.pva.offset, valid_position);
        IF NOT valid_position THEN
          location := NIL;
          RETURN;
        IFEND;

        NEXT location IN segment;

      IFEND;


    PROCEND get_pointer_location;
?? OLDTITLE ??
?? NEWTITLE := 'get_value_segment', EJECT ??

    PROCEDURE get_value_segment
      (    pointer: ^oct$pointer_list;
       VAR segment: ^oct$output_segment_descriptor);


      VAR
        section_name: ^oct$section_name_list;


      IF pointer^.section_name <> osc$null_name THEN
        section_name := v$section_name_list.link;

        WHILE section_name <> NIL DO
          IF (section_name^.name = pointer^.section_name) AND
                (section_name^.segment_descriptor^.extensible_attribute <> occ$allocated_extensible) THEN
            segment := section_name^.segment_descriptor;
            RETURN;
          IFEND;

          section_name := section_name^.link;
        WHILEND;

        segment := NIL;

      ELSE
        segment := v$output_segment_list.link;

        WHILE segment <> NIL DO
          IF (segment^.number = pointer^.segment_number) AND
                (segment^.extensible_attribute <> occ$allocated_extensible) THEN
            RETURN;
          IFEND;

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

      osp$set_status_abnormal (oc, oce$e_section_or_seg_not_found, pointer^.name, status);
      issue_diagnostic (osc$error_status, status);


    PROCEND get_value_segment;
?? OLDTITLE ??
?? NEWTITLE := 'turn_declaration_matching_off', EJECT ??

{ PURPOSE:
{   This procedure sets DECLARATION_MATCHING_REQUIRED to FALSE for
{   task services entry points (TSEP) specified by the DELETE_DECLARATION_MATCHING
{   program name list.

    PROCEDURE turn_declaration_matching_off
      (    delete_declaration_matching: oct$program_name_list;
       VAR tsep: ^array [1 .. * ] of oct$task_services_entry_point);

      VAR
        temp: integer,
        entry_point_found: boolean,
        entry_point_list: ^oct$program_name_list,
        hi: 0 .. occ$maximum_externals,
        lo: 0 .. occ$maximum_externals,
        mid: 0 .. occ$maximum_externals,
        status: ost$status;

      entry_point_list := delete_declaration_matching.link;

      WHILE entry_point_list <> NIL DO
        hi := UPPERBOUND (tsep^);
        lo := 1;
        entry_point_found := FALSE;

        WHILE (lo <= hi) AND NOT entry_point_found DO
          temp := lo + hi;
          mid := temp DIV 2;
          IF entry_point_list^.name = tsep^ [mid].ep.name THEN
            entry_point_found := TRUE;
            tsep^ [mid].ep.declaration_matching_required := FALSE;
          ELSEIF entry_point_list^.name < tsep^ [mid].ep.name THEN
            hi := mid - 1;
          ELSE
            lo := mid + 1;
          IFEND;
        WHILEND;

        IF NOT entry_point_found THEN
          osp$set_status_abnormal (oc, oce$w_name_not_in_symbol_table, entry_point_list^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        entry_point_list := entry_point_list^.link;
      WHILEND;
    PROCEND turn_declaration_matching_off;
?? OLDTITLE ??
?? NEWTITLE := 'heap_sort_entry_points', EJECT ??

    PROCEDURE heap_sort_entry_points
      (    entry_points: ^array [1 .. * ] of oct$task_services_entry_point);


      VAR
        left: integer,
        right: integer,
        i: integer,
        j: integer,
        number: integer,
        temp: oct$task_services_entry_point,
        key: pmt$program_name;


      number := UPPERBOUND (entry_points^);

      IF (number = 1) THEN
        RETURN;
      ELSEIF (number = 2) THEN
        IF (entry_points^ [1].ep.name > entry_points^ [2].ep.name) THEN
          temp := entry_points^ [1];
          entry_points^ [1] := entry_points^ [2];
          entry_points^ [2] := temp;
        IFEND;
        RETURN;
      IFEND;

      left := (number DIV 2) + 1;
      right := number;

    /outer_loop/
      WHILE (TRUE) DO
        IF (left > 1) THEN
          left := left - 1;
          temp := entry_points^ [left];
          key := entry_points^ [left].ep.name;
        ELSE
          temp := entry_points^ [right];
          key := entry_points^ [right].ep.name;
          entry_points^ [right] := entry_points^ [1];
          right := right - 1;
          IF (right = 1) THEN
            entry_points^ [right] := temp;
            RETURN;
          IFEND;
        IFEND;

        j := left;

      /inner_loop/
        WHILE (TRUE) DO
          i := j;
          j := j + j;

          IF (j < right) THEN
            IF (entry_points^ [j].ep.name < entry_points^ [j + 1].ep.name) THEN
              j := j + 1;
            IFEND;
          ELSEIF (j > right) THEN
            EXIT /inner_loop/;
          IFEND;

          IF (key >= entry_points^ [j].ep.name) THEN
            EXIT /inner_loop/;
          IFEND;

          entry_points^ [i] := entry_points^ [j];
        WHILEND /inner_loop/;

        entry_points^ [i] := temp;
      WHILEND /outer_loop/;


    PROCEND heap_sort_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'build_task_services_entry_pnts', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build an array of task services entry
{   points from the outboard symbol table, to sort it in alphabetical order,
{   and to turn declaration matching off for specified entry points.

    PROCEDURE build_task_services_entry_pnts
      (    delete_declaration_matching: oct$program_name_list;
       VAR tsep: ^array [1 .. * ] of oct$task_services_entry_point;
       VAR status: ost$status);


      VAR
        i: integer;

      status.normal := TRUE;

      IF v$outboard_symbol_table = NIL THEN
        tsep := NIL;
        RETURN;
      IFEND;

      NEXT tsep: [1 .. UPPERBOUND (v$outboard_symbol_table^)] IN ocv$vel_scratch_seq;
      IF tsep = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL20', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      FOR i := 1 TO UPPERBOUND (tsep^) DO
        tsep^ [i].ep.name := v$outboard_symbol_table^ [i].name;
        tsep^ [i].ep.address.ring := v$outboard_symbol_table^ [i].pva.ring;
        tsep^ [i].ep.address.segment := v$outboard_symbol_table^ [i].pva.seg;
        tsep^ [i].ep.address.offset := v$outboard_symbol_table^ [i].pva.offset;
        tsep^ [i].ep.binding_section_address.ring := v$outboard_symbol_table^ [i].binding_section.ring;
        tsep^ [i].ep.binding_section_address.segment := v$outboard_symbol_table^ [i].binding_section.seg;
        tsep^ [i].ep.binding_section_address.offset := v$outboard_symbol_table^ [i].binding_section.offset;
        tsep^ [i].ep.gated := v$outboard_symbol_table^ [i].gated;
        tsep^ [i].ep.global_lock := v$outboard_symbol_table^ [i].global_key;
        tsep^ [i].ep.r1 := v$outboard_symbol_table^ [i].r1;
        tsep^ [i].ep.r2 := v$outboard_symbol_table^ [i].r2;
        tsep^ [i].ep.r3 := v$outboard_symbol_table^ [i].r3;
        tsep^ [i].ep.vmid := v$vmid;
        tsep^ [i].ep.declaration_matching_required := v$outboard_symbol_table^ [i].
              declaration_matching_required;
        tsep^ [i].ep.declaration_matching := v$outboard_symbol_table^ [i].declaration_matching;
        tsep^ [i].ep.language := v$outboard_symbol_table^ [i].language;
        tsep^ [i].fill := 0;
      FOREND;

      heap_sort_entry_points (tsep);

      IF delete_declaration_matching.link <> NIL THEN
        turn_declaration_matching_off (delete_declaration_matching, tsep);
      IFEND;

    PROCEND build_task_services_entry_pnts;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_symbol_table_ptrs', EJECT ??

    PROCEDURE initialize_symbol_table_ptrs
      (    symbol_table_pointers: oct$pointer_list;
           delete_declaration_matching: oct$program_name_list;
       VAR status: ost$status);


      VAR
        pointer: ^oct$pointer_list,

        tsep: ^array [1 .. * ] of oct$task_services_entry_point,

        symbol_table: ^array [1 .. * ] of oct$task_services_entry_point,
        symbol_table_pointer: ^cell,

        valid_position: boolean,
        sequence_pointer: ost$segment_offset,

        symbol_table_segment: ^oct$output_segment_descriptor;

      status.normal := TRUE;

      IF symbol_table_pointers.link = NIL THEN
        IF delete_declaration_matching.link <> NIL THEN
          osp$set_status_condition (oce$w_must_include_symbols, status);
          issue_diagnostic (osc$warning_status, status);
          status.normal := TRUE;
        IFEND;
        RETURN;
      IFEND;

      build_task_services_entry_pnts (delete_declaration_matching, tsep, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pointer := symbol_table_pointers.link;

      WHILE pointer <> NIL DO
        get_pointer_location (pointer^.name, symbol_table_pointer);

        IF symbol_table_pointer <> NIL THEN
          IF tsep = NIL THEN
            build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, symbol_table_pointer);

          ELSE
            get_value_segment (pointer, symbol_table_segment);

            IF symbol_table_segment <> NIL THEN
              sequence_pointer := i#current_sequence_position (symbol_table_segment^.segment.
                    sequence_pointer);
              sequence_pointer := ((sequence_pointer + 7) DIV 8) * 8;
              pmp$position_object_library (symbol_table_segment^.segment.sequence_pointer, sequence_pointer,
                    valid_position);
              IF NOT valid_position THEN
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL239', status);
                build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, symbol_table_pointer);
                issue_diagnostic (osc$error_status, status);
              ELSE
                build_adaptable_array_pointer (symbol_table_segment^.r2, symbol_table_segment^.number,
                      sequence_pointer, #SIZE (tsep^), 1, #SIZE (oct$task_services_entry_point),
                      symbol_table_pointer);

                NEXT symbol_table: [1 .. UPPERBOUND (tsep^)] IN
                      symbol_table_segment^.segment.sequence_pointer;
                IF symbol_table = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL239', status);
                  build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0,
                        symbol_table_pointer);
                  issue_diagnostic (osc$error_status, status);

                ELSE
                  syp$advised_move_bytes (#LOC (tsep^), #LOC (symbol_table^), #SIZE (symbol_table^), status);
                  IF NOT status.normal THEN
                    issue_diagnostic (osc$fatal_status, status);
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        pointer := pointer^.link;
      WHILEND;


    PROCEND initialize_symbol_table_ptrs;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_recovery_name_table', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build a table of names and addresses
{   that will be used when the system being linked is being recovered.
{
{ NOTES:
{   The recovery name table is currently not implemented anywhere but in the linker.

    PROCEDURE initialize_recovery_name_table
      (    name_table: oct$pointer_list;
           addresses: oct$program_name_list;
       VAR status: ost$status);


      VAR
        name_table_pointer: ^oct$array_pointer,
        name_table_segment: ^oct$output_segment_descriptor,
        recovery_name_table: ^dst$recovery_name_table,
        sequence_pointer: ost$segment_offset,
        valid_position: boolean,
        address: ^oct$program_name_list,
        recovery_address: ^dst$recovery_address,
        number_of_addresses: integer,
        entry_point: ^oct$entry_points,
        pva: ^ost$pva;


      IF name_table.name = osc$null_name THEN
        RETURN;
      IFEND;

      get_pointer_location (name_table.name, name_table_pointer);
      IF name_table_pointer = NIL THEN
        RETURN;
      IFEND;

      IF addresses.link = NIL THEN
        build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, name_table_pointer);
        RETURN;
      IFEND;

      get_value_segment (^name_table, name_table_segment);
      IF name_table_segment = NIL THEN
        RETURN;
      IFEND;

      sequence_pointer := i#current_sequence_position (name_table_segment^.segment.sequence_pointer);
      sequence_pointer := ((sequence_pointer + 7) DIV 8) * 8;

      pmp$position_object_library (name_table_segment^.segment.sequence_pointer, sequence_pointer,
            valid_position);
      IF NOT valid_position THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL123', status);
        issue_diagnostic (osc$error_status, status);
        build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, name_table_pointer);
        RETURN;
      IFEND;

      number_of_addresses := 0;
      address := addresses.link;

      WHILE address <> NIL DO
        NEXT recovery_address IN name_table_segment^.segment.sequence_pointer;
        IF recovery_address = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL123', status);
          issue_diagnostic (osc$error_status, status);
          build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, name_table_pointer);
          RETURN;
        IFEND;

        recovery_address^.name := address^.name;
        search_entry_point_tree (address^.name, osc$invalid_ring, osc$max_ring, entry_point);

        IF entry_point = NIL THEN
          recovery_address^.address := NIL;
        ELSE
          pva := #LOC (recovery_address^.address);
          pva^ := entry_point^.pva;
          IF entry_point^.declaration_matching_required THEN
            recovery_address^.verification := entry_point^.declaration_matching;
          ELSE
            recovery_address^.verification.language_dependent_value := 0;
          IFEND;
        IFEND;

        number_of_addresses := number_of_addresses + 1;
        address := address^.link;
      WHILEND;

      build_adaptable_array_pointer (name_table_segment^.r2, name_table_segment^.number, sequence_pointer,
            (number_of_addresses * #SIZE (dst$recovery_address)), 1, #SIZE (dst$recovery_address),
            name_table_pointer);


    PROCEND initialize_recovery_name_table;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_heap_pointers', EJECT ??

    PROCEDURE initialize_heap_pointers
      (    heap_pointers: oct$pointer_list;
       VAR status: ost$status);


      VAR
        offset: integer,
        length: integer,
        pointer: ^oct$pointer_list,
        heap_segment: ^oct$output_segment_descriptor,
        sequence_pointer: ost$segment_offset,
        valid_position: boolean,
        heap_pointer: ^oct$heap_pointer;


      pointer := heap_pointers.link;

      WHILE pointer <> NIL DO
        get_pointer_location (pointer^.name, heap_pointer);

        IF heap_pointer <> NIL THEN
          get_value_segment (pointer, heap_segment);

          IF heap_segment <> NIL THEN
            sequence_pointer := i#current_sequence_position (heap_segment^.segment.sequence_pointer);

            offset := ((sequence_pointer + 31) DIV 32) * 32;
            length := (osc$max_segment_length - 1) - offset;

            IF length <= 0 THEN
              osp$set_status_abnormal (oc, oce$e_section_or_seg_not_found, pointer^.name, status);
              issue_diagnostic (osc$error_status, status);

            ELSE
              heap_pointer^.pva.ring := heap_segment^.r1;
              heap_pointer^.pva.seg := heap_segment^.number;
              heap_pointer^.pva.offset := offset;

              heap_segment^.used_attributes := heap_segment^.used_attributes +
                    $oct$segment_attributes [occ$sa_extensible];
              heap_segment^.extensible_attribute := occ$allocated_extensible;
              pmp$position_object_library (heap_segment^.segment.sequence_pointer, offset, valid_position);
              IF NOT valid_position THEN
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, pointer^.name, status);
                issue_diagnostic (osc$fatal_status, status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        pointer := pointer^.link;
      WHILEND;


    PROCEND initialize_heap_pointers;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_build_level_vars', EJECT ??

    PROCEDURE initialize_build_level_vars
      (    build_level: pmt$os_name;
           variables: oct$program_name_list);


      VAR
        local_status: ost$status,
        build_level_location: ^pmt$os_name,
        next_variable: ^oct$program_name_list;


      IF variables.link = NIL THEN
        RETURN;
      IFEND;

      IF build_level = osc$null_name THEN
        osp$set_status_condition (oce$w_build_level_not_specified, local_status);
        issue_diagnostic (osc$warning_status, local_status);
      IFEND;

      next_variable := variables.link;

      WHILE next_variable <> NIL DO
        get_pointer_location (next_variable^.name, build_level_location);

        IF build_level_location <> NIL THEN
          build_level_location^ := build_level;
        IFEND;

        next_variable := next_variable^.link;
      WHILEND;


    PROCEND initialize_build_level_vars;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_symbol_table_id', EJECT ??

    PROCEDURE initialize_symbol_table_id
      (    symbol_table_id: ost$name;
           symbol_table_id_variable: pmt$program_name;
       VAR status: ost$status);


      VAR
        name_pointer: ^ost$name;

      IF symbol_table_id <> osc$null_name THEN
        v$symbol_table_id := symbol_table_id;

      ELSE
        pmp$get_unique_name (v$symbol_table_id, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;

      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        space (2);
        output ('SYMBOL TABLE ID = ', v$symbol_table_id, #SIZE (v$symbol_table_id), flush);
      IFEND;

      IF symbol_table_id_variable <> osc$null_name THEN
        get_pointer_location (symbol_table_id_variable, name_pointer);
        IF name_pointer <> NIL THEN
          name_pointer^ := v$symbol_table_id;
        IFEND;
      IFEND;


    PROCEND initialize_symbol_table_id;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_debug_table_pointer', EJECT ??

    PROCEDURE initialize_debug_table_pointer
      (    debug_table: ^SEQ ( * );
           debug_table_pointer: oct$pointer_list;
       VAR status: ost$status);


      VAR
        pointer_to_sequence: ^cell,
        segment: ^oct$output_segment_descriptor,
        saved_table: ^SEQ ( * );

      status.normal := TRUE;

      IF (debug_table_pointer.link = NIL) THEN
        RETURN;
      IFEND;

      get_pointer_location (debug_table_pointer.link^.name, pointer_to_sequence);
      IF (pointer_to_sequence <> NIL) THEN
        get_value_segment (debug_table_pointer.link, segment);
        IF (segment <> NIL) THEN
          NEXT saved_table: [[REP (#SIZE (debug_table^)) OF cell]] IN segment^.segment.sequence_pointer;
          IF saved_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL438', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          syp$advised_move_bytes (#LOC (debug_table^), #LOC (saved_table^), #SIZE (saved_table^), status);
          IF NOT status.normal THEN
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          build_adaptable_seq_pointer (segment^.r2, segment^.number, #OFFSET (saved_table),
                #SIZE (saved_table^), pointer_to_sequence);
        IFEND;
      IFEND;


    PROCEND initialize_debug_table_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'clean_up_debug_processing', EJECT ??

    PROCEDURE clean_up_debug_processing
      (    debug_table_pointer: oct$pointer_list;
       VAR status: ost$status);


      VAR
        debug_table: ^SEQ ( * );


      ocp$dtb_get_debug_table (debug_table, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$error_status, status);
        RETURN;
      IFEND;

      initialize_debug_table_pointer (debug_table, debug_table_pointer, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$error_status, status);
        RETURN;
      IFEND;

      ocp$dtb_close_debug_table (status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$error_status, status);
        RETURN;
      IFEND;


    PROCEND clean_up_debug_processing;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_message_module_ptr', EJECT ??

    PROCEDURE initialize_message_module_ptr
      (    object_libraries_to_use: oct$object_file_descriptor;
           module_name: pmt$program_name;
           pointer_name: pmt$program_name;
           section_name: pmt$program_name;
       VAR status: ost$status);


      VAR
        message_module_header: ^llt$library_member_header,
        member: ^SEQ ( * ),
        member_size: llt$section_length,
        module_found: boolean,

        object_library: ^oct$object_file_descriptor,
        i: 0 .. llc$max_modules_in_library,

        pointer_to_sequence: ^cell,
        section_pointer: oct$pointer_list,
        segment: ^oct$output_segment_descriptor,
        saved_table: ^SEQ ( * );


      status.normal := TRUE;

      object_library := object_libraries_to_use.link;

      module_found := FALSE;

    /find_message_module/
      WHILE object_library <> NIL DO

        IF object_library^.module_dictionary <> NIL THEN
          FOR i := LOWERBOUND (object_library^.module_dictionary^)
                TO UPPERBOUND (object_library^.module_dictionary^) DO
            IF (object_library^.module_dictionary^ [i].kind = llc$message_module) AND
                  (object_library^.module_dictionary^ [i].name = module_name) THEN

              message_module_header := #PTR (object_library^.module_dictionary^ [i].message_header,
                    object_library^.segment.sequence_pointer^);
              IF message_module_header <> NIL THEN
                member_size := message_module_header^.member_size;
                member := #PTR (message_module_header^.member, object_library^.segment.sequence_pointer^);
                IF member <> NIL THEN
                  RESET member;
                  module_found := TRUE;
                  EXIT /find_message_module/
                ELSE
                  osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL439', status);
                  issue_diagnostic (osc$fatal_status, status);
                  RETURN;
                IFEND;
              ELSE
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL439', status);
                issue_diagnostic (osc$fatal_status, status);
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

        object_library := object_library^.link;
      WHILEND /find_message_module/;

      get_pointer_location (pointer_name, pointer_to_sequence);

      IF pointer_to_sequence <> NIL THEN
        IF module_found THEN
          section_pointer.section_name := section_name;
          get_value_segment (^section_pointer, segment);
          IF (segment <> NIL) THEN
            NEXT saved_table: [[REP member_size OF cell]] IN segment^.segment.sequence_pointer;
            IF saved_table = NIL THEN
              osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL439', status);
              issue_diagnostic (osc$fatal_status, status);
              RETURN;
            IFEND;

            saved_table^ := member^;

            build_adaptable_seq_pointer (segment^.r2, segment^.number, #OFFSET (saved_table), member_size,
                  pointer_to_sequence);
          IFEND;
        ELSE
          build_adaptable_seq_pointer (0f(16), 0fff(16), 80000000(16), 0, pointer_to_sequence);
        IFEND;
      IFEND;

    PROCEND initialize_message_module_ptr;
?? OLDTITLE ??
?? NEWTITLE := 'print_allocated_segment_map', EJECT ??

    PROCEDURE print_allocated_segment_map
      (    allocated_segments: oct$output_segment_descriptor);


      VAR
        segment: ^oct$output_segment_descriptor,
        sections: ^oct$program_name_list,
        seq_pointer: ost$segment_offset,

        header_printed: boolean,
        attribute: oct$segment_attribute,
        segment_attributes: oct$segment_attributes,
        ascii_attribute: [STATIC] array [occ$sa_cache_bypass .. occ$sa_no_append] of string (2) :=
              ['CB', 'ET', 'WR', 'SH', 'FX', 'ST', 'RT', 'FB', 'NA'];


      segment := allocated_segments.link;

      WHILE segment <> NIL DO
        v$lm_segment_detail.segment := segment^.number;
        v$lm_segment_detail.r1 := segment^.r1;
        v$lm_segment_detail.r2 := segment^.r2;
        v$lm_segment_detail.segment_global_key_lock := segment^.global_key;
        v$lm_segment_detail.segment_local_key_lock := segment^.local_key;
        v$lm_segment_detail.stack_segment := FALSE;

        seq_pointer := i#current_sequence_position (segment^.segment.sequence_pointer);
        v$lm_segment_detail.segment_length := seq_pointer;

        v$lm_segment_detail.segment_access_attributes.cache_bypass :=
              (occ$sa_cache_bypass IN segment^.used_attributes);

        IF occ$sa_read IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$read_uncontrolled;
        ELSEIF occ$sa_read_kl IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$read_key_lock_controlled;
        ELSEIF occ$sa_binding IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$binding_segment;
        ELSE
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$non_readable;
        IFEND;

        IF occ$sa_write IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.write_privilege := osc$write_uncontrolled;
        ELSEIF occ$sa_write_kl IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.write_privilege := osc$write_key_lock_controlled;
        ELSE
          v$lm_segment_detail.segment_access_attributes.write_privilege := osc$non_writable;
        IFEND;

        IF occ$sa_non_privileged IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$non_privileged;
        ELSEIF occ$sa_local_privilege IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$local_privilege;
        ELSEIF occ$sa_global_privilege IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$global_privilege;
        ELSE
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$non_executable;
        IFEND;

        ocp$generate_link_map_text (v$lm_segment_detail);

        header_printed := FALSE;
        segment_attributes := segment^.used_attributes + segment^.unused_attributes;

        FOR attribute := occ$sa_cache_bypass TO occ$sa_no_append DO
          IF attribute IN segment_attributes THEN
            IF NOT header_printed THEN
              output (' ', '                                               ', 44, no_flush);
              header_printed := TRUE;
            IFEND;

            output (' ', ascii_attribute [attribute], 2, no_flush);
          IFEND;
        FOREND;

        IF header_printed THEN
          output (' ', ' ', 1, flush);
        IFEND;

        IF segment^.sections_allocated.link <> NIL THEN
          sections := segment^.sections_allocated.link;
          output ('                                   SECTIONS : ', sections^.name,
                STRLENGTH (sections^.name), flush);

          sections := sections^.link;

          WHILE sections <> NIL DO
            output ('                                              ', sections^.name,
                  STRLENGTH (sections^.name), flush);
            sections := sections^.link;
          WHILEND;
        IFEND;

        segment := segment^.link;
      WHILEND;

    PROCEND print_allocated_segment_map;
?? OLDTITLE ??
?? NEWTITLE := 'print_common_block_map', EJECT ??

    PROCEDURE print_common_block_map
      (    allocated_common_blocks: oct$common_block_item);


      VAR
        common_block: ^oct$common_block_item,
        print_line: string (80),
        pos: 1 .. 81,
        attributes: oct$segment_attributes,
        dummy: ost$status;


      IF allocated_common_blocks.link <> NIL THEN
        ocp$generate_link_map_text (v$lm_page_header);
        output ('', 'ALLOCATED COMMON BLOCK MAP', 26, flush);
        output ('   ', 'ACCESS ATTRIBUTES', 17, no_flush);
        output ('               ', 'LENGTH', 6, no_flush);
        output ('        ', 'ADDRESS', 7, flush);
        output ('   ', '--------------------------------------------------------------', 60, flush);

        common_block := allocated_common_blocks.link;

        WHILE common_block <> NIL DO
          space (1);
          print_line := '  ';
          pos := 4;

          print_line (pos, 6) := 'NAME: ';
          pos := pos + 6;

          print_line (pos, * ) := common_block^.section_item^.common_block_name;
          pos := pos + 31;

          IF common_block^.section_item^.deferred_common_block THEN
            print_line (pos, * ) := 'DEFERRED ';
            pos := pos + 9;
          IFEND;

          output ('', print_line, 60, flush);

          print_line := '  ';
          pos := 4;
          attributes := common_block^.section_item^.output^.used_attributes;

          IF occ$sa_extensible IN attributes THEN
            print_line (pos, * ) := 'EXTENSIBLE ';
            pos := pos + 11;
          IFEND;

          IF occ$sa_binding IN attributes THEN
            print_line (pos, * ) := 'BINDING ';
            pos := pos + 8;
          ELSEIF occ$sa_read IN attributes THEN
            print_line (pos, * ) := 'READ ';
            pos := pos + 5;
          ELSEIF occ$sa_read_kl IN attributes THEN
            print_line (pos, * ) := 'READ_KL ';
            pos := pos + 8;
          IFEND;

          IF occ$sa_write IN attributes THEN
            print_line (pos, * ) := 'WRITE ';
            pos := pos + 6;
          ELSEIF occ$sa_write_kl IN attributes THEN
            print_line (pos, * ) := 'WRITE_KL ';
            pos := pos + 9;
          IFEND;

          IF (occ$sa_non_privileged IN attributes) OR (occ$sa_local_privilege IN attributes) OR
                (occ$sa_global_privilege IN attributes) THEN
            print_line (pos, * ) := 'EXECUTE ';
            pos := pos + 8;
          IFEND;

          clp$convert_integer_to_rjstring (common_block^.section_item^.definition.length, 16, FALSE, ' ',
                print_line (35, 8), dummy);
          convert_hex_pva_to_ascii (common_block^.section_item^.pva, print_line (47, 14));

          output ('', print_line, 60, flush);

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


    PROCEND print_common_block_map;
?? OLDTITLE ??
?? NEWTITLE := 'print_starting_procedure', EJECT ??

    PROCEDURE print_starting_procedure
      (    starting_procedure: ^oct$entry_points);


      IF starting_procedure^.name <> osc$null_name THEN
        v$lm_transfer_detail.transfer_symbol := starting_procedure^.name;
        v$lm_transfer_detail.transfer_address.ring := starting_procedure^.pva.ring;
        v$lm_transfer_detail.transfer_address.segment := starting_procedure^.pva.seg;
        v$lm_transfer_detail.transfer_address.offset := starting_procedure^.pva.offset;

        ocp$generate_link_map_text (v$lm_transfer_detail);
      IFEND;


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

    PROCEDURE build_symbol_table
      (    symbol_table_name: ^fst$file_reference;
       VAR status: ost$status);


      VAR
        id: amt$file_identifier,
        segment: amt$segment_pointer,
        symbol_table_header: ^oct$symbol_table_header,
        symbol_table: ^oct$list_of_entry_points,
        ignore_status: ost$status;


      IF symbol_table_name = NIL THEN
        RETURN;
      IFEND;

      ocp$open_output_segment (symbol_table_name^, id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT symbol_table_header IN segment.sequence_pointer;
      IF symbol_table_header = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL99', status);
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      symbol_table_header^.version := occ$symbol_table_version;
      symbol_table_header^.id := v$symbol_table_id;

      IF v$outboard_symbol_table = NIL THEN
        symbol_table_header^.number_of_symbols := 0;
      ELSE
        symbol_table_header^.number_of_symbols := UPPERBOUND (v$outboard_symbol_table^);

        NEXT symbol_table: [1 .. symbol_table_header^.number_of_symbols] IN segment.sequence_pointer;
        IF symbol_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL100', status);
          issue_diagnostic (osc$fatal_status, status);
          fsp$close_file (id, ignore_status);
          RETURN;
        IFEND;

        symbol_table^ := v$outboard_symbol_table^;
      IFEND;

      amp$set_segment_eoi (id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      fsp$close_file (id, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;


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

    PROCEDURE fill_in_image_header
      (    header: ^pmt$virtual_memory_image_header);


      VAR
        entry_point: ^oct$entry_points,
        pva: ^ost$pva,
        i: 0 .. 8;


      header^.version := pmc$image_version;
      header^.system_core_id := v$symbol_table_id;

      header^.starting_procedure.fill1 := 0;
      header^.starting_procedure.vmid := osc$cyber_180_mode;
      header^.starting_procedure.xp := TRUE;
      header^.starting_procedure.fill2 := 0;
      header^.starting_procedure.r3 := v$starting_entry_point^.pva.ring;
      pva := #LOC (header^.starting_procedure.code_pva);
      pva^ := v$starting_entry_point^.pva;
      header^.starting_procedure.fill3 := 0;
      pva := #LOC (header^.starting_procedure.binding_pva);
      pva^ := v$starting_entry_point^.binding_section;

      header^.number_of_segments := 0;

      FOR i := 1 TO UPPERBOUND (header^.pad_for_170_linker) DO
        header^.pad_for_170_linker [i] := 0;
      FOREND;

      IF (link_parameters.exchange_package_variable <> osc$null_name) THEN
        search_entry_point_tree (link_parameters.exchange_package_variable, 1, 15, entry_point);
        IF (entry_point <> NIL) THEN
          header^.exchange_package := #ADDRESS (entry_point^.pva.ring, entry_point^.pva.seg,
                entry_point^.pva.offset);
        ELSE
          header^.exchange_package := NIL;
        IFEND;
      ELSE
        header^.exchange_package := NIL;
      IFEND;


    PROCEND fill_in_image_header;
?? OLDTITLE ??
?? NEWTITLE := 'fill_in_segment_description', EJECT ??

    PROCEDURE fill_in_segment_description
      (    descriptor: ^oct$output_segment_descriptor;
           length: ost$segment_length;
           description: ^pmt$linked_segment_description);


      VAR
        i: 0 .. 8;


      description^.name := descriptor^.name;
      description^.segment_number := descriptor^.number;
      description^.length := length;

      IF occ$sa_cache_bypass IN descriptor^.used_attributes THEN
        description^.segment_descriptor.vl := osc$vl_cache_bypass;
      ELSE
        description^.segment_descriptor.vl := osc$vl_regular_segment;
      IFEND;

      IF occ$sa_non_privileged IN descriptor^.used_attributes THEN
        description^.segment_descriptor.xp := osc$non_privileged;
      ELSEIF occ$sa_local_privilege IN descriptor^.used_attributes THEN
        description^.segment_descriptor.xp := osc$local_privilege;
      ELSEIF occ$sa_global_privilege IN descriptor^.used_attributes THEN
        description^.segment_descriptor.xp := osc$global_privilege;
      ELSE
        description^.segment_descriptor.xp := osc$non_executable;
      IFEND;

      IF occ$sa_read IN descriptor^.used_attributes THEN
        description^.segment_descriptor.rp := osc$read_uncontrolled;
      ELSEIF occ$sa_read_kl IN descriptor^.used_attributes THEN
        description^.segment_descriptor.rp := osc$read_key_lock_controlled;
      ELSEIF occ$sa_binding IN descriptor^.used_attributes THEN
        description^.segment_descriptor.rp := osc$binding_segment;
      ELSE
        description^.segment_descriptor.rp := osc$non_readable;
      IFEND;

      IF occ$sa_write IN descriptor^.used_attributes THEN
        description^.segment_descriptor.wp := osc$write_uncontrolled;
      ELSEIF occ$sa_write_kl IN descriptor^.used_attributes THEN
        description^.segment_descriptor.wp := osc$write_key_lock_controlled;
      ELSE
        description^.segment_descriptor.wp := osc$non_writable;
      IFEND;

      description^.segment_descriptor.r1 := descriptor^.r1;
      description^.segment_descriptor.r2 := descriptor^.r2;
      description^.segment_descriptor.asid := 0;

      description^.segment_descriptor.key_lock.value := 0;

      IF descriptor^.global_key <> 0 THEN
        description^.segment_descriptor.key_lock.global := TRUE;
        description^.segment_descriptor.key_lock.value := descriptor^.global_key;
      ELSE
        description^.segment_descriptor.key_lock.global := FALSE;
      IFEND;

      IF descriptor^.local_key <> 0 THEN
        description^.segment_descriptor.key_lock.local := TRUE;
        description^.segment_descriptor.key_lock.value := descriptor^.local_key;
      ELSE
        description^.segment_descriptor.key_lock.local := FALSE;
      IFEND;

      description^.software_attributes := $mmt$software_attribute_set [];
      IF occ$sa_wired IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_wired];
      IFEND;
      IF occ$sa_fixed IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_fixed];
      IFEND;
      IF occ$sa_stack IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_stack];
      IFEND;
      IF occ$sa_read_transfer_unit IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_read_transfer_unit];
      IFEND;
      IF occ$sa_free_behind IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_free_behind];
      IFEND;
      IF occ$sa_no_append IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_no_append];
      IFEND;

      FOR i := 1 TO UPPERBOUND (description^.pad_for_170_linker) DO
        description^.pad_for_170_linker [i] := 0;
      FOREND;


    PROCEND fill_in_segment_description;
?? OLDTITLE ??
?? NEWTITLE := 'build_virtual_memory_image', EJECT ??

    PROCEDURE build_virtual_memory_image
      (    virtual_memory_image: fst$file_reference;
       VAR status: ost$status);


      VAR
        ignore_status: ost$status,
        id: amt$file_identifier,
        segment: amt$segment_pointer,
        header: ^pmt$virtual_memory_image_header,
        description: ^pmt$linked_segment_description,
        descriptor: ^oct$output_segment_descriptor,
        length: ost$segment_length,
        pad_segment: ^SEQ ( * ),
        temp_segment: ^SEQ ( * ),
        output_segment: ^SEQ ( * );


      ocp$open_output_segment (virtual_memory_image, id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT header IN segment.sequence_pointer;
      IF header = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL101', status);
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      fill_in_image_header (header);

      descriptor := v$output_segment_list.link;

      WHILE descriptor <> NIL DO

        IF occ$sa_binding IN descriptor^.used_attributes THEN
          NEXT pad_segment: [[REP 8 OF cell]] IN descriptor^.segment.sequence_pointer;
          IF pad_segment = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL98', status);
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;
        IFEND;

{ for 170 linker compatability

        length := ((i#current_sequence_position (descriptor^.segment.sequence_pointer) + 3) DIV 4) * 4;

        IF length > 0 THEN
          header^.number_of_segments := header^.number_of_segments + 1;

          NEXT description IN segment.sequence_pointer;
          IF description = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VE102', status);
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;

          fill_in_segment_description (descriptor, length, description);

          RESET descriptor^.segment.sequence_pointer;
          NEXT temp_segment: [[REP length OF cell]] IN descriptor^.segment.sequence_pointer;
          NEXT output_segment: [[REP length OF cell]] IN segment.sequence_pointer;
          IF (temp_segment = NIL) OR (output_segment = NIL) THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VE103', status);
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;

          syp$advised_move_bytes (#LOC (temp_segment^), #LOC (output_segment^), #SIZE (output_segment^),
                status);
          IF NOT status.normal THEN
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;
        IFEND;

        descriptor := descriptor^.link;
      WHILEND;

      header^.length := i#current_sequence_position (segment.sequence_pointer);

      amp$set_segment_eoi (id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      fsp$close_file (id, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;


    PROCEND build_virtual_memory_image;
?? OLDTITLE ??
?? NEWTITLE := 'convert_seg_to_section_ordinal', EJECT ??

{ A nearly identical piece of code appears in procedure build_entry_definition_record.
{ If this procedure is changed, that one may need to change too.

    PROCEDURE convert_seg_to_section_ordinal
      (    segment_number: llt$section_ordinal;
       VAR section_ordinal: llt$section_ordinal;
       VAR relocation_offset: ost$segment_offset);

      VAR
        seg: ^oct$output_segment_descriptor;


      seg := v$output_segment_list.link;

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

      IF (seg <> NIL) THEN
        section_ordinal := seg^.section_ordinal;
        relocation_offset := #OFFSET (seg^.segment.sequence_pointer);
      ELSE
        section_ordinal := UPPERVALUE (segment_number);
        relocation_offset := 0;
      IFEND;

    PROCEND convert_seg_to_section_ordinal;
?? OLDTITLE ??
?? NEWTITLE := 'open_binary_output_file', EJECT ??

    PROCEDURE open_binary_output_file
      (    name: fst$file_reference;
       VAR file_identifier: amt$file_identifier;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        attachment_options: ^fst$attachment_options,
        creation_validation_attributes: ^fst$file_cycle_attributes,
        ignore_status: ost$status;


      status.normal := TRUE;

      PUSH attachment_options: [1 .. 2];
      PUSH creation_validation_attributes: [1 .. 2];

      attachment_options^ [1].selector := fsc$access_and_share_modes;
      attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^ [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$append, fsc$modify, fsc$shorten];
      attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options^ [2].selector := fsc$delete_data;
      attachment_options^ [2].delete_data := TRUE;

      creation_validation_attributes^ [1].selector := fsc$file_contents_and_processor;
      creation_validation_attributes^ [1].file_contents := fsc$object_data;
      creation_validation_attributes^ [1].file_processor := amc$unknown_processor;
      creation_validation_attributes^ [2].selector := fsc$record_type;
      creation_validation_attributes^ [2].record_type := amc$undefined;

      fsp$open_file (name, amc$segment, attachment_options, {default_creation_attributes} NIL,
            creation_validation_attributes, creation_validation_attributes, {attribute_override} NIL,
            file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, output_file, status);
      IF NOT status.normal THEN
        fsp$close_file (file_identifier, ignore_status);
        RETURN;
      IFEND;

      RESET output_file.sequence_pointer;


    PROCEND open_binary_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'assign_section_ordinals', EJECT ??

    PROCEDURE assign_section_ordinals
      (    segments: oct$output_segment_descriptor;
       VAR greatest_section_ordinal: llt$section_ordinal);


      VAR
        seg: ^oct$output_segment_descriptor,
        section_ordinal: integer;


      section_ordinal := -1;
      seg := segments.link;

      WHILE seg <> NIL DO
        IF i#current_sequence_position (seg^.segment.sequence_pointer) <> 0 THEN
          section_ordinal := section_ordinal + 1;
          seg^.section_ordinal := section_ordinal;
        IFEND;

        seg := seg^.link;
      WHILEND;

      IF section_ordinal >= 0 THEN
        greatest_section_ordinal := section_ordinal;
      ELSE
        greatest_section_ordinal := 0;
      IFEND;


    PROCEND assign_section_ordinals;
?? OLDTITLE ??
?? NEWTITLE := 'build_identification_record', EJECT ??

    PROCEDURE build_identification_record
      (    name: fst$file_reference;
           kind: llt$module_kind;
           greatest_section_ordinal: llt$section_ordinal;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        identification: ^llt$identification,
        object_text_descriptor: ^llt$object_text_descriptor,
        parsed_file_reference: fst$parsed_file_reference;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$identification;
      object_text_descriptor^.unused := 0;

      NEXT identification IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      clp$convert_string_to_file_ref (name, parsed_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      identification^.name := parsed_file_reference.path (parsed_file_reference.last_name.index,
            parsed_file_reference.last_name.size);

      identification^.object_text_version := llc$object_text_version;
      identification^.kind := kind;

      pmp$get_time (osc$hms_time, identification^.time_created, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_date (osc$mdy_date, identification^.date_created, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      identification^.attributes := $llt$module_attributes [llc$nonbindable];
      IF NOT v$source_type_checking THEN
        identification^.attributes := identification^.attributes +
              $llt$module_attributes [llc$object_cybil_checking];
      IFEND;
      identification^.greatest_section_ordinal := greatest_section_ordinal;
      identification^.generator_id := llc$virtual_environment_linker;
      identification^.generator_name_vers := 'Virtual Environment Linker - V1.0';
      identification^.commentary := ' ';


    PROCEND build_identification_record;
?? OLDTITLE ??
?? NEWTITLE := 'build_68000_absolute', EJECT ??


    PROCEDURE build_68000_absolute
      (    name: fst$file_reference;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        m68000_absolute: ^llt$68000_absolute,
        local_68000_sequence: ^SEQ ( * ),
        text: ^SEQ ( * ),
        file_identifier: amt$file_identifier,
        size: ost$segment_length,
        offset: 0 .. osc$max_segment_length - 1,
        space: ^SEQ ( * ),
        output_file: amt$segment_pointer;


      open_binary_output_file (name, file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_identification_record (name, llc$motorola_68000_absolute, 0, output_file, status);

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      get_68000_segment_limits (size, offset);
      object_text_descriptor^.kind := llc$68000_absolute;
      object_text_descriptor^.number_of_68000_bytes := size - offset;

      NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
            output_file.sequence_pointer;
      IF m68000_absolute = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      m68000_absolute^.load_address := offset;
      m68000_absolute^.transfer_address := v$starting_entry_point^.pva.offset;

      local_68000_sequence := link_parameters.mc68000_seq;

      RESET local_68000_sequence;

      IF offset <> 0 THEN
        NEXT space: [[REP offset OF cell]] IN local_68000_sequence;
      IFEND;

      NEXT text: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN local_68000_sequence;

      m68000_absolute^.text := text^;

      build_transfer_symbol (v$starting_procedure, output_file, status);

      close_binary_output_file (file_identifier, output_file, status);

    PROCEND build_68000_absolute;

?? OLDTITLE ??
?? NEWTITLE := 'get_68000_segment_limits', EJECT ??

    PROCEDURE get_68000_segment_limits
      (VAR size: ost$segment_length;
       VAR offset: 0 .. osc$max_segment_length - 1);

      VAR
        segment: ^oct$output_segment_descriptor,
        segment2: ^oct$output_segment_descriptor,
        offset1: 0 .. osc$max_segment_length - 1,
        size1: ost$segment_length;

      size := 0;
      offset := 0;

      segment := ^v$output_segment_list;

      IF segment <> NIL THEN
        segment := segment^.link;
        IF segment <> NIL THEN
          size := i#current_sequence_position (segment^.segment.sequence_pointer);
          offset := segment^.offset;
          segment2 := segment^.link;
          WHILE segment2 <> NIL DO
            IF segment2^.offset < offset THEN
              offset := segment2^.offset;
            IFEND;
            size1 := i#current_sequence_position (segment2^.segment.sequence_pointer);
            IF size < size1 THEN
              size := size1;
            IFEND;
            segment2 := segment2^.link;
          WHILEND;
        IFEND;
      IFEND;


    PROCEND get_68000_segment_limits;
?? OLDTITLE ??
?? NEWTITLE := 'build_libraries', EJECT ??

    PROCEDURE build_libraries
      (    number_of_libraries: integer;
           library_list: oct$known_file_list;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        libraries: ^llt$libraries,
        lib: ^oct$known_file_list,
        i: integer;


      IF number_of_libraries > 0 THEN
        NEXT object_text_descriptor IN output_file.sequence_pointer;
        IF object_text_descriptor = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        object_text_descriptor^.kind := llc$libraries;
        object_text_descriptor^.number_of_libraries := number_of_libraries;

        NEXT libraries: [1 .. number_of_libraries] IN output_file.sequence_pointer;
        IF libraries = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        lib := library_list.link;

        FOR i := 1 TO number_of_libraries DO
          libraries^ [i] := lib^.name^;
          lib := lib^.link;
        FOREND;
      IFEND;


    PROCEND build_libraries;
?? OLDTITLE ??
?? NEWTITLE := 'assign_section_attributes', EJECT ??

    PROCEDURE assign_section_attributes
      (    segment_attributes: oct$segment_attributes;
           extensible: oct$extensible_attributes;
       VAR section_kind: llt$section_kind;
       VAR section_attributes: llt$section_access_attributes);


      IF (($oct$segment_attributes [occ$sa_non_privileged, occ$sa_local_privilege,
            occ$sa_global_privilege] * segment_attributes) <> $oct$segment_attributes []) THEN
        section_kind := llc$code_section;
        section_attributes := $llt$section_access_attributes [llc$read, llc$execute];

      ELSEIF occ$sa_binding IN segment_attributes THEN
        section_kind := llc$binding_section;
        section_attributes := $llt$section_access_attributes [llc$read, llc$binding];

      ELSE
        IF extensible = occ$allocated_extensible THEN
          section_kind := llc$extensible_working_storage;
        ELSE
          section_kind := llc$working_storage_section;
        IFEND;

        IF (($oct$segment_attributes [occ$sa_read, occ$sa_read_kl] * segment_attributes) <>
              $oct$segment_attributes []) THEN
          section_attributes := $llt$section_access_attributes [llc$read];
        ELSE
          section_attributes := $llt$section_access_attributes [];
        IFEND;

        IF (($oct$segment_attributes [occ$sa_write, occ$sa_write_kl] * segment_attributes) <>
              $oct$segment_attributes []) THEN
          section_attributes := section_attributes + $llt$section_access_attributes [llc$write];
        IFEND;
      IFEND;


    PROCEND assign_section_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'build_segment_definition', EJECT ??

    PROCEDURE build_segment_definition
      (    segment: ^oct$output_segment_descriptor;
           length: ost$segment_length;
       VAR section_kind: llt$section_kind;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        segment_definition: ^llt$segment_definition,
        relocation_offset: ost$segment_offset;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$segment_definition;
      object_text_descriptor^.unused := 0;

      NEXT segment_definition IN output_file.sequence_pointer;
      IF segment_definition = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      segment_definition^.segment_number := segment^.number;
      segment_definition^.r1 := segment^.r1;
      segment_definition^.r2 := segment^.r2;

      IF segment^.cybil_default_heap THEN
        segment_definition^.section_definition.kind := llc$extensible_common_block;
        segment_definition^.section_definition.access_attributes := $llt$section_access_attributes
              [llc$read, llc$write];

        segment_definition^.section_definition.name := cyc$default_heap_name;
      ELSE
        assign_section_attributes (segment^.used_attributes, segment^.extensible_attribute,
              segment_definition^.section_definition.kind, segment_definition^.section_definition.
              access_attributes);

        segment_definition^.section_definition.name := osc$null_name;
      IFEND;

      segment_definition^.section_definition.section_ordinal := segment^.section_ordinal;
      IF segment^.extensible_attribute <> occ$allocated_extensible THEN
        segment_definition^.section_definition.length := length;
      ELSE
        segment_definition^.section_definition.length := 7fffffff(16);
      IFEND;
      segment_definition^.section_definition.allocation_alignment := 8;
      segment_definition^.section_definition.allocation_offset := 0;
      segment_definition^.section_definition.name := osc$null_name;

      section_kind := segment_definition^.section_definition.kind;

      IF (section_kind = llc$code_section) AND (segment^.binding_section_encountered) THEN
        convert_seg_to_section_ordinal (segment^.binding_section_segment,
              segment_definition^.binding_section_ordinal, relocation_offset);
        segment_definition^.binding_section_offset := segment^.binding_section_offset - relocation_offset;
      ELSE
        segment_definition^.binding_section_ordinal := 0;
        segment_definition^.binding_section_offset := 0;
      IFEND;

      segment_definition^.future_use := 0;


    PROCEND build_segment_definition;
?? OLDTITLE ??
?? NEWTITLE := 'build_common_block_definition', EJECT ??

    PROCEDURE build_common_block_definition
      (    section_item: ^oct$section_table_item;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        section_definition: ^llt$section_definition;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      IF (section_item^.unallocated_common_block) THEN
        object_text_descriptor^.kind := llc$unallocated_common_block;
      ELSE
        object_text_descriptor^.kind := llc$section_definition;
      IFEND;
      object_text_descriptor^.unused := 0;

      NEXT section_definition IN output_file.sequence_pointer;
      IF section_definition = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      section_definition^ := section_item^.definition;
      section_definition^.section_ordinal := section_item^.output^.section_ordinal;
      section_definition^.name := section_item^.common_block_name;
      IF (section_definition^.name = cyc$default_heap_name) THEN
        section_definition^.length := 7fffffff(16);
      IFEND;


    PROCEND build_common_block_definition;
?? OLDTITLE ??
?? NEWTITLE := 'build_deferred_common_block', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build an object text record containing
{   all of the deferred common blocks.
{ DESIGN:
{   Search common block table for those that are deferred and build a common
{   block definition for each uniquely named common block.  Duplicate common
{   block definitions are combined.

    PROCEDURE build_deferred_common_block
      (    common_blocks: oct$common_block_item;
           number_deferred_common_blocks: llt$section_ordinal;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);

      VAR
        common_block: ^oct$common_block_item,
        common_block_index: 0 .. llc$max_deferred_common_blocks,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        extensible_common_block: boolean,
        object_text_descriptor: ^llt$object_text_descriptor,
        previously_defined: boolean,
        search_index: 0 .. llc$max_deferred_common_blocks;


      status.normal := TRUE;

{ Build object text records for the deferred common blocks.

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$deferred_common_blocks;

      NEXT deferred_common_blocks: [1 .. number_deferred_common_blocks] IN output_file.sequence_pointer;
      IF deferred_common_blocks = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      common_block_index := 0;

      common_block := common_blocks.link;

      WHILE (common_block <> NIL) DO
        IF common_block^.section_item^.deferred_common_block THEN
          extensible_common_block := (common_block^.section_item^.definition.kind =
                llc$extensible_common_block);

          previously_defined := FALSE;

        /find_common_block/
          FOR search_index := 1 TO common_block_index DO
            IF (deferred_common_blocks^ [search_index].name = common_block^.section_item^.definition.name)
                  THEN
              previously_defined := TRUE;
              EXIT /find_common_block/
            IFEND;
          FOREND /find_common_block/;

          IF NOT previously_defined THEN
            common_block_index := common_block_index + 1;
            deferred_common_blocks^ [common_block_index].name :=
                  common_block^.section_item^.common_block_name;
            deferred_common_blocks^ [common_block_index].global_lock :=
                  common_block^.section_item^.global_key;
            deferred_common_blocks^ [common_block_index].loaded_ring := common_block^.section_item^.r2;
            deferred_common_blocks^ [common_block_index].address.ring := common_block^.section_item^.pva.ring;
            deferred_common_blocks^ [common_block_index].address.segment :=
                  common_block^.section_item^.pva.seg;
            deferred_common_blocks^ [common_block_index].address.offset :=
                  common_block^.section_item^.pva.offset;
            deferred_common_blocks^ [common_block_index].allocation_length :=
                  common_block^.section_item^.definition.length;
            deferred_common_blocks^ [common_block_index].allocation_alignment :=
                  common_block^.section_item^.definition.allocation_alignment;
            deferred_common_blocks^ [common_block_index].allocation_offset :=
                  common_block^.section_item^.definition.allocation_offset;
            deferred_common_blocks^ [common_block_index].access_attributes :=
                  common_block^.section_item^.definition.access_attributes;
            convert_segment_access_control (common_block^.section_item^.output^.used_attributes,
                  deferred_common_blocks^ [common_block_index].segment_access_control);
            deferred_common_blocks^ [common_block_index].extensible := extensible_common_block;
            deferred_common_blocks^ [common_block_index].unallocated_common := FALSE;
            deferred_common_blocks^ [common_block_index].unallocated_common_open := FALSE;
          ELSE {previously_defined
            IF (deferred_common_blocks^ [search_index].extensible = extensible_common_block) AND
                  (deferred_common_blocks^ [search_index].allocation_alignment =
                  common_block^.section_item^.definition.allocation_alignment) AND
                  (deferred_common_blocks^ [search_index].allocation_offset =
                  common_block^.section_item^.definition.allocation_offset) AND
                  (deferred_common_blocks^ [search_index].access_attributes =
                  common_block^.section_item^.definition.access_attributes) THEN
              IF (deferred_common_blocks^ [search_index].allocation_length <>
                    common_block^.section_item^.definition.length) THEN
                IF extensible_common_block THEN
                  IF (deferred_common_blocks^ [search_index].allocation_length <
                        common_block^.section_item^.definition.length) THEN
                    deferred_common_blocks^ [search_index].allocation_length :=
                          common_block^.section_item^.definition.length;
                  IFEND;
                ELSE
                  osp$set_status_abnormal (oc, oce$w_conflicting_common_length,
                        common_block^.section_item^.common_block_name, status);
                  issue_diagnostic (osc$warning_status, status);
                IFEND;
              IFEND;
            ELSE
              osp$set_status_abnormal (oc, oce$w_conflicting_com_attribute,
                    common_block^.section_item^.common_block_name, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND; {previously_defined
        IFEND; {deferred_common_block

        common_block := common_block^.link;
      WHILEND;

{ Position output_file to end of last deferred common block definition.

      object_text_descriptor^.number_of_common_blocks := common_block_index;
      RESET output_file.sequence_pointer TO deferred_common_blocks;
      NEXT deferred_common_blocks: [1 .. common_block_index] IN output_file.sequence_pointer;

    PROCEND build_deferred_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'build_text_record', EJECT ??

    PROCEDURE build_text_record
      (    section_ordinal: llt$section_ordinal;
           segment: amt$segment_pointer;
           length: ost$segment_length;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        local_segment: amt$segment_pointer,
        object_text_descriptor: ^llt$object_text_descriptor,
        text: ^llt$text,
        byte: ^array [1 .. * ] of 0 .. 255;


      local_segment := segment;

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$text;
      object_text_descriptor^.number_of_bytes := length;

      NEXT text: [1 .. length] IN output_file.sequence_pointer;
      IF text = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      text^.section_ordinal := section_ordinal;
      text^.offset := 0;

      RESET local_segment.sequence_pointer;
      NEXT byte: [1 .. length] IN local_segment.sequence_pointer;
      syp$advised_move_bytes (#LOC (byte^), #LOC (text^.byte), #SIZE (byte^), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND build_text_record;
?? OLDTITLE ??
?? NEWTITLE := 'build_segment_definitions', EJECT ??

    PROCEDURE build_segment_definitions
      (    output_segments: oct$output_segment_descriptor;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        segment: ^oct$output_segment_descriptor,
        length: ost$segment_length,
        section_kind: llt$section_kind;


      segment := output_segments.link;

      WHILE segment <> NIL DO
        IF (NOT segment^.retained_common_block) THEN
          length := i#current_sequence_position (segment^.segment.sequence_pointer);

          IF length > 0 THEN
            build_segment_definition (segment, length, section_kind, output_file, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (segment^.number_of_bytes_written > 0) THEN
              build_text_record (segment^.section_ordinal, segment^.segment, segment^.number_of_bytes_written,
                    output_file, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

          IFEND;
        IFEND;

        segment := segment^.link;
      WHILEND;


    PROCEND build_segment_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'build_common_block_definitions', EJECT ??

    PROCEDURE build_common_block_definitions
      (    common_blocks: oct$common_block_item;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        common_block: ^oct$common_block_item,
        length: ost$segment_length,
        number_of_bytes_written: ost$segment_length,
        number_deferred_common_blocks: 0 .. llc$max_deferred_common_blocks,
        segment: ^oct$output_segment_descriptor;


      common_block := common_blocks.link;

      number_deferred_common_blocks := 0;
      WHILE common_block <> NIL DO
        IF (common_block^.section_item^.retained_common_block) AND
              (NOT common_block^.section_item^.deferred_common_block) THEN
          segment := common_block^.section_item^.output;
          length := i#current_sequence_position (segment^.segment.sequence_pointer);

          IF length > 0 THEN
            build_common_block_definition (common_block^.section_item, output_file, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (segment^.number_of_bytes_written > 0) THEN

{ Remember this segment is "inside" another segment, so number written must be recomputed.

              number_of_bytes_written := segment^.number_of_bytes_written -
                    #OFFSET (segment^.segment.sequence_pointer);
              IF (number_of_bytes_written > 0) THEN
                build_text_record (segment^.section_ordinal, segment^.segment, number_of_bytes_written,
                      output_file, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;

            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSEIF common_block^.section_item^.deferred_common_block THEN
          number_deferred_common_blocks := number_deferred_common_blocks + 1;
        IFEND;

        common_block := common_block^.link;
      WHILEND;

      IF number_deferred_common_blocks > 0 THEN
        build_deferred_common_block (common_blocks, number_deferred_common_blocks, output_file, status);
      IFEND;

    PROCEND build_common_block_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'build_adr_records', EJECT ??

    PROCEDURE build_adr_records
      (    address_formulation_records: oct$object_record_list;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        address_formulation: ^llt$address_formulation,
        adr: ^oct$object_record_list,
        dest_relocation: ost$segment_offset,
        value_relocation: ost$segment_offset,
        i: integer;


      adr := address_formulation_records.link;

      WHILE adr <> NIL DO
        NEXT object_text_descriptor IN output_file.sequence_pointer;
        IF object_text_descriptor = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        object_text_descriptor^.kind := llc$address_formulation;
        object_text_descriptor^.number_of_adr_items := UPPERBOUND (adr^.address_formulation^.item);

        NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
              output_file.sequence_pointer;
        IF address_formulation = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        address_formulation^ := adr^.address_formulation^;
        convert_seg_to_section_ordinal (address_formulation^.dest_section, address_formulation^.dest_section,
              dest_relocation);
        convert_seg_to_section_ordinal (address_formulation^.value_section,
              address_formulation^.value_section, value_relocation);

        IF (dest_relocation <> 0) OR (value_relocation <> 0) THEN
          FOR i := 1 TO object_text_descriptor^.number_of_adr_items DO
            address_formulation^.item [i].dest_offset := address_formulation^.item [i].dest_offset -
                  dest_relocation;
            address_formulation^.item [i].value_offset := address_formulation^.item [i].value_offset -
                  value_relocation;
          FOREND;
        IFEND;

        adr := adr^.link;
      WHILEND;


    PROCEND build_adr_records;
?? OLDTITLE ??
?? NEWTITLE := 'build_external_records', EJECT ??

    PROCEDURE build_external_records
      (    unsatisfied_externals: oct$ext_reference_list;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        maximum: llt$object_text_descriptor,
        relocation_offset: ost$segment_offset,
        object_text_descriptor: ^llt$object_text_descriptor,
        external_linkage: ^llt$external_linkage,
        external: ^oct$ext_reference_list,
        item: ^oct$external_items;


      maximum.number_of_ext_items := UPPERVALUE (maximum.number_of_ext_items);

      external := unsatisfied_externals.link;

      WHILE (external <> NIL) DO
        object_text_descriptor := ^maximum;

        item := external^.items.link;

        WHILE (item <> NIL) DO
          IF (object_text_descriptor^.number_of_ext_items = UPPERVALUE (object_text_descriptor^.
                number_of_ext_items)) THEN
            NEXT object_text_descriptor IN output_file.sequence_pointer;
            IF object_text_descriptor = NIL THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;

            object_text_descriptor^.kind := llc$external_linkage;
            object_text_descriptor^.number_of_ext_items := 1;

            NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                  output_file.sequence_pointer;
            IF (external_linkage = NIL) THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;

            external_linkage^.name := external^.name;
            external_linkage^.language := external^.language;
            external_linkage^.declaration_matching_required := external^.declaration_matching_required;
            external_linkage^.declaration_matching := external^.declaration_matching;
          ELSE
            object_text_descriptor^.number_of_ext_items := object_text_descriptor^.number_of_ext_items + 1;

            RESET output_file.sequence_pointer TO external_linkage;
            NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                  output_file.sequence_pointer;
            IF object_text_descriptor = NIL THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;
          IFEND;

          convert_seg_to_section_ordinal (item^.output^.number, external_linkage^.
                item [object_text_descriptor^.number_of_ext_items].section_ordinal, relocation_offset);
          external_linkage^.item [object_text_descriptor^.number_of_ext_items].
                offset := #OFFSET (item^.address) - relocation_offset;
          external_linkage^.item [object_text_descriptor^.number_of_ext_items].kind := item^.kind;
          external_linkage^.item [object_text_descriptor^.number_of_ext_items].offset_operand :=
                item^.offset_operand;

          item := item^.link;
        WHILEND;

        external := external^.link;
      WHILEND;


    PROCEND build_external_records;
?? OLDTITLE ??
?? NEWTITLE := 'build_relocation_record', EJECT ??

    PROCEDURE build_relocation_record
      (    output_segments: oct$output_segment_descriptor;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        maximum: llt$object_text_descriptor,
        relocation_offset: ost$segment_offset,
        ignore: ost$segment_offset,
        object_text_descriptor: ^llt$object_text_descriptor,
        relocation_item: ^llt$relocation_item,
        segment: ^oct$output_segment_descriptor,
        section_ordinal: llt$section_ordinal,
        relocation_value: ^oct$segment_relocation_list;


      object_text_descriptor := ^maximum;
      object_text_descriptor^.number_of_rel_items := UPPERVALUE (object_text_descriptor^.number_of_rel_items);
      segment := output_segments.link;

      WHILE segment <> NIL DO
        convert_seg_to_section_ordinal (segment^.number, section_ordinal, relocation_offset);
        relocation_value := segment^.relocation_list.link;

        WHILE relocation_value <> NIL DO
          IF (object_text_descriptor^.number_of_rel_items = UPPERVALUE (object_text_descriptor^.
                number_of_rel_items)) THEN
            NEXT object_text_descriptor IN output_file.sequence_pointer;
            IF object_text_descriptor = NIL THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;

            object_text_descriptor^.kind := llc$relocation;
            object_text_descriptor^.number_of_rel_items := 1;
          ELSE
            object_text_descriptor^.number_of_rel_items := object_text_descriptor^.number_of_rel_items + 1;
          IFEND;

          NEXT relocation_item IN output_file.sequence_pointer;
          IF object_text_descriptor = NIL THEN
            osp$set_status_condition (oce$e_eof_on_generated_file, status);
            RETURN;
          IFEND;

          relocation_item^.section_ordinal := section_ordinal;
          relocation_item^.offset := #OFFSET (relocation_value^.pva) + 2 - relocation_offset;
          convert_seg_to_section_ordinal (relocation_value^.pva^.seg, relocation_item^.relocating_section,
                ignore);
          relocation_item^.container := llc$four_bytes;
          relocation_item^.address := llc$byte_signed;

          relocation_value := relocation_value^.link;
        WHILEND;

        segment := segment^.link;
      WHILEND;


    PROCEND build_relocation_record;
?? OLDTITLE ??
?? NEWTITLE := 'heap_sort_deferred_entry_points', EJECT ??

{ PURPOSE:
{   Sort the deferred entry point list by name.

    PROCEDURE heap_sort_deferred_entry_points
      (VAR deferred_entry_points: llt$deferred_entry_points);


      VAR
        i: 0 .. llc$max_deferred_entry_points,
        j: 0 .. llc$max_deferred_entry_points,
        key: pmt$program_name,
        left: 0 .. llc$max_deferred_entry_points,
        number: 1 .. llc$max_deferred_entry_points,
        right: 0 .. llc$max_deferred_entry_points,
        temp: llt$deferred_entry_point;


      number := UPPERBOUND (deferred_entry_points);

      IF (number = 1) THEN
        RETURN;
      ELSEIF (number = 2) THEN
        IF (deferred_entry_points [1].name > deferred_entry_points [2].name) THEN
          temp := deferred_entry_points [1];
          deferred_entry_points [1] := deferred_entry_points [2];
          deferred_entry_points [2] := temp;
        IFEND;
        RETURN;
      IFEND;

      left := (number DIV 2) + 1;
      right := number;

    /outer_loop/
      WHILE (TRUE) DO
        IF (left > 1) THEN
          left := left - 1;
          temp := deferred_entry_points [left];
          key := deferred_entry_points [left].name;
        ELSE
          temp := deferred_entry_points [right];
          key := deferred_entry_points [right].name;
          deferred_entry_points [right] := deferred_entry_points [1];
          right := right - 1;
          IF (right = 1) THEN
            deferred_entry_points [right] := temp;
            RETURN;
          IFEND;
        IFEND;

        j := left;

      /inner_loop/
        WHILE (TRUE) DO
          i := j;
          j := j + j;

          IF (j < right) THEN
            IF (deferred_entry_points [j].name < deferred_entry_points [j + 1].name) THEN
              j := j + 1;
            IFEND;
          ELSEIF (j > right) THEN
            EXIT /inner_loop/;
          IFEND;

          IF (key >= deferred_entry_points [j].name) THEN
            EXIT /inner_loop/;
          IFEND;

          deferred_entry_points [i] := deferred_entry_points [j];
        WHILEND /inner_loop/;

        deferred_entry_points [i] := temp;
      WHILEND /outer_loop/;

    PROCEND heap_sort_deferred_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'build_deferred_entry_definition', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build an object text record containing
{   all of the deferred entry points.
{ DESIGN:
{   Search entry point list for those that are deferred and build entry
{   definitions that include the segment number and offset of the entry
{   point.

    PROCEDURE build_deferred_entry_definition
      (    entry_points: oct$entry_points;
           number_of_deferred_entry_points: llt$section_ordinal;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);

      VAR
        deferred_entry_points: ^llt$deferred_entry_points,
        entry_point: ^oct$entry_points,
        entry_point_index: 0 .. llc$max_deferred_entry_points,
        ignore_relocation_offset: ost$segment_offset,
        object_text_descriptor: ^llt$object_text_descriptor;


      status.normal := TRUE;

{ Build object text records for the deferred common blocks.

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$deferred_entry_points;
      object_text_descriptor^.number_of_entry_points := number_of_deferred_entry_points;

      NEXT deferred_entry_points: [1 .. number_of_deferred_entry_points] IN output_file.sequence_pointer;
      IF deferred_entry_points = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      entry_point_index := 0;

      entry_point := entry_points.link;

      WHILE (entry_point <> NIL) AND (entry_point_index < number_of_deferred_entry_points) DO
        IF entry_point^.deferred THEN
          entry_point_index := entry_point_index + 1;

          deferred_entry_points^ [entry_point_index].address.ring := entry_point^.pva.ring;
          deferred_entry_points^ [entry_point_index].address.segment := entry_point^.pva.seg;
          deferred_entry_points^ [entry_point_index].address.offset := entry_point^.pva.offset;
          convert_seg_to_section_ordinal (entry_point^.pva.seg,
                deferred_entry_points^ [entry_point_index].section_ordinal, ignore_relocation_offset);
          deferred_entry_points^ [entry_point_index].attributes := entry_point^.attributes;
          deferred_entry_points^ [entry_point_index].name := entry_point^.name;
          deferred_entry_points^ [entry_point_index].language := entry_point^.language;
          deferred_entry_points^ [entry_point_index].declaration_matching_required :=
                entry_point^.declaration_matching_required;
          deferred_entry_points^ [entry_point_index].declaration_matching_value :=
                entry_point^.declaration_matching;
          deferred_entry_points^ [entry_point_index].source_type_checking := v$source_type_checking;
          deferred_entry_points^ [entry_point_index].binding_section_address.ring :=
                entry_point^.binding_section.ring;
          deferred_entry_points^ [entry_point_index].binding_section_address.segment :=
                entry_point^.binding_section.seg;
          deferred_entry_points^ [entry_point_index].binding_section_address.offset :=
                entry_point^.binding_section.offset;

        IFEND;

        entry_point := entry_point^.link;
      WHILEND;

      heap_sort_deferred_entry_points (deferred_entry_points^);
    PROCEND build_deferred_entry_definition;
?? OLDTITLE ??
?? NEWTITLE := 'build_entry_definition_records', EJECT ??

    PROCEDURE build_entry_definition_records
      (    entry_points: oct$entry_points;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        entry_definition: ^llt$entry_definition,
        ept: ^oct$entry_points,
        number_of_deferred_entry_points: 0 .. llc$max_deferred_entry_points,
        object_text_descriptor: ^llt$object_text_descriptor,
        relocation_offset: ost$segment_offset,
        segment_p: ^oct$output_segment_descriptor;

      ept := entry_points.link;

      number_of_deferred_entry_points := 0;
      WHILE ept <> NIL DO
        IF (NOT ept^.deferred) THEN
          NEXT object_text_descriptor IN output_file.sequence_pointer;
          IF object_text_descriptor = NIL THEN
            osp$set_status_condition (oce$e_eof_on_generated_file, status);
            RETURN;
          IFEND;

          object_text_descriptor^.kind := llc$entry_definition;
          object_text_descriptor^.unused := 0;

          NEXT entry_definition IN output_file.sequence_pointer;
          IF entry_definition = NIL THEN
            osp$set_status_condition (oce$e_eof_on_generated_file, status);
            RETURN;
          IFEND;

          segment_p := v$output_segment_list.link;

          WHILE (segment_p <> NIL) AND (segment_p^.number <> ept^.pva.seg) DO
            segment_p := segment_p^.link;
          WHILEND;

          IF (segment_p <> NIL) THEN
            entry_definition^.section_ordinal := segment_p^.section_ordinal;
            IF segment_p^.retained_common_block AND (segment_p^.extensible_attribute = occ$non_extensible)
                  THEN

{  This common block is defined inside of the scratch sequence so it has not been relocated.

              relocation_offset := 0;
            ELSE
              relocation_offset := #OFFSET (segment_p^.segment.sequence_pointer);
            IFEND;
          ELSE
            entry_definition^.section_ordinal := UPPERVALUE (ept^.pva.seg);
            relocation_offset := 0;
          IFEND;

          entry_definition^.offset := ept^.pva.offset - relocation_offset;
          entry_definition^.attributes := ept^.attributes;
          entry_definition^.name := ept^.name;
          entry_definition^.language := ept^.language;
          entry_definition^.declaration_matching_required := ept^.declaration_matching_required;
          entry_definition^.declaration_matching := ept^.declaration_matching;
        ELSE {ept^.deferred
          number_of_deferred_entry_points := number_of_deferred_entry_points + 1;
        IFEND;

        ept := ept^.link;
      WHILEND;

      IF number_of_deferred_entry_points > 0 THEN
        build_deferred_entry_definition (entry_points, number_of_deferred_entry_points, output_file, status);
      IFEND;

    PROCEND build_entry_definition_records;
?? OLDTITLE ??
?? NEWTITLE := 'build_transfer_symbol', EJECT ??

    PROCEDURE build_transfer_symbol
      (    name: pmt$program_name;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        transfer_symbol: ^llt$transfer_symbol;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$transfer_symbol;
      object_text_descriptor^.unused := 0;

      NEXT transfer_symbol IN output_file.sequence_pointer;
      IF transfer_symbol = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      transfer_symbol^.name := name;


    PROCEND build_transfer_symbol;
?? OLDTITLE ??
?? NEWTITLE := 'close_binary_output_file', EJECT ??

    PROCEDURE close_binary_output_file
      (    file_identifier: amt$file_identifier;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      amp$set_segment_eoi (file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$close_file (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND close_binary_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'build_product_module', EJECT ??

    PROCEDURE build_product_module
      (    name: fst$file_reference;
       VAR status: ost$status);


      VAR
        file_identifier: amt$file_identifier,
        output_file: amt$segment_pointer,
        greatest_section_ordinal: llt$section_ordinal;


      open_binary_output_file (name, file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      assign_section_ordinals (v$output_segment_list, greatest_section_ordinal);

      build_identification_record (name, v$module_kind, greatest_section_ordinal, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_libraries (v$number_of_libraries, v$library_list, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_segment_definitions (v$output_segment_list, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_common_block_definitions (v$common_block_table, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_adr_records (v$address_formulation_records, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_external_records (v$unsatisfied_externals, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_relocation_record (v$output_segment_list, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_entry_definition_records (v$entry_points, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_transfer_symbol (v$starting_procedure, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      close_binary_output_file (file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND build_product_module;
?? OLDTITLE ??
?? EJECT ??

    CONST
      flush = TRUE,
      no_flush = FALSE;

    VAR
      current_message_module: ^oct$message_module_list,
      entry_point: ^oct$entry_points,
      link_map_close_status: ost$status,
      malfunction_descriptor: pmt$established_handler,
      map_malfunction: [STATIC, READ] pmt$condition := [pmc$user_defined_condition, loe$map_malfunction],
      reset_value: ^SEQ ( * ),
      v$output_buffer: string (120),
      v$output_pos: 1 .. 121;


    pmp$establish_condition_handler (map_malfunction, ^link_map_malfunction, ^malfunction_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$initialize_link_map (link_parameters.map_file^, link_parameters.build_level, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF link_parameters.debug_table <> NIL THEN
      v$generate_debug_tables := TRUE;
      ocp$dtb_initialize_debug_tables (link_parameters.build_level, link_parameters.input_debug_table,
            link_parameters.debug_table^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      v$generate_debug_tables := FALSE;
    IFEND;

    reset_value := ocv$vel_scratch_seq;

    osp$set_status_abnormal (oc, oce$i_generate_status, 'GENERATE completed - NO errors encountered',
          v$generate_status);

  /link_virtual_environment/
    BEGIN
      setup_link (status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      process_predefined_segments (ocv$predefined_segment_list, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      process_inboard_symbol_tables (link_parameters.symbol_tables_to_use, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      v$module_kind := llc$mi_virtual_state;

      add_object_files (link_parameters.object_files_to_add, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      IF v$starting_procedure = osc$null_name THEN
        v$starting_procedure := v$last_starting_procedure;
      IFEND;

      add_object_modules (link_parameters.modules_to_add, link_parameters.object_libraries_to_use, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      IF v$starting_procedure = osc$null_name THEN
        v$starting_procedure := v$last_starting_procedure;
      IFEND;

      satisfy_externals (link_parameters.object_libraries_to_use, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      search_entry_point_tree (v$starting_procedure, osc$invalid_ring, osc$max_ring, entry_point);
      IF entry_point <> NIL THEN
        IF entry_point^.deferred THEN
          entry_point^.deferred := FALSE;
        IFEND;
      IFEND;

      clean_up_residue_diagnostics;

{ Caution: The debug tables and the symbol table must be before
{          the system on the virtual memory image.  This is required because if they
{          follow the rest of the system, they may cause the length of the virtual memory
{          image to be a non integral multiple of 8 bytes which causes the 170 deadstart
{          tape generator to abort.  If they are at the beginning of the virtual memory
{          image, the code modules which follow them will start on an 8 byte boundary
{          which will result in a virtual memory image which also ends on an 8 byte boundary.

      IF v$generate_debug_tables THEN
        clean_up_debug_processing (link_parameters.debug_table_pointers, status);
        IF NOT status.normal THEN
          EXIT /link_virtual_environment/;
        IFEND;
      IFEND;

      current_message_module := link_parameters.message_module_list;
      WHILE current_message_module <> NIL DO
        initialize_message_module_ptr (link_parameters.object_libraries_to_use,
              current_message_module^.module_name, current_message_module^.pointer_name,
              current_message_module^.section_name, status);
        IF NOT status.normal THEN
          EXIT /link_virtual_environment/;
        IFEND;
        current_message_module := current_message_module^.link;
      WHILEND;

      generate_outboard_symbol_table (status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_symbol_table_ptrs (link_parameters.symbol_table_pointers,
            link_parameters.delete_declaration_matching, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_recovery_name_table (link_parameters.recovery_name_table_pointer,
            link_parameters.recovery_addresses, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_heap_pointers (link_parameters.heap_pointers, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_build_level_vars (link_parameters.build_level, link_parameters.build_level_variables);

      initialize_symbol_table_id (link_parameters.symbol_table_id, link_parameters.symbol_table_id_variable,
            status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      IF pmc$segment_map IN link_parameters.map_options THEN
        print_allocated_segment_map (v$output_segment_list);
        print_common_block_map (v$common_block_table);
      IFEND;

      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        print_starting_procedure (v$starting_entry_point);
      IFEND;

      build_symbol_table (link_parameters.symbol_table, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      CASE link_parameters.mode OF
      = occ$template =
        build_virtual_memory_image (link_parameters.virtual_image^, status);
      = occ$product =
        build_product_module (link_parameters.virtual_image^, status);
      = occ$mc68000 =
        build_68000_absolute (link_parameters.virtual_image^, status);
      CASEND;

    END /link_virtual_environment/;

    IF v$current_segment_number <= UPPERVALUE (ost$segment) THEN
      ocv$next_available_segment := v$current_segment_number;
    ELSE
      ocv$next_available_segment := occ$initial_segment_number;
    IFEND;

    IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
      ocp$generate_link_map_text (v$lm_diagnostic_summary);

      ocp$close_link_map (link_map_close_status);
    IFEND;

    IF NOT status.normal THEN
      ocv$vel_scratch_seq := reset_value;
      RETURN;
    IFEND;

    status := v$generate_status;


  PROCEND ocp$execute_the_ve_linker;
?? OLDTITLE ??
MODEND ocm$virtual_environment_linker;
