?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Program load lieutenants' ??
MODULE lom$program_load_lieutenants;

{  PURPOSE:
{    This module contains procedures which are first_level subordinates in the program load process.

{  NOTE:
{    Condition raised: LOE$LOADER_MALFUNCTION.

  ?VAR
    inline_procs: boolean := TRUE?;

?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lle$loader_status_conditions
*copyc loe$abort_load
*copyc lot$loader_type_definitions
*copyc lot$loader_options
*copyc osd$code_base_pointer
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$status_severity
?? POP ??
*copyc amp$close
*copyc mmp$delete_segment

{!  Temporary for compatibility with HCS tasking.

*copyc pmp$record_task_name
*copyc osp$generate_message
*copyc sfp$emit_statistic
*copyc pmc$min_scc_program_execution

{!  End temporary.

*copyc lop$add_program_load_libraries
*copyc lop$add_unsatisfied_ref_to_list
*copyc lop$build_file_descriptor
*copyc lop$check_for_target_text
*copyc lop$find_library_descriptor
*copyc lop$find_matching_entry_point
*copyc lop$generate_cross_refernce_map
*copyc lop$generate_load_map_text
*copyc lop$generate_segment_map
*copyc lop$list_referencing_module
*copyc lop$load_library_file
*copyc lop$load_module
*copyc lop$open_library
*copyc lop$release_unsat_ref_segment
*copyc lop$report_error
*copyc lop$reserve_storage
*copyc lop$store_linkage
*copyc osp$executing_in_job_monitor
*copyc osp$set_status_abnormal
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc pmp$find_executing_task_tcb
*copyc lov$loi$nil
*copyc lov$apd_load
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    lov$diagnostic_count: [XREF] array [ost$status_severity] of 0 .. 0ffff(16),
    stub_entry_definition: [READ, oss$job_paged_literal] lot$entry_definition :=
          [NIL, [FALSE, * , * , osc$max_ring, osc$cyber_180_mode, [osc$invalid_ring, 0, 0],
          [osc$invalid_ring, 0, 0], FALSE, * , FALSE, * , * , * , * , * , * ], * , * , FALSE];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$determine_initial_ring', EJECT ??

  PROCEDURE [XDCL] lop$determine_initial_ring
    (    object_file_list: ^pmt$object_file_list;
         execute_library_list: ^pmt$object_library_list;
         target_ring: pmt$loadable_ring;
     VAR initial_ring: pmt$loadable_ring;
     VAR starting_procedure_ring: pmt$loadable_ring;
     VAR file_descriptors: ^array [1 .. * ] of lot$file_descriptor);

{  PURPOSE:
{    This procedure is responsible for determining an initial_ring and a starting_procedure_ring
{    for a program load.  The initial_ring is a prophecy (self_fulfilling to a large degree) of the
{    ring in which the program will commence execution.  Modules from load files (object files and
{    library files) whose execution bracket includes initial_ring will be loaded in initial_ring.
{    Modules from other load files will be loaded in the ring at the top of their execute bracket and
{    be given their execute bracket.  Starting_procedure_ring is the ring from which the reference
{    to starting_procedure is presumed to emanate, in the event that the program transfer address
{    is specified via the starting_procedure mechanism.

    VAR
      number_of_object_files: pmt$number_of_object_files,
      number_of_execute_libraries: pmt$number_of_libraries,
      number_of_load_files: integer,
      file_loadable: boolean,
      i: integer,
      minimum_ring: pmt$loadable_ring,
      maximum_ring: pmt$loadable_ring,
      library_found: boolean,
      library_valid: boolean,
      file_descriptor: lot$file_descriptor,
      library_descriptor: ^lot$library_descriptor,
      load_file_execute_bracket: ^array [1 .. * ] of pmt$loadable_ring,
      caller_id: ost$caller_identifier,
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

?? EJECT ??

{ If the caller specified a ring number on a TASK statement then use that ring as initial ring

    IF object_file_list = NIL THEN
      number_of_object_files := 0;
    ELSE
      number_of_object_files := UPPERBOUND (object_file_list^);
    IFEND;
    IF execute_library_list = NIL THEN
      number_of_execute_libraries := 0;
    ELSE
      number_of_execute_libraries := UPPERBOUND (execute_library_list^);
    IFEND;

    minimum_ring := LOWERVALUE (pmt$loadable_ring);
    maximum_ring := UPPERVALUE (pmt$loadable_ring);

    IF number_of_object_files <> 0 THEN
      number_of_load_files := number_of_object_files;
      PUSH load_file_execute_bracket: [1 .. number_of_object_files];
      FOR i := 1 TO number_of_object_files DO
        lop$build_file_descriptor (object_file_list^ [i], file_loadable, file_descriptors^ [i]);
        IF file_loadable THEN
          load_file_execute_bracket^ [i] := file_descriptors^ [i].ring_brackets.r1;
        ELSE
          load_file_execute_bracket^ [i] := LOWERVALUE (pmt$loadable_ring);
        IFEND;
      FOREND;

    ELSEIF number_of_execute_libraries <> 0 THEN
      number_of_load_files := number_of_execute_libraries;
      PUSH load_file_execute_bracket: [1 .. number_of_execute_libraries];
      FOR i := 1 TO number_of_execute_libraries DO
        lop$find_library_descriptor (execute_library_list^ [i], library_descriptor, library_found);
        IF library_found THEN
          library_valid := TRUE;
          IF NOT library_descriptor^.library_open THEN
            lop$open_library (execute_library_list^ [i], file_descriptor, library_valid);
            IF library_valid THEN
              library_descriptor^.segment := file_descriptor.segment;
              library_descriptor^.ring_brackets := file_descriptor.ring_brackets;
              library_descriptor^.attributes := file_descriptor.attributes;
              library_descriptor^.library_open := TRUE;
              library_descriptor^.text_embedded_library := FALSE;
            IFEND;
          IFEND;

          IF library_valid THEN
            load_file_execute_bracket^ [i] := library_descriptor^.ring_brackets.r1;
          ELSE
            load_file_execute_bracket^ [i] := LOWERVALUE (pmt$loadable_ring);
          IFEND;
        IFEND;
      FOREND;

    ELSE
      number_of_load_files := 0;
    IFEND;

{  Use target_ring if set with TASK R=n statement.

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.cl_task THEN
      initial_ring := target_ring;
      starting_procedure_ring := target_ring;
      RETURN;
    IFEND;

    IF number_of_load_files <> 0 THEN

{     Set minimum_ring to MAX(execute_bracket)

      FOR i := 1 TO number_of_load_files DO
        IF load_file_execute_bracket^ [i] > minimum_ring THEN
          minimum_ring := load_file_execute_bracket^ [i];
        IFEND;
      FOREND;

    IFEND;

{   Select initial_ring from larger of (minimum_ring, target_ring).

    IF target_ring < minimum_ring THEN
      initial_ring := minimum_ring;
      starting_procedure_ring := minimum_ring;
    ELSE
      starting_procedure_ring := target_ring;
      initial_ring := target_ring;
    IFEND;
  PROCEND lop$determine_initial_ring;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_object_files', EJECT ??

  PROCEDURE [XDCL] lop$load_object_files
    (    file_descriptors: ^array [1 .. * ] of lot$file_descriptor;
         initial_ring: ost$ring;
         control_options {control} : lot$control_options;
     VAR transfer_descriptor: lot$external_descriptor);

{  PURPOSE:
{    This procedure initiates the loading of every module on every file in the object_file_list.  It
{    determines the ring into which each module will be loaded and obtains file attributes which
{    will be inherited by the loaded module.

    VAR
      module_structure_error: boolean,
      file_loadable: boolean,
      i: pmt$number_of_object_files,
      record_descriptor: ^llt$object_text_descriptor,
      module_ring_attributes: lot$module_ring_attributes,
      retain_object_file: boolean,
      debug_symbol_table_present: boolean,
      status: ost$status,
      abort_status: ^ost$status;

  /load_a_file/
    FOR i := LOWERBOUND (file_descriptors^) TO UPPERBOUND (file_descriptors^) DO
      IF NOT file_descriptors^ [i].file_open THEN
        CYCLE /load_a_file/
      IFEND;
      IF initial_ring >= file_descriptors^ [i].ring_brackets.r2 THEN
        module_ring_attributes.loaded_ring := file_descriptors^ [i].ring_brackets.r2;
        module_ring_attributes.call_bracket := file_descriptors^ [i].ring_brackets.r3
      ELSE
        module_ring_attributes.loaded_ring := initial_ring;
        module_ring_attributes.call_bracket := initial_ring;
      IFEND;
      IF lov$apd_flags.apd_load THEN
        lop$check_for_target_text (file_descriptors^ [i].attributes.name);
      IFEND;
      IF file_descriptors^ [i].attributes.library_file THEN
        lop$load_library_file (file_descriptors^ [i], module_ring_attributes, control_options,
              transfer_descriptor);
      ELSE
        NEXT record_descriptor IN file_descriptors^ [i].segment;
        retain_object_file := FALSE;
        WHILE record_descriptor <> NIL DO
          RESET file_descriptors^ [i].segment TO record_descriptor;
          lop$load_module (module_ring_attributes, file_descriptors^ [i].attributes, control_options,
                file_descriptors^ [i].segment, transfer_descriptor, debug_symbol_table_present,
                module_structure_error);
          IF module_structure_error THEN
            amp$close (file_descriptors^ [i].file_identifier, status);
            IF NOT status.normal THEN
              PUSH abort_status;
              pmp$cause_condition (loe$loader_malfunction, ^status, abort_status^);
              pmp$exit (abort_status^);
            IFEND;
            CYCLE /load_a_file/
          IFEND;
          NEXT record_descriptor IN file_descriptors^ [i].segment;
        WHILEND;
      IFEND;
    FOREND /load_a_file/;
    IF lov$apd_flags.apd_load THEN
      lop$check_for_target_text (osc$null_name);
    IFEND;
  PROCEND lop$load_object_files;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] emit_starting_proc_statistic', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] emit_starting_proc_statistic
      (    starting_procedure: pmt$program_name);

  ?ELSE

    PROCEDURE emit_starting_proc_statistic
      (    starting_procedure: pmt$program_name);

  ?IFEND

  VAR
    local_status: ost$status;

  IF NOT osp$executing_in_job_monitor () THEN
    sfp$emit_statistic (pml$starting_procedure_name, starting_procedure, NIL, local_status);

    IF NOT local_status.normal THEN
      osp$generate_message (local_status, local_status);
    IFEND;
  IFEND;


PROCEND emit_starting_proc_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$establish_transfer_symbol', EJECT ??

PROCEDURE [XDCL] lop$establish_transfer_symbol
  (    starting_procedure: pmt$program_name;
       starting_procedure_ring: ost$ring;
   VAR transfer_descriptor {input_output} : lot$external_descriptor;
   VAR reference_descriptor: lot$reference_descriptor;
   VAR user_program_cbp: ^ost$external_code_base_pointer);

{  PURPOSE:
{    This procedure determines the transfer symbol for program loads and causes generation of a
{    code base pointer to be used in making the initial transfer to the user program.

*copyc lov$binding_segment_attributes

  VAR
    reservation_size: ost$segment_length,
    transfer_symbol_defined: boolean,
    linkage_info: ^lot$linkage_name_lists,
    transfer_symbol_definition: ^lot$entry_definition,
    binding_section_overwrite: boolean,
    declaration_mismatch: boolean,
    transfer_symbol_unaligned: boolean,
    malfunction_status: ^ost$status,
    abort_status: ^ost$status;

?? EJECT ??
  IF starting_procedure <> osc$null_name THEN
    transfer_descriptor.name := starting_procedure;
    transfer_descriptor.global_key := loc$master_key;
  IFEND;
  transfer_descriptor.reference_ring := starting_procedure_ring;

{!  Temporary for compatability with HCS tasking.

  pmp$record_task_name (transfer_descriptor.name, FALSE);
  emit_starting_proc_statistic (transfer_descriptor.name);
  IF transfer_descriptor.name <> osc$null_name THEN
    lop$find_matching_entry_point (transfer_descriptor, transfer_symbol_defined, linkage_info,
          transfer_symbol_definition);

{ Reserve space for an external code base pointer in the binding segment.

    reservation_size := #SIZE (ost$external_code_base_pointer);
    lop$reserve_storage (binding_segment_attributes, 8, 0, FALSE, 0, loc$no_shadow_file, 0, reservation_size,
          reference_descriptor.details.address);
    user_program_cbp := #ADDRESS (loc$loader_ring, reference_descriptor.details.address.segment,
          reference_descriptor.details.address.offset);
    reference_descriptor.details.kind := llc$external_proc;
    reference_descriptor.details.binding_section_destination := TRUE;
    reference_descriptor.details.declaration_matching_required := FALSE;
    reference_descriptor.mmodule := '** STARTING PROCEDURE **';
    reference_descriptor.details.in_target_text := FALSE;
    IF transfer_symbol_defined THEN
      lop$store_linkage (^reference_descriptor.details, transfer_symbol_definition, binding_section_overwrite,
            declaration_mismatch, transfer_symbol_unaligned);
      IF binding_section_overwrite OR declaration_mismatch THEN
        PUSH malfunction_status;
        osp$set_status_abnormal ('LL', lle$loader_malfunctioned,
              'binding section overwrite - STARTING PROCEDURE', malfunction_status^);
        PUSH abort_status;
        pmp$cause_condition (loe$loader_malfunction, malfunction_status, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      IF transfer_symbol_unaligned THEN
        lop$report_error (lle$transfer_symbol_unaligned, transfer_descriptor.name,
              reference_descriptor.mmodule, 0);
      IFEND;
    ELSE
      reference_descriptor.ring := transfer_descriptor.reference_ring;
      reference_descriptor.global_key := transfer_descriptor.global_key;
      lop$add_unsatisfied_ref_to_list (reference_descriptor, linkage_info);
    IFEND;
  IFEND;
PROCEND lop$establish_transfer_symbol;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$release_transient_segments', EJECT ??

PROCEDURE [XDCL] lop$release_transient_segments
  (    control_options {control} : lot$control_options);

{  PURPOSE:
{    This procedure releases segments which contain transient data used during the program load
{    process.  When the program load is complete these segments should be empty.  If any data remains
{    in these segments, this procedure reports appropriate errors before releasing the segments.
{  NOTE:
{    This procedure utilizes an external procedure (which understands the data structure used to store
{    unsatisfied references) to locate all unsatisfied references.  The external procedure is passed
{    a pointer to an internal procedure which is called to process individual unsatisfied references
{    as they are located by the external procedure.

?? NEWTITLE := '[INLINE] report_unsatisfied_externals', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] report_unsatisfied_externals;

  ?ELSE

    PROCEDURE report_unsatisfied_externals;

  ?IFEND

{  PURPOSE:
{    This procedure reports (in the load map) an external name which has not been resolved and
{    itemizes all modules which made reference to the name.  It also 'satisfies' references to
{    the name by building a linkage which will cause a ring_zero interrupt when the linkage
{    is accessed.

  VAR
    current_reference: ^lot$unsatisfied_reference_list,
    reference_group: ^lot$unsatisfied_reference_group,
    unsatisfied_reference: ^lot$unsatisfied_reference,
    load_map_data: lot$load_map_data,
    ignored: boolean;

  current_reference := lov$head_of_unsat_ref_list^.f_link;
  WHILE current_reference <> lov$head_of_unsat_ref_list DO
    lop$report_error (lle$unsatisfied_external, current_reference^.linkage_info^.name, '', 0);
    reference_group := current_reference^.references;
    load_map_data.code := loc$lm_accumulate_names;

  /itemize_referencing_modules/
    WHILE reference_group <> NIL DO
      unsatisfied_reference := reference_group^.list;
      WHILE unsatisfied_reference <> NIL DO
        lop$list_referencing_module (unsatisfied_reference^.mmodule);
        IF control_options.map <> $pmt$load_map_options [pmc$no_load_map] THEN
          load_map_data.name := unsatisfied_reference^.mmodule;
          lop$generate_load_map_text (load_map_data);
        IFEND;
        lop$store_linkage (^unsatisfied_reference^.details, ^stub_entry_definition, ignored, ignored,
              ignored);
        unsatisfied_reference := unsatisfied_reference^.nnext;
      WHILEND;
      reference_group := reference_group^.nnext;
    WHILEND /itemize_referencing_modules/;
    IF control_options.map <> $pmt$load_map_options [pmc$no_load_map] THEN
      load_map_data.code := loc$lm_flush_accumulated_names;
      lop$generate_load_map_text (load_map_data);
    IFEND;
    current_reference^.linkage_info^.unsat_references_list := NIL;
    current_reference := current_reference^.f_link;
  WHILEND;
PROCEND report_unsatisfied_externals;
?? OLDTITLE, EJECT ??

*copyc lov$head_of_unsat_ref_list

VAR
  abort_status: ^ost$status,
  malfunction_status: ^ost$status,
  release_transient_segment_calls: [STATIC, oss$task_private] 0 .. 255 := 0;

IF release_transient_segment_calls = 255 THEN
  PUSH malfunction_status;
  osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'Too many calls to lop$release_transient_segments',
        malfunction_status^);
  PUSH abort_status;
  pmp$cause_condition (loe$loader_malfunction, malfunction_status, abort_status^);
  pmp$exit (abort_status^);
ELSE
  release_transient_segment_calls := release_transient_segment_calls + 1;
IFEND;

IF release_transient_segment_calls = 1 THEN
  IF lov$head_of_unsat_ref_list <> NIL THEN
    report_unsatisfied_externals;
  IFEND;

  lop$release_unsat_ref_segment;
IFEND;

release_transient_segment_calls := release_transient_segment_calls - 1;

PROCEND lop$release_transient_segments;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$finish_load_map', EJECT ??

PROCEDURE [XDCL] lop$finish_load_map
  (    load_map_options: pmt$load_map_options;
       transfer_descriptor: lot$external_descriptor;
       normal_termination {control} : boolean);

{  PURPOSE:
{    This procedure controls the generation of those parts of the load map which can be done
{    only after all program modules have been loaded.

  VAR
    transfer_symbol_defined: boolean,
    pseudo_linkage_info: ^lot$linkage_name_lists,
    transfer_symbol_definition: ^lot$entry_definition,
    load_map_data: lot$load_map_data;

  IF normal_termination THEN
    IF pmc$entry_point_xref IN load_map_options THEN
      lop$generate_cross_refernce_map;
    IFEND;
    IF pmc$segment_map IN load_map_options THEN
      lop$generate_segment_map;
    IFEND;
    IF transfer_descriptor.name = osc$null_name THEN
      lop$report_error (lle$transfer_symbol_missing, '', '', 0);
    ELSE
      lop$find_matching_entry_point (transfer_descriptor, transfer_symbol_defined, pseudo_linkage_info,
            transfer_symbol_definition);
      IF (load_map_options - $pmt$load_map_options [pmc$no_load_map]) <> $pmt$load_map_options [] THEN
        load_map_data.code := loc$lm_transfer_detail;
        load_map_data.transfer_symbol := transfer_descriptor.name;
        IF transfer_symbol_defined THEN
          load_map_data.transfer_address := transfer_symbol_definition^.attributes.address;
        ELSE
          load_map_data.transfer_address := loc$nil;
        IFEND;
        lop$generate_load_map_text (load_map_data);
      IFEND;
      IF transfer_symbol_defined THEN
        IF (transfer_symbol_definition^.attributes.address.offset MOD 8) <> 0 THEN
          lop$report_error (lle$transfer_symbol_unaligned, '', '', 0);
        IFEND;
      ELSE
        lop$report_error (lle$transfer_symbol_undefined, transfer_descriptor.name, '', 0);
      IFEND;
    IFEND;
  IFEND;
  IF load_map_options <> $pmt$load_map_options [pmc$no_load_map] THEN
    load_map_data.code := loc$lm_diagnostic_summary;
    load_map_data.diagnostic_count := lov$diagnostic_count;
    lop$generate_load_map_text (load_map_data);
  IFEND;
PROCEND lop$finish_load_map;
?? OLDTITLE ??
MODEND lom$program_load_lieutenants;
