?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Linker : Debug Table Builder' ??
MODULE ocm$linker_debug_table_builder;

{  PURPOSE:
{    This module is responsible for accumulating the debug table
{    information output by the linker and making it available to
{    the debugger.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$load_module
*copyc oce$library_generator_errors
*copyc oce$ve_linker_exceptions
*copyc oct$object_code_utility_types
*copyc pme$debug_exceptions
*copyc pmt$linker_debug_table_header
?? POP ??
*copyc amp$close
*copyc amp$open
*copyc amp$set_segment_eoi
*copyc i#current_sequence_position
*copyc ocp$create_transient_segment
*copyc ocp$open_input_debug_table
*copyc ocp$open_output_debug_table
*copyc osp$set_status_abnormal
*copyc pmp$get_date
*copyc pmp$get_time
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    debug_table_header: ^pmt$linker_debug_table_header,

    module_segment_identifier: amt$file_identifier,
    module_segment: amt$segment_pointer,
    entry_point_segment: amt$segment_pointer := [amc$sequence_pointer, NIL],
    address_segment: amt$segment_pointer := [amc$sequence_pointer, NIL],

    module_before_last: ^pmt$module_item,
    last_module: ^pmt$module_item,
    current_module: ^pmt$module_item,
    current_modules_first_address: pmt$number_of_debug_items,

    entry_points: ^pmt$entry_point_items,
    addresses: ^pmt$address_items;

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

  PROCEDURE open_debug_scratch_files
    (VAR status: ost$status);


    IF entry_point_segment.sequence_pointer = NIL THEN
      ocp$create_transient_segment (amc$sequence_pointer, entry_point_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    RESET entry_point_segment.sequence_pointer;


    IF address_segment.sequence_pointer = NIL THEN
      ocp$create_transient_segment (amc$sequence_pointer, address_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    RESET address_segment.sequence_pointer;


  PROCEND open_debug_scratch_files;
?? OLDTITLE ??
?? NEWTITLE := '  INITIALIZE_DEBUG_TABLES', EJECT ??

  PROCEDURE initialize_debug_tables
    (    build_level: pmt$os_name;
         debug_table_header: ^pmt$linker_debug_table_header);


    VAR
      ignore_status: ost$status;


    debug_table_header^.version := pmc$linker_debug_table_version;
    debug_table_header^.build_level := build_level;
    pmp$get_date (osc$mdy_date, debug_table_header^.date, ignore_status);
    pmp$get_time (osc$hms_time, debug_table_header^.time, ignore_status);
    debug_table_header^.number_of_modules := 0;
    debug_table_header^.number_of_entry_points := 0;
    debug_table_header^.number_of_addresses := 0;

    entry_points := NIL;
    addresses := NIL;

    last_module := NIL;


  PROCEND initialize_debug_tables;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_ADDRESS_TABLES_TO_SCRATCH', EJECT ??

  PROCEDURE copy_address_tables_to_scratch
    (    debug_table_header: ^pmt$linker_debug_table_header;
         file_name: fst$file_reference;
     VAR debug_table: amt$segment_pointer;
     VAR status: ost$status);


    VAR
      old_entry_points: ^pmt$entry_point_items,
      old_addresses: ^pmt$address_items;


    IF debug_table_header^.number_of_entry_points = 0 THEN
      entry_points := NIL;
    ELSE
      old_entry_points := #PTR (debug_table_header^.entry_point_items, debug_table.sequence_pointer^);
      IF old_entry_points = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_name, status);
        RETURN;
      IFEND;

      NEXT entry_points: [1 .. UPPERBOUND (old_entry_points^)] IN entry_point_segment.sequence_pointer;
      IF entry_points = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'DTB08', status);
        RETURN;
      IFEND;

      entry_points^ := old_entry_points^;
    IFEND;


    IF debug_table_header^.number_of_addresses = 0 THEN
      addresses := NIL;
    ELSE
      old_addresses := #PTR (debug_table_header^.address_items, debug_table.sequence_pointer^);
      IF old_addresses = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_name, status);
        RETURN;
      IFEND;

      NEXT addresses: [1 .. UPPERBOUND (old_addresses^)] IN address_segment.sequence_pointer;
      IF addresses = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'DTB09', status);
        RETURN;
      IFEND;

      addresses^ := old_addresses^;
    IFEND;


  PROCEND copy_address_tables_to_scratch;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_OUTPUT_DEBUG_TABLE ', EJECT ??

  PROCEDURE copy_output_debug_table
    (    build_level: pmt$os_name;
         debug_table: fst$file_reference,
         debug_table_header: ^pmt$linker_debug_table_header;
     VAR last_module: ^pmt$module_item;
     VAR status: ost$status);


    VAR
      location: ^cell,
      i: pmt$number_of_debug_items,
      ignore_status: ost$status;


    debug_table_header^.build_level := build_level;
    pmp$get_date (osc$mdy_date, debug_table_header^.date, ignore_status);
    pmp$get_time (osc$hms_time, debug_table_header^.time, ignore_status);


    last_module := #PTR (debug_table_header^.first_module_address_table_item,
          module_segment.sequence_pointer^);

    FOR i := 2 TO debug_table_header^.number_of_modules DO
      last_module := #PTR (last_module^.next_module, module_segment.sequence_pointer^);
    FOREND;

    copy_address_tables_to_scratch (debug_table_header, debug_table, module_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    location := #ADDRESS (#RING (last_module), #SEGMENT (last_module),
          (#OFFSET (last_module) + #SIZE (last_module^)));
    RESET module_segment.sequence_pointer TO location;


  PROCEND copy_output_debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'COPY_INPUT_DEBUG_TABLE', EJECT ??

  PROCEDURE copy_input_debug_table
    (    input_name: fst$file_reference;
         output_name: fst$file_reference;
         output_header: ^pmt$linker_debug_table_header;
     VAR last_module: ^pmt$module_item;
     VAR status: ost$status);


    VAR
      input_id: amt$file_identifier,
      input_segment: amt$segment_pointer,
      input_header: ^pmt$linker_debug_table_header,
      input_item: ^pmt$module_item,
      i: pmt$number_of_debug_items,
      ignore_status: ost$status;


    last_module := NIL;

    ocp$open_input_debug_table (input_name, input_id, input_segment, input_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF input_header^.number_of_modules = 0 THEN
      entry_points := NIL;
      addresses := NIL;
      amp$close (input_id, status);
      RETURN;
    IFEND;


    input_item := #PTR (input_header^.first_module_address_table_item, input_segment.sequence_pointer^);

    NEXT last_module: [0 .. input_item^.identification.greatest_section_ordinal] IN
          module_segment.sequence_pointer;
    IF last_module = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, output_name, status);
      RETURN;
    IFEND;

    output_header^.first_module_address_table_item := #REL (last_module, module_segment.sequence_pointer^);
    output_header^.number_of_modules := 1;
    last_module^ := input_item^;
?? EJECT ??

    FOR i := 2 TO input_header^.number_of_modules DO
      input_item := #PTR (input_item^.next_module, input_segment.sequence_pointer^);

      NEXT last_module: [0 .. input_item^.identification.greatest_section_ordinal] IN
            module_segment.sequence_pointer;
      IF last_module = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, output_name, status);
        amp$close (input_id, ignore_status);
      IFEND;

      last_module^ := input_item^;
      output_header^.number_of_modules := output_header^.number_of_modules + 1;
    FOREND;


    copy_address_tables_to_scratch (input_header, input_name, input_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_header^.number_of_addresses := input_header^.number_of_addresses;
    output_header^.number_of_entry_points := input_header^.number_of_entry_points;


    amp$close (input_id, status);


  PROCEND copy_input_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '  ADD_TO_ENTRY_POINTS', EJECT ??

  PROCEDURE add_to_entry_points
    (    name: pmt$program_name;
         address: pmt$segment_and_offset;
     VAR status: ost$status);


    debug_table_header^.number_of_entry_points := debug_table_header^.number_of_entry_points + 1;

    RESET entry_point_segment.sequence_pointer;
    NEXT entry_points: [1 .. debug_table_header^.number_of_entry_points] IN
          entry_point_segment.sequence_pointer;
    IF entry_points = NIL THEN
      osp$set_status_abnormal (oc, pme$module_segment_overflow, 'DFEP1', status);
      RETURN;
    IFEND;

    entry_points^ [debug_table_header^.number_of_entry_points].name := name;
    entry_points^ [debug_table_header^.number_of_entry_points].address := address;


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

  PROCEDURE define_address
    (    segment_offset: pmt$segment_and_offset;
         address_from_an_entry_point: boolean;
     VAR status: ost$status);


    debug_table_header^.number_of_addresses := debug_table_header^.number_of_addresses + 1;

    RESET address_segment.sequence_pointer;
    NEXT addresses: [1 .. debug_table_header^.number_of_addresses] IN address_segment.sequence_pointer;
    IF addresses = NIL THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'DA01', status);
      RETURN;
    IFEND;

    addresses^ [debug_table_header^.number_of_addresses].segment_offset := segment_offset;
    addresses^ [debug_table_header^.number_of_addresses].module_item :=
          #REL (current_module, module_segment.sequence_pointer^);
    addresses^ [debug_table_header^.number_of_addresses].from_an_entry_point := address_from_an_entry_point;


  PROCEND define_address;
?? OLDTITLE ??
?? NEWTITLE := '  DEFINE_ENTRY_POINT_ADDRESS', EJECT ??

  PROCEDURE define_entry_point_address
    (    address: pmt$segment_and_offset;
         entry_point_name: pmt$program_name;
     VAR status: ost$status);


    VAR
      i: llt$section_ordinal,
      j: pmt$number_of_debug_items;


    FOR i := LOWERBOUND (current_module^.section_item) TO UPPERBOUND (current_module^.section_item) DO
      IF (address = current_module^.section_item [i].address) THEN
        IF (entry_point_name = current_module^.section_item [i].name) THEN
          RETURN;
        ELSE
          FOR j := current_modules_first_address TO debug_table_header^.number_of_addresses DO
            IF (address = addresses^ [j].segment_offset) THEN
              addresses^ [j].from_an_entry_point := TRUE;
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      ELSEIF (address > current_module^.section_item [i].address) AND
            ((address < current_module^.section_item [i].address + current_module^.section_item [i].length))
            THEN
        define_address (address, TRUE, status);
        RETURN;
      IFEND;
    FOREND;


  PROCEND define_entry_point_address;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL]  OCP$DTB_INITIALIZE_DEBUG_TABLES', EJECT ??

  PROCEDURE [XDCL] ocp$dtb_initialize_debug_tables
    (    build_level: pmt$os_name;
         input_debug_table: ^fst$file_reference;
         debug_table: fst$file_reference;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status;


    status.normal := TRUE;

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

    ocp$open_output_debug_table (debug_table, module_segment_identifier, module_segment, debug_table_header,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF (input_debug_table <> NIL) AND (input_debug_table^ = debug_table) THEN
      IF debug_table_header^.version <> pmc$linker_debug_table_version THEN
        osp$set_status_abnormal (oc, oce$e_invalid_debug_tbl_version, debug_table, status);
        amp$close (module_segment_identifier, ignore_status);
        RETURN;
      IFEND;

      IF debug_table_header^.number_of_modules = 0 THEN
        initialize_debug_tables (build_level, debug_table_header);
      ELSE
        copy_output_debug_table (build_level, debug_table, debug_table_header, last_module, status);
        IF NOT status.normal THEN
          amp$close (module_segment_identifier, ignore_status);
          RETURN;
        IFEND;
      IFEND;
    ELSE
      initialize_debug_tables (build_level, debug_table_header);

      IF (input_debug_table <> NIL) THEN
        copy_input_debug_table (input_debug_table^, debug_table, debug_table_header, last_module, status);
        IF NOT status.normal THEN
          amp$close (module_segment_identifier, ignore_status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    current_module := NIL;


  PROCEND ocp$dtb_initialize_debug_tables;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL]  OCP$DTB_DEFINE_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$dtb_define_module
    (    identification: ^llt$identification;
     VAR status: ost$status);


    status.normal := TRUE;

    IF current_module <> NIL THEN
      osp$set_status_abnormal (oc, pme$missing_module_termination, current_module^.identification.name,
            status);
      RETURN;
    IFEND;


    NEXT current_module: [0 .. identification^.greatest_section_ordinal] IN module_segment.sequence_pointer;
    IF current_module = NIL THEN
      osp$set_status_abnormal (oc, pme$module_segment_overflow, '', status);
      RETURN;
    IFEND;


    current_module^.identification := identification^;
    current_module^.number_of_line_address_tables := 0;
    current_module^.number_of_debug_symbol_tables := 0;
    current_modules_first_address := debug_table_header^.number_of_addresses + 1;


  PROCEND ocp$dtb_define_module;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL]  OCP$DTB_DEFINE_SECTION' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$dtb_define_section
    (    section_item: pmt$section_item;
     VAR status: ost$status);


    status.normal := TRUE;

    IF current_module = NIL THEN
      osp$set_status_abnormal (oc, pme$missing_module_definition, '', status);
      RETURN;
    IFEND;

    current_module^.section_item [section_item.section_ordinal] := section_item;


    IF (section_item.length > 0) THEN
      IF (section_item.name <> osc$null_name) AND (section_item.kind = llc$code_section) THEN
        add_to_entry_points (section_item.name, section_item.address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      define_address (section_item.address, FALSE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


  PROCEND ocp$dtb_define_section;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL]  OCP$DTB_DEFINE_ENTRY_POINT' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$dtb_define_entry_point
    (    name: pmt$program_name;
         pva: ost$pva;
     VAR status: ost$status);


    VAR
      address: pmt$segment_and_offset;


    status.normal := TRUE;

    IF current_module = NIL THEN
      osp$set_status_abnormal (oc, pme$missing_module_definition, '', status);
      RETURN;
    IFEND;


    address := (pva.seg * 100000000(16)) + pva.offset;

    add_to_entry_points (name, address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    define_entry_point_address (address, name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND ocp$dtb_define_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL]  OCP$DTB_TERMINATE_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$dtb_terminate_module
    (VAR status: ost$status);


    status.normal := TRUE;

    IF current_module = NIL THEN
      osp$set_status_abnormal (oc, pme$missing_module_definition, '', status);
      RETURN;
    IFEND;

    IF debug_table_header^.number_of_modules = 0 THEN
      debug_table_header^.first_module_address_table_item :=
            #REL (current_module, module_segment.sequence_pointer^);
    ELSE
      last_module^.next_module := #REL (current_module, module_segment.sequence_pointer^);
    IFEND;

    debug_table_header^.number_of_modules := debug_table_header^.number_of_modules + 1;
    module_before_last := last_module;
    last_module := current_module;
    current_module := NIL;


  PROCEND ocp$dtb_terminate_module;
?? OLDTITLE ??
?? NEWTITLE := '  OMIT_NON_ENTRY_POINT_ADDRESSES', EJECT ??

  PROCEDURE omit_non_entry_point_addresses
    (    addresses: ^pmt$address_items;
         first_address: pmt$number_of_debug_items;
     VAR number_of_addresses: pmt$number_of_debug_items);


    VAR
      i: integer,
      j: integer;


    j := first_address - 1;

    FOR i := first_address TO number_of_addresses DO
      IF (addresses^ [i].from_an_entry_point) THEN
        j := j + 1;
        addresses^ [j] := addresses^ [i];
      IFEND;
    FOREND;

    number_of_addresses := j;


  PROCEND omit_non_entry_point_addresses;
?? OLDTITLE ??
?? NEWTITLE := '  GET_COMPONENT_INFO', EJECT ??

  PROCEDURE get_component_info
    (    info_element_header: ^llt$info_element_header;
     VAR object_library: ^SEQ ( * );
     VAR components: ^llt$component_information;
     VAR sections: ^llt$section_maps;
     VAR maps: ^array [0 .. * ] of ^llt$section_map_items;
     VAR status: ost$status);


    VAR
      i: llt$section_ordinal;


    IF (info_element_header^.number_of_components = 0) THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'GCI_1', status);
      RETURN;
    ELSE
      components := #PTR (info_element_header^.component_ptr, object_library^);
    IFEND;

    IF (info_element_header^.number_of_section_maps = 0) THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'GCI_2', status);
      RETURN;
    ELSE
      sections := #PTR (info_element_header^.section_maps, object_library^);
    IFEND;

    ALLOCATE maps: [0 .. UPPERBOUND (sections^)];
    IF (maps = NIL) THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'GCI_3', status);
      RETURN;
    IFEND;

    FOR i := 0 TO UPPERBOUND (sections^) DO
      IF (sections^ [i].number_of_items <> 0) THEN
        maps^ [i] := #PTR (sections^ [i].map, object_library^);
      ELSE
        maps^ [i] := NIL;
      IFEND;
    FOREND;


  PROCEND get_component_info;
?? OLDTITLE ??
?? NEWTITLE := '  REBUILD_MODULE_ITEM', EJECT ??

  PROCEDURE rebuild_module_item
    (    component: ^llt$component_description;
     VAR module_item: ^pmt$module_item;
     VAR status: ost$status);


    NEXT module_item: [0 .. 0] IN module_segment.sequence_pointer;
    IF (module_item = NIL) THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'RMI_1', status);
      RETURN;
    IFEND;

    module_item^.identification.name := component^.name;
    module_item^.identification.object_text_version := llc$object_text_version;
    module_item^.identification.kind := llc$mi_virtual_state;
    module_item^.identification.time_created := component^.time_created;
    module_item^.identification.date_created := component^.date_created;
    module_item^.identification.attributes := $llt$module_attributes [];
    module_item^.identification.greatest_section_ordinal := 0;
    module_item^.identification.generator_id := component^.generator_id;
    module_item^.identification.generator_name_vers := component^.generator_name_vers;
    module_item^.identification.commentary := component^.commentary;
    module_item^.number_of_line_address_tables := 0;
    module_item^.number_of_debug_symbol_tables := 0;

    current_module := module_item;


  PROCEND rebuild_module_item;
?? OLDTITLE ??
?? NEWTITLE := '  REBUILD_SECTION_ITEM', EJECT ??

  PROCEDURE rebuild_section_item
    (    saved_item: ^pmt$section_item;
         map: ^llt$section_map_item;
         rebuilt_item: ^pmt$section_item;
     VAR status: ost$status);


    rebuilt_item^.kind := saved_item^.kind;
    rebuilt_item^.section_ordinal := map^.original_section_ordinal;
    rebuilt_item^.address := saved_item^.address + map^.offset;
    rebuilt_item^.length := map^.length;
    rebuilt_item^.segment_access_control := saved_item^.segment_access_control;
    rebuilt_item^.ring := saved_item^.ring;
    rebuilt_item^.key_lock := saved_item^.key_lock;
    rebuilt_item^.name := map^.name;

    IF (rebuilt_item^.length > 0) THEN
      IF (rebuilt_item^.name <> osc$null_name) AND (rebuilt_item^.kind = llc$code_section) THEN
        add_to_entry_points (rebuilt_item^.name, rebuilt_item^.address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      define_address (rebuilt_item^.address, FALSE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


  PROCEND rebuild_section_item;
?? OLDTITLE ??
?? NEWTITLE := '  REBUILD_MODULE', EJECT ??

  PROCEDURE rebuild_module
    (    component: ^llt$component_description;
         component_number: 1 .. llc$max_components;
         saved_sections: ^array [0 .. * ] of pmt$section_item;
         sections: ^llt$section_maps;
         maps: ^array [0 .. * ] of ^llt$section_map_items;
     VAR rebuilt_module: ^pmt$module_item;
     VAR status: ost$status);


    VAR
      i: integer,
      j: integer,
      item: ^llt$section_map_item,
      reset_value: ^SEQ ( * );


    reset_value := module_segment.sequence_pointer;

    rebuild_module_item (component, rebuilt_module, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 0 TO UPPERBOUND (sections^) DO
      FOR j := 1 TO (sections^ [i].number_of_items) DO
        item := ^maps^ [i]^ [j];
        IF (item^.component = component_number) THEN
          IF (item^.original_section_ordinal > rebuilt_module^.identification.greatest_section_ordinal) THEN
            rebuilt_module^.identification.greatest_section_ordinal := item^.original_section_ordinal;

            module_segment.sequence_pointer := reset_value;

            NEXT rebuilt_module: [0 .. rebuilt_module^.identification.greatest_section_ordinal] IN
                  module_segment.sequence_pointer;
            IF (rebuilt_module = NIL) THEN
              osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'RM_1', status);
              RETURN;
            IFEND;
          IFEND;

          rebuild_section_item (^saved_sections^ [i], item, ^rebuilt_module^.
                section_item [item^.original_section_ordinal], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    FOREND;


  PROCEND rebuild_module;
?? OLDTITLE ??
?? NEWTITLE := '  REBUILD_MODULE_LIST', EJECT ??

  PROCEDURE rebuild_module_list
    (    components: ^llt$component_information;
         sections: ^llt$section_maps;
         maps: ^array [0 .. * ] of ^llt$section_map_items;
     VAR module_list: ^array [1 .. * ] of ^pmt$module_item;
     VAR status: ost$status);


    VAR
      saved_sections: ^array [0 .. * ] of pmt$section_item,
      i: integer;


    ALLOCATE saved_sections: [0 .. UPPERBOUND (last_module^.section_item)];
    IF (saved_sections = NIL) THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'RML_1', status);
      RETURN;
    IFEND;

    saved_sections^ := last_module^.section_item;

    debug_table_header^.number_of_modules := debug_table_header^.number_of_modules - 1;

    RESET module_segment.sequence_pointer TO last_module;


    ALLOCATE module_list: [1 .. UPPERBOUND (components^)];
    IF (module_list = NIL) THEN
      osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'RML_2', status);
      RETURN;
    IFEND;

    IF (debug_table_header^.number_of_modules <> 0) THEN
      last_module := module_before_last;
    IFEND;

    FOR i := 1 TO UPPERBOUND (components^) DO
      rebuild_module (^components^ [i], i, saved_sections, sections, maps, module_list^ [i], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF debug_table_header^.number_of_modules = 0 THEN
        debug_table_header^.first_module_address_table_item :=
              #REL (module_list^ [i], module_segment.sequence_pointer^);
      ELSE
        last_module^.next_module := #REL (module_list^ [i], module_segment.sequence_pointer^);
      IFEND;

      last_module := module_list^ [i];
      debug_table_header^.number_of_modules := debug_table_header^.number_of_modules + 1;
    FOREND;


  PROCEND rebuild_module_list;
?? OLDTITLE ??
?? NEWTITLE := '  FIND_ADDRESS_IN_MODULE', EJECT ??

  PROCEDURE find_address_in_module
    (    address: pmt$segment_and_offset;
         section_items: ^array [0 .. * ] of pmt$section_item;
     VAR found: boolean);


    VAR
      i: llt$section_ordinal;


    FOR i := 0 TO UPPERBOUND (section_items^) DO
      IF (address >= section_items^ [i].address) AND (address <
            (section_items^ [i].address + section_items^ [i].length - 1)) THEN
        found := TRUE;
        RETURN;
      IFEND;
    FOREND;

    found := FALSE;

  PROCEND find_address_in_module;
?? OLDTITLE ??
?? NEWTITLE := '  FIND_MODULE_FOR_ADDRESS', EJECT ??

  PROCEDURE find_module_for_address
    (    address: pmt$segment_and_offset;
         module_list: ^array [1 .. * ] of ^pmt$module_item;
     VAR module_for_address: integer);


    VAR
      current_module: integer,
      found: boolean;


    current_module := module_for_address;

    FOR module_for_address := module_for_address TO UPPERBOUND (module_list^) DO
      find_address_in_module (address, ^module_list^ [module_for_address]^.section_item, found);
      IF found THEN
        RETURN;
      IFEND;
    FOREND;

    FOR module_for_address := 1 TO (current_module - 1) DO
      find_address_in_module (address, ^module_list^ [module_for_address]^.section_item, found);
      IF found THEN
        RETURN;
      IFEND;
    FOREND;


  PROCEND find_module_for_address;
?? OLDTITLE ??
?? NEWTITLE := '  RELOCATE_ADDRESSES', EJECT ??

  PROCEDURE relocate_addresses
    (    module_list: ^array [1 .. * ] of ^pmt$module_item;
         addresses: ^pmt$address_items);


    VAR
      i: integer,
      module_for_address: integer;


    module_for_address := 1;

    FOR i := current_modules_first_address TO debug_table_header^.number_of_addresses DO
      find_module_for_address (addresses^ [i].segment_offset, module_list, module_for_address);

      addresses^ [i].module_item := #REL (module_list^ [module_for_address],
            module_segment.sequence_pointer^);
    FOREND;


  PROCEND relocate_addresses;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] OCP$DTB_REDEFINE_MODULE', EJECT ??

  PROCEDURE [XDCL] ocp$dtb_redefine_module
    (    info_element_header: ^llt$info_element_header;
     VAR object_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      components: ^llt$component_information,
      sections: ^llt$section_maps,
      maps: ^array [0 .. * ] of ^llt$section_map_items,
      module_list: ^array [1 .. * ] of ^pmt$module_item;


    status.normal := TRUE;

    omit_non_entry_point_addresses (addresses, current_modules_first_address,
          debug_table_header^.number_of_addresses);

    get_component_info (info_element_header, object_library, components, sections, maps, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rebuild_module_list (components, sections, maps, module_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    relocate_addresses (module_list, addresses);

    current_module := NIL;


  PROCEND ocp$dtb_redefine_module;
?? OLDTITLE ??
?? NEWTITLE := '  HEAP_SORT_ADDRESSES', EJECT ??

  PROCEDURE heap_sort_addresses
    (    addresses: ^pmt$address_items);


    VAR
      left: pmt$number_of_debug_items,
      right: pmt$number_of_debug_items,
      i: pmt$number_of_debug_items,
      j: pmt$number_of_debug_items,
      number: pmt$number_of_debug_items,
      temp: pmt$address_item,
      key: pmt$segment_and_offset;


    number := UPPERBOUND (addresses^);

    IF (number = 1) THEN
      RETURN;
    ELSEIF (number = 2) THEN
      IF (addresses^ [1].segment_offset > addresses^ [2].segment_offset) THEN
        temp := addresses^ [1];
        addresses^ [1] := addresses^ [2];
        addresses^ [2] := temp;
      IFEND;
      RETURN;
    IFEND;
?? EJECT ??

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

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

      j := left;

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

        IF (j < right) THEN
          IF (addresses^ [j].segment_offset < addresses^ [j + 1].segment_offset) THEN
            j := j + 1;
          IFEND;
        ELSEIF (j > right) THEN
          EXIT /inner_loop/;
        IFEND;

        IF (key >= addresses^ [j].segment_offset) THEN
          EXIT /inner_loop/;
        IFEND;

        addresses^ [i] := addresses^ [j];
      WHILEND /inner_loop/;

      addresses^ [i] := temp;
    WHILEND /outer_loop/;


  PROCEND heap_sort_addresses;
?? OLDTITLE ??
?? NEWTITLE := '  HEAP_SORT_ENTRY_POINTS ', EJECT ??

  PROCEDURE heap_sort_entry_points
    (    entry_points: ^pmt$entry_point_items);


    VAR
      left: pmt$number_of_debug_items,
      right: pmt$number_of_debug_items,
      i: pmt$number_of_debug_items,
      j: pmt$number_of_debug_items,
      number: pmt$number_of_debug_items,
      temp: pmt$entry_point_item,
      key: pmt$program_name;


    number := UPPERBOUND (entry_points^);

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

    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].name;
      ELSE
        temp := entry_points^ [right];
        key := entry_points^ [right].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].name < entry_points^ [j + 1].name) THEN
            j := j + 1;
          IFEND;
        ELSEIF (j > right) THEN
          EXIT /inner_loop/;
        IFEND;

        IF (key >= entry_points^ [j].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 := '  REMOVE_DUPLICATE_ENTRY_POINTS', EJECT ??

  PROCEDURE remove_duplicate_entry_points
    (VAR entry_points: ^pmt$entry_point_items;
     VAR sequence: ^SEQ ( * ));


    VAR
      i: integer,
      j: integer;


    i := 1;

    FOR j := 2 TO UPPERBOUND (entry_points^) DO
      IF (entry_points^ [i] <> entry_points^ [j]) THEN
        i := i + 1;
        IF (i <> j) THEN
          entry_points^ [i] := entry_points^ [j];
        IFEND;
      IFEND;
    FOREND;

    IF (i <> UPPERBOUND (entry_points^)) THEN
      RESET sequence TO entry_points;
      NEXT entry_points: [1 .. i] IN sequence;
    IFEND;


  PROCEND remove_duplicate_entry_points;
?? OLDTITLE ??
?? NEWTITLE := '  REMOVE_DUPLICATE_ADDRESSES', EJECT ??

  PROCEDURE remove_duplicate_addresses
    (VAR addresses: ^pmt$address_items;
     VAR sequence: ^SEQ ( * ));


    VAR
      i: integer,
      j: integer;


    i := 1;

    FOR j := 2 TO UPPERBOUND (addresses^) DO
      IF (addresses^ [i].segment_offset <> addresses^ [j].segment_offset) THEN
        i := i + 1;
        IF (i <> j) THEN
          addresses^ [i] := addresses^ [j];
        IFEND;
      ELSE
        addresses^ [i].from_an_entry_point := (addresses^ [i].from_an_entry_point OR
              addresses^ [j].from_an_entry_point);
      IFEND;
    FOREND;

    IF (i <> UPPERBOUND (addresses^)) THEN
      RESET sequence TO addresses;
      NEXT addresses: [1 .. i] IN sequence;
    IFEND;


  PROCEND remove_duplicate_addresses;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DTB_GET_DEBUG_TABLE', EJECT ??

  PROCEDURE [XDCL] ocp$dtb_get_debug_table
    (VAR debug_table: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      output_entry_points: ^pmt$entry_point_items,
      output_addresses: ^pmt$address_items,
      size: integer;

    IF entry_points <> NIL THEN
      NEXT output_entry_points: [1 .. UPPERBOUND (entry_points^)] IN module_segment.sequence_pointer;
      IF output_entry_points = NIL THEN
        osp$set_status_abnormal (oc, pme$module_segment_overflow, 'DCDT1', status);
        RETURN;
      IFEND;

      output_entry_points^ := entry_points^;
      heap_sort_entry_points (output_entry_points);

      remove_duplicate_entry_points (output_entry_points, module_segment.sequence_pointer);
      debug_table_header^.number_of_entry_points := UPPERBOUND (output_entry_points^);
      debug_table_header^.entry_point_items := #REL (output_entry_points, module_segment.sequence_pointer^);
    IFEND;


    IF addresses <> NIL THEN
      NEXT output_addresses: [1 .. UPPERBOUND (addresses^)] IN module_segment.sequence_pointer;
      IF output_addresses = NIL THEN
        osp$set_status_abnormal (oc, pme$module_segment_overflow, 'DCDT2', status);
        RETURN;
      IFEND;

      output_addresses^ := addresses^;
      heap_sort_addresses (output_addresses);

      remove_duplicate_addresses (output_addresses, module_segment.sequence_pointer);
      debug_table_header^.number_of_addresses := UPPERBOUND (output_addresses^);
      debug_table_header^.address_items := #REL (output_addresses, module_segment.sequence_pointer^);
    IFEND;


    size := i#current_sequence_position (module_segment.sequence_pointer);

    RESET module_segment.sequence_pointer;
    NEXT debug_table: [[REP size OF cell]] IN module_segment.sequence_pointer;


  PROCEND ocp$dtb_get_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] OCP$DTB_CLOSE_DEBUG_TABLE', EJECT ??

  PROCEDURE [XDCL] ocp$dtb_close_debug_table
    (VAR status: ost$status);


    amp$set_segment_eoi (module_segment_identifier, module_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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


  PROCEND ocp$dtb_close_debug_table;
?? OLDTITLE ??



MODEND pmm$debug_table_builder;
