?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE : Loader : Program segment management' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE lom$program_segment_management;

{  PURPOSE:
{    This module is responsible for managing all segments created to contain modules loaded by
{    the loader.  All procedures which need access to information regarding these segments
{    reside in this module.

{  NOTE:
{    Conditions raised: LOE$ABORT_LOAD, LOE$INSUFFICIENT_MEMORY.
?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
*copyc loe$abort_load
*copyc pme$program_services_exceptions
*copyc ost$caller_identifier
*copyc osd$code_base_pointer
*copyc ost$status
?? POP ??
*copyc mmp$create_segment
*copyc mmp$fetch_segment_attributes
*copyc mmp$store_segment_attributes
*copyc fmp$ln_open_chapter
*copyc amp$get_file_attributes
*copyc lop$augment_allocated_segments
*copyc lop$fix_binding_segment_attr
*copyc lop$defix_binding_segment_attr
*copyc mmp$preset_conversion
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc lop$report_error
*copyc lop$generate_load_map_text
*copyc lov$allocated_segments
*copyc lov$secondary_status
*copyc pmt$initialization_value
*copyc mmv$preset_conversion_table
*copyc mmv$page_map_offsets
*copyc oss$task_private
*copyc osv$page_size

  VAR
    lov$defix_segment_call_count: [STATIC, oss$task_private] 0 .. 255 := 0,
    lov$highest_segment_index: [XDCL, #GATE] lot$allocated_segments_index;

?? TITLE := '  [XDCL] lop$reserve_storage', EJECT ??

  PROCEDURE [XDCL] lop$reserve_storage (attributes: lot$segment_attributes;
        allocation_alignment: ost$segment_offset;
        allocation_offset: ost$segment_offset;
        segment_predefined: boolean;
        predefined_segment_number: ost$segment;
        shadow_pointer: ^cell;
        shadow_length: ost$segment_length;
    VAR allocation_length: ost$segment_length;
    VAR reserved_storage_address: lot$address);

{  PURPOSE:
{    This procedure is responsible for reserving storage in a segment with specified attributes.  If
{    an existing segment has the appropriate attributes, storage is reserved in it.  Otherwise a new
{    segment is created.
*copyc lov$loader_options

    VAR
      i: pmt$initialization_value,
      preset_value: pmt$initialization_value,
      destination_segment: lot$allocated_segments_index,
      segment_pointer: mmt$segment_pointer,
      alignment_pad: ost$segment_length,
      fetched_attribute: array [1 .. 1] of mmt$attribute_descriptor,
      requested_attributes: array [1 .. 7] of mmt$attribute_descriptor,
      abort_status: ^ost$status;

?? EJECT ??

  /find_destination_segment/
    BEGIN
      IF lov$allocated_segments = NIL THEN
        lop$augment_allocated_segments;
        lov$highest_segment_index := 1;
      ELSE
        IF NOT (attributes.extensible OR segment_predefined) THEN
          FOR destination_segment := 1 TO lov$highest_segment_index DO
            IF attributes = lov$allocated_segments^ [destination_segment].attributes THEN
              EXIT /find_destination_segment/
            IFEND;
          FOREND;
        IFEND;
        IF lov$highest_segment_index = UPPERBOUND (lov$allocated_segments^) THEN
          lop$augment_allocated_segments;
        IFEND;
        lov$highest_segment_index := lov$highest_segment_index + 1;
      IFEND;
      requested_attributes [1].keyword := mmc$kw_preset_value;
      requested_attributes [2].keyword := mmc$kw_segment_access_control;
      IF attributes.stack THEN
        mmp$preset_conversion (lov$loader_options.preset, preset_value);
        requested_attributes [1].preset_value := preset_value;
        requested_attributes [2].access_control := attributes.access_control;
        requested_attributes [3].keyword := mmc$kw_ring_numbers;
        requested_attributes [3].r1 := attributes.r1;
        requested_attributes [3].r2 := attributes.r2;
        requested_attributes [4].keyword := mmc$kw_software_attributes;
        requested_attributes [4].software_attri_set := $mmt$software_attribute_set [mmc$sa_stack];
      ELSEIF attributes.access_control.read_privilege = osc$binding_segment THEN
        requested_attributes [1].preset_value := pmc$initialize_to_zero;
        requested_attributes [2].access_control.cache_bypass := FALSE;
        requested_attributes [2].access_control.execute_privilege := osc$non_executable;
        requested_attributes [2].access_control.read_privilege := osc$read_uncontrolled;
        requested_attributes [2].access_control.write_privilege := osc$write_uncontrolled;
        requested_attributes [3].keyword := mmc$kw_ring_numbers;
        requested_attributes [3].r1 := attributes.r1;
        requested_attributes [3].r2 := attributes.r2;
        requested_attributes [4].keyword := mmc$kw_null_keyword;
      ELSE
        mmp$preset_conversion (lov$loader_options.preset, preset_value);
        requested_attributes [1].preset_value := preset_value;
        requested_attributes [2].access_control.cache_bypass := FALSE;
        requested_attributes [2].access_control.execute_privilege := osc$non_executable;
        requested_attributes [2].access_control.read_privilege := osc$read_uncontrolled;
        requested_attributes [2].access_control.write_privilege := osc$write_uncontrolled;
        requested_attributes [3].keyword := mmc$kw_null_keyword;
        requested_attributes [4].keyword := mmc$kw_null_keyword;
      IFEND;
      requested_attributes [5].keyword := mmc$kw_gl_key;
      requested_attributes [5].gl_key := attributes.key_lock;
      IF segment_predefined THEN
        requested_attributes [6].keyword := mmc$kw_segment_number;
        requested_attributes [6].segnum := predefined_segment_number;
      ELSE
        requested_attributes [6].keyword := mmc$kw_null_keyword;
      IFEND;
      IF (shadow_pointer <> loc$no_shadow_file) THEN
        requested_attributes [7].keyword := mmc$kw_shadow_segment;
        requested_attributes [7].shadow_p := shadow_pointer;
        requested_attributes [7].shadow_length := shadow_length;
      ELSE
        requested_attributes [7].keyword := mmc$kw_null_keyword;
      IFEND;
      mmp$create_segment (^requested_attributes, mmc$cell_pointer, loc$loader_ring, segment_pointer,
            lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_prog_seg, '', '', predefined_segment_number);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      fetched_attribute [1].keyword := mmc$kw_max_segment_length;
      mmp$fetch_segment_attributes (segment_pointer.cell_pointer, fetched_attribute, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_get_prog_seg_size, '', '', predefined_segment_number);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      lov$allocated_segments^ [lov$highest_segment_index].maximum_length := fetched_attribute [1].max_length;
      IF (attributes.access_control.read_privilege = osc$binding_segment) THEN
             lov$allocated_segments^ [lov$highest_segment_index].current_length :=
                           mmv$page_map_offsets [mmc$pmo_binding_segment] * osv$page_size;
      ELSEIF (attributes.stack) THEN
            lov$allocated_segments^ [lov$highest_segment_index].current_length :=
                (mmv$page_map_offsets [mmc$pmo_user_stack] * osv$page_size) + mmc$ring_crossing_offset;
      ELSE
        lov$allocated_segments^ [lov$highest_segment_index].current_length := 0;
      IFEND;
      lov$allocated_segments^ [lov$highest_segment_index].segment := #segment (segment_pointer.cell_pointer);
      lov$allocated_segments^ [lov$highest_segment_index].attributes := attributes;
      destination_segment := lov$highest_segment_index;
    END /find_destination_segment/;
    alignment_pad := (allocation_alignment - 1) - ((lov$allocated_segments^ [destination_segment].
          current_length + allocation_alignment - 1 - allocation_offset) MOD allocation_alignment);
    IF (lov$allocated_segments^ [destination_segment].current_length + alignment_pad + allocation_length) <=
          lov$allocated_segments^ [destination_segment].maximum_length THEN
      reserved_storage_address.ring := loc$loader_ring;
      reserved_storage_address.segment := lov$allocated_segments^ [destination_segment].segment;
      reserved_storage_address.offset := lov$allocated_segments^ [destination_segment].current_length +
            alignment_pad;
      lov$allocated_segments^ [destination_segment].current_length := lov$allocated_segments^
            [destination_segment].current_length + alignment_pad + allocation_length;
    ELSE
      IF attributes.extensible THEN
        allocation_length := lov$allocated_segments^ [destination_segment].maximum_length;
{!  The following error is reported to load map too early.
        lop$report_error (lle$extensible_truncated, '', '', 0);
      ELSE
        lop$report_error (lle$program_segment_overflow, '', '', destination_segment);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    IFEND;
  PROCEND lop$reserve_storage;
?? TITLE := '  [XDCL]] lop$open_library_as_predefined', EJECT ??

  PROCEDURE [XDCL] lop$open_library_as_predefined (name: amt$local_file_name;
        attributes: lot$segment_attributes;
        predefined_segment_number: ost$segment);


    VAR
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean,
      requested_attributes: array [1 .. 5] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer,
      abort_status: ^ost$status;


    requested_attributes [1].keyword := mmc$kw_ring_numbers;
    requested_attributes [1].r1 := attributes.r1;
    requested_attributes [1].r2 := attributes.r2;
    requested_attributes [2].keyword := mmc$kw_segment_number;
    requested_attributes [2].segnum := predefined_segment_number;
    requested_attributes [3].keyword := mmc$kw_gl_key;
    requested_attributes [3].gl_key := attributes.key_lock;
    requested_attributes [4].keyword := mmc$kw_segment_access_control;
    requested_attributes [4].access_control := attributes.access_control;
    requested_attributes [5].keyword := mmc$kw_software_attributes;
    requested_attributes [5].software_attri_set := $mmt$software_attribute_set [];

    fmp$ln_open_chapter (name, 0, loc$loader_ring, ^requested_attributes,
          mmc$cell_pointer, segment_pointer, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lop$report_error (lle$unable_to_create_prog_seg, '', '', predefined_segment_number);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;


  PROCEND lop$open_library_as_predefined;
?? TITLE := '  [XDCL] lop$fix_program_segment_attr', EJECT ??

  PROCEDURE [XDCL] lop$fix_program_segment_attr;

{  PURPOSE:
{    As program segments are created, they are given attributes appropriate for the loader's usage of
{    them.  When all modules have been loaded, this procedure changes the attributes of each segment
{    to the attributes required for the user program's usage.

    VAR
      i: lot$allocated_segments_index,
      attribute_fixer: array [1 .. 3] of mmt$attribute_descriptor,
      abort_status: ^ost$status,
{!   temporary variable until CYBIL is fixed for intrinsics in procedure call
      temporary_ptr: ^cell;

    lov$defix_segment_call_count := lov$defix_segment_call_count - 1;
    IF lov$defix_segment_call_count <> 0 THEN
      RETURN
    IFEND;

    IF lov$allocated_segments <> NIL THEN

    /fix_attributes/
      FOR i := 1 TO lov$highest_segment_index DO
        IF lov$allocated_segments^ [i].attributes.access_control.read_privilege = osc$binding_segment THEN
          lop$fix_binding_segment_attr (lov$allocated_segments^ [i].segment, lov$allocated_segments^ [i].
                current_length, lov$secondary_status);
          IF NOT lov$secondary_status.normal THEN
            lop$report_error (lle$unable_to_fix_prog_seg_attr, '', '', lov$allocated_segments^ [i].segment);
            PUSH abort_status;
            pmp$cause_condition (loe$abort_load, NIL, abort_status^);
            pmp$exit (abort_status^);
          IFEND;
        ELSE
          attribute_fixer [1].keyword := mmc$kw_segment_access_control;
          attribute_fixer [1].access_control := lov$allocated_segments^ [i].attributes.access_control;
          attribute_fixer [2].keyword := mmc$kw_max_segment_length;
          attribute_fixer [2].max_length := lov$allocated_segments^ [i].current_length;
          attribute_fixer [3].keyword := mmc$kw_ring_numbers;
          attribute_fixer [3].r1 := lov$allocated_segments^ [i].attributes.r1;
          attribute_fixer [3].r2 := lov$allocated_segments^ [i].attributes.r2;
{!        mmp$store_segment_attributes (#address (loc$loader_ring, lov$allocated_segments^ [i].segment, 0),
{!   temporary code until CYBIL is fixed - intrinsics in a procedure call
          temporary_ptr := #address (loc$loader_ring, lov$allocated_segments^ [i].segment, 0);
          mmp$store_segment_attributes (temporary_ptr,
{!   End of temporary code.
          loc$loader_ring, attribute_fixer, lov$secondary_status);
          IF NOT lov$secondary_status.normal THEN
            lop$report_error (lle$unable_to_fix_prog_seg_attr, '', '', lov$allocated_segments^ [i].segment);
            PUSH abort_status;
            pmp$cause_condition (loe$abort_load, NIL, abort_status^);
            pmp$exit (abort_status^);
          IFEND;
        IFEND;
      FOREND /fix_attributes/;
    IFEND;
  PROCEND lop$fix_program_segment_attr;
?? TITLE := '  [XDCL] lop$defix_program_segment_attr', EJECT ??

  PROCEDURE [XDCL] lop$defix_program_segment_attr;

{  PURPOSE:
{    This procedure is responsible for restoring the attributes of program segments to values
{    appropriate for the loader's usage of these segments (as opposed to the values required for
{    the program's usage of the segments).

    VAR
      i: lot$allocated_segments_index,
      attribute_defixer: array [1 .. 3] of mmt$attribute_descriptor,
      abort_status: ^ost$status,
{!   temporary variable until CYBIL is fixed for intrinsics in a procedure call
      temporary_ptr: ^cell;

    lov$defix_segment_call_count := lov$defix_segment_call_count + 1;

    IF lov$allocated_segments <> NIL THEN

    /defix_attributes/
      FOR i := 1 TO lov$highest_segment_index DO
        IF lov$allocated_segments^ [i].attributes.stack THEN
          CYCLE /defix_attributes/
        ELSEIF lov$allocated_segments^ [i].attributes.access_control.read_privilege = osc$binding_segment THEN
          lop$defix_binding_segment_attr (lov$allocated_segments^ [i].segment, lov$allocated_segments^ [i].
                maximum_length, lov$secondary_status);
          IF NOT lov$secondary_status.normal THEN
            lop$report_error (lle$unable_to_defix_seg_attr, '', '', lov$allocated_segments^ [i].segment);
            PUSH abort_status;
            pmp$cause_condition (loe$abort_load, NIL, abort_status^);
            pmp$exit (abort_status^);
          IFEND;
        ELSE
          attribute_defixer [1].keyword := mmc$kw_segment_access_control;
          attribute_defixer [1].access_control.cache_bypass := FALSE;
          IF lov$allocated_segments^ [i].attributes.debug_segment THEN
            attribute_defixer [1].access_control.execute_privilege := lov$allocated_segments^ [i].attributes.
                  access_control.execute_privilege;
            attribute_defixer [1].access_control.read_privilege := lov$allocated_segments^ [i].attributes.
                  access_control.read_privilege;
          ELSE
            attribute_defixer [1].access_control.execute_privilege := osc$non_executable;
            attribute_defixer [1].access_control.read_privilege := osc$read_uncontrolled;
          IFEND;
          attribute_defixer [1].access_control.write_privilege := osc$write_uncontrolled;
          attribute_defixer [2].keyword := mmc$kw_max_segment_length;
          attribute_defixer [2].max_length := lov$allocated_segments^ [i].maximum_length;
          attribute_defixer [3].keyword := mmc$kw_ring_numbers;
          attribute_defixer [3].r1 := loc$loader_ring;
          attribute_defixer [3].r2 := lov$allocated_segments^ [i].attributes.r2;
{!        mmp$store_segment_attributes (#address (loc$loader_ring, lov$allocated_segments^ [i].segment, 0),
{!   temporary code until CYBIL is fixed - intrinsics in a procedure call
          temporary_ptr := #address (loc$loader_ring, lov$allocated_segments^ [i].segment, 0);
          mmp$store_segment_attributes (temporary_ptr,
{!   End of temporary code.
          loc$loader_ring, attribute_defixer, lov$secondary_status);
          IF NOT lov$secondary_status.normal THEN
            lop$report_error (lle$unable_to_defix_seg_attr, '', '', lov$allocated_segments^ [i].segment);
            PUSH abort_status;
            pmp$cause_condition (loe$abort_load, NIL, abort_status^);
            pmp$exit (abort_status^);
          IFEND;
        IFEND;
      FOREND /defix_attributes/;
    IFEND;
  PROCEND lop$defix_program_segment_attr;
?? TITLE := '  [XDCL] lop$generate_segment_map', EJECT ??

  PROCEDURE [XDCL] lop$generate_segment_map;

{  PURPOSE:
{    This procedure is responsible for generating load map output identifying all segments created for
{    a program load and describing their attributes.

    VAR
      i: lot$allocated_segments_index,
      load_map_data: lot$load_map_data;

    IF lov$allocated_segments <> NIL THEN
      load_map_data.code := loc$lm_segment_header_init;
      lop$generate_load_map_text (load_map_data);
      FOR i := 1 TO lov$highest_segment_index DO
        IF NOT lov$allocated_segments^ [i].attributes.apd_binding_segment THEN
          load_map_data.code := loc$lm_segment_detail;
          load_map_data.segment := lov$allocated_segments^ [i].segment;
          load_map_data.segment_length := lov$allocated_segments^ [i].current_length;
          load_map_data.r1 := lov$allocated_segments^ [i].attributes.r1;
          load_map_data.r2 := lov$allocated_segments^ [i].attributes.r2;
          IF lov$allocated_segments^ [i].attributes.key_lock.global THEN
            load_map_data.segment_global_key_lock := lov$allocated_segments^ [i].attributes.key_lock.value;
          ELSE
            load_map_data.segment_global_key_lock := 0;
          IFEND;
          IF lov$allocated_segments^ [i].attributes.key_lock.local THEN
            load_map_data.segment_local_key_lock := lov$allocated_segments^ [i].attributes.key_lock.value;
          ELSE
            load_map_data.segment_local_key_lock := 0;
          IFEND;
          load_map_data.segment_access_attributes := lov$allocated_segments^ [i].attributes.access_control;
          load_map_data.stack_segment := lov$allocated_segments^ [i].attributes.stack;
          lop$generate_load_map_text (load_map_data);
        IFEND;
      FOREND;
    IFEND;
  PROCEND lop$generate_segment_map;

MODEND lom$program_segment_management;
