?? RIGHT := 110 ??
?? NEWTITLE := 'PMM$PROGRAM_ATTRIBUTES' ??
MODULE pmm$program_attributes;

{
{ PURPOSE:
{   This module contains the procedures for the function $program_attributes,
{   to display the program attributes.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$get_path_name
*copyc clp$make_boolean_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_record_value
*copyc clv$standard_files
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc oss$job_paged_literal
*copyc ost$status
*copyc osv$lower_to_upper
*copyc pmp$continue_to_cause
*copyc pmp$find_prog_options_and_libs
*copyc pmp$job_debug_ring
*copyc pmv$preset_conversion_table
?? POP ??

  TYPE
    pmt$attribute_names = (null, libraries, debug_libraries, load_map, load_map_options,
          termination_error_level, preset_value, maximum_stack_size, debug_ring,
          debug_input, debug_output, abort_file, debug_mode, arithmetic_overflow,
          arithmetic_loss_of_significance, divide_fault, exponent_overflow, exponent_underflow,
          fp_indefinite, fp_loss_of_significance, invalid_bdp_data);

  CONST
    max_map_option_string_size = 16, {cross reference
    max_preset_string_size = 25, {floating_point_indefinite
    max_term_error_level_str_size = 7; {warning

  VAR
    attributes_name: [STATIC, READ, oss$job_paged_literal] array [pmt$attribute_names] of ost$name :=
          [' ','LIBRARIES', 'DEBUG_LIBRARIES', 'LOAD_MAP', 'LOAD_MAP_OPTIONS', 'TERMINATION_ERROR_LEVEL',
          'PRESET_VALUE', 'MAXIMUM_STACK_SIZE', 'DEBUG_RING', 'DEBUG_INPUT', 'DEBUG_OUTPUT', 'ABORT_FILE',
          'DEBUG_MODE', 'ARITHMETIC_OVERFLOW', 'ARITHMETIC_LOSS_OF_SIGNIFICANCE', 'DIVIDE_FAULT',
          'EXPONENT_OVERFLOW', 'EXPONENT_UNDERFLOW', 'FP_INDEFINITE', 'FP_LOSS_OF_SIGNIFICANCE',
          'INVALID_BDP_DATA'],
    map_option_string: [STATIC, READ, oss$job_paged_literal] array
          [pmc$no_load_map .. pmc$entry_point_xref] of string (max_map_option_string_size) := ['none',
          'segment', 'block', 'entry_point', 'cross_reference'],
    termination_error_level_string: [STATIC, READ, oss$job_paged_literal] array
          [pmc$warning_load_errors .. pmc$fatal_load_errors] of string (max_term_error_level_str_size) :=
          ['warning', 'error', 'fatal'],
    preset_string: [STATIC, READ, oss$job_paged_literal] array [pmt$initialization_value] of
          string (max_preset_string_size) := ['zero', 'alternate_ones', 'floating_point_indefinite',
          'infinity'];

?? TITLE := '[XDCL] pmp$$program_attributes', EJECT ??

{ PURPOSE:
{  This is the command processor for $program_attributes function.
{

  PROCEDURE [XDCL] pmp$$program_attributes
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$program_attributes) $program_attributes, $program_attribute (
{   attributes: any of
{       key
{         all
{       keyend
{       list of key
{         (libraries, l)
{         (debug_libraries, dl)
{         (load_map, lm)
{         (load_map_options, lmo)
{         (termination_error_level, tel)
{         (preset_value, pv)
{         (maximum_stack_size, maxss)
{         (debug_ring, dr)
{         (debug_input, di)
{         (debug_output, do)
{         (abort_file, af)
{         (debug_mode, dm)
{         (arithmetic_overflow, ao)
{         (arithmetic_loss_of_significance, alos)
{         (devide_fault, df)
{         (exponent_overflow, eo)
{         (exponent_underflow, eu)
{         (fp_indefinite, fi)
{         (fp_loss_of_significance, flos)
{         (invalid_bdp_data, ibd)
{       keyend
{     anyend = all
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 1] of clt$pdt_parameter_name,
      parameters: array [1 .. 1] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 40] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [95, 4, 17, 23, 57, 51, 985],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$PROGRAM_ATTRIBUTES'], [
    ['ATTRIBUTES                     ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1567,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    1503, [[1, 0, clc$list_type], [1487, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [40], [
        ['ABORT_FILE                     ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['AF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['ALOS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['ARITHMETIC_LOSS_OF_SIGNIFICANCE', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['ARITHMETIC_OVERFLOW            ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['DEBUG_INPUT                    ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['DEBUG_LIBRARIES                ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['DEBUG_MODE                     ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['DEBUG_OUTPUT                   ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['DEBUG_RING                     ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['DEVIDE_FAULT                   ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['DF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['DI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['DL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['DM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['DO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['DR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['EO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['EU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['EXPONENT_OVERFLOW              ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['EXPONENT_UNDERFLOW             ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['FI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['FLOS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['FP_INDEFINITE                  ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['FP_LOSS_OF_SIGNIFICANCE        ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['IBD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['INVALID_BDP_DATA               ', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['LIBRARIES                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['LM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['LMO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['LOAD_MAP                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['LOAD_MAP_OPTIONS               ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['MAXIMUM_STACK_SIZE             ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['MAXSS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['PRESET_VALUE                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['PV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['TEL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['TERMINATION_ERROR_LEVEL        ', clc$nominal_entry, clc$normal_usage_entry, 5]]
        ]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attributes = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      all_specified: boolean,
      attribute_array: array [1 .. 5] of ost$name,
      attribute_index: integer,
      attribute_value: pmt$attribute_names,
      current_node: ^^clt$data_value,
      debug_library_list: ^pmt$object_library_list,
      default_program_options: pmt$program_options,
      file_reference: fst$path,
      initialization_value: pmt$initialization_value,
      job_library_list: ^pmt$object_library_list,
      list_of_attributes: ^clt$data_value,
      loop_index: pmt$number_of_libraries,
      map_option: pmc$no_load_map .. pmc$entry_point_xref,
      map_option_found: boolean,
      number_of_libraries: pmt$number_of_libraries,
      number_of_record_fields: clt$list_size,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      translated_string: string (osc$max_name_size);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This abort handler processes segment_access, block exit and system
{   conditions.
{
{   A block exit (or segment access) condition can occur when a NIL pointer
{   is returned by NEXTing the work_area. This is then assumed to be a
{   work_area overflow.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status_p: ^ost$status;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$block_exit_processing =
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'PMP$$PROGRAM_ATTRIBUTES', status);
        EXIT pmp$$program_attributes;

      = pmc$system_conditions =
        IF status.normal THEN
          PUSH local_status_p;
          osp$set_status_from_condition ('PM', condition, save_area, status, local_status_p^);
        IFEND;
        EXIT pmp$$program_attributes;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND abort_handler;

    all_specified := FALSE;
    list_of_attributes := NIL;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, TRUE {= block exit} );

    IF pvt [p$attributes].value^.kind = clc$keyword {ALL} THEN
      all_specified := TRUE;
      number_of_record_fields := $integer (uppervalue (pmt$attribute_names));
    ELSE
      list_of_attributes := pvt [p$attributes].value;
      number_of_record_fields := clp$count_list_elements (list_of_attributes);
    IFEND;

    pmp$find_prog_options_and_libs (prog_options_and_libraries);
    job_library_list := prog_options_and_libraries^.job_library_list;
    debug_library_list := prog_options_and_libraries^.debug_library_list;
    default_program_options := prog_options_and_libraries^.default_options^;

    clp$make_record_value (number_of_record_fields, work_area, result);

    attribute_index := 1;
    attribute_value := NULL;
    WHILE (attribute_index <= number_of_record_fields) DO

      IF all_specified THEN
        attribute_value := succ(attribute_value);
      ELSE

      /for_loop/
        FOR attribute_value := succ (lowervalue (pmt$attribute_names))
              TO uppervalue (pmt$attribute_names) DO
          IF list_of_attributes^.element_value^.keyword_value = attributes_name [attribute_value] THEN
            EXIT /for_loop/;
          IFEND;
        FOREND /for_loop/;
        list_of_attributes := list_of_attributes^.link;
      IFEND;

      result^.field_values^ [attribute_index].name := attributes_name [attribute_value];

      CASE attribute_value OF

      = libraries =
        IF job_library_list = NIL THEN
          clp$make_keyword_value ('NONE', work_area, result^.field_values^ [attribute_index].value);
        ELSE
          current_node := ^result^.field_values^ [attribute_index].value;
          number_of_libraries := UPPERBOUND (job_library_list^);
          FOR loop_index := 1 TO number_of_libraries DO
            clp$make_list_value (work_area, current_node^);
            IF job_library_list^ [loop_index] = 'OSF$TASK_SERVICES_LIBRARY' THEN
              clp$make_file_value ('osf$task_services_library', work_area, current_node^^.element_value);
            ELSE
              clp$get_path_name (job_library_list^ [loop_index], osc$full_message_level, file_reference);
              clp$make_file_value (file_reference, work_area, current_node^^.element_value);
            IFEND;
            current_node := ^current_node^^.link;
          FOREND;
        IFEND;

      = debug_libraries =
        IF debug_library_list = NIL THEN
          clp$make_keyword_value ('NONE', work_area, result^.field_values^ [attribute_index].value);
        ELSE
          current_node := ^result^.field_values^ [attribute_index].value;
          number_of_libraries := UPPERBOUND (debug_library_list^);
          FOR loop_index := 1 TO number_of_libraries DO
            clp$make_list_value (work_area, current_node^);
            clp$get_path_name (debug_library_list^ [loop_index], osc$full_message_level, file_reference);
            clp$make_file_value (file_reference, work_area, current_node^^.element_value);
            current_node := ^current_node^^.link;
          FOREND;
        IFEND;

      = load_map =
        clp$get_path_name (default_program_options.map_file, osc$full_message_level, file_reference);
        clp$make_file_value (file_reference, work_area, result^.field_values^ [attribute_index].value);

      = load_map_options =
        current_node := ^result^.field_values^ [attribute_index].value;
        map_option_found := FALSE;
        FOR map_option := pmc$no_load_map TO pmc$entry_point_xref DO
          IF map_option IN default_program_options.map_options THEN
            map_option_found := TRUE;
            clp$make_list_value (work_area, current_node^);
            clp$make_keyword_value (map_option_string [map_option], work_area, current_node^^.element_value);
            current_node := ^current_node^^.link;
          IFEND;
        FOREND;
        IF NOT map_option_found THEN
          clp$make_keyword_value ('NONE', work_area, result^.field_values^ [attribute_index].value);
        IFEND;

      = termination_error_level =
        #TRANSLATE (osv$lower_to_upper, termination_error_level_string
              [default_program_options.termination_error_level], translated_string);
        clp$make_keyword_value (translated_string, work_area, result^.field_values^ [attribute_index].value);

      = preset_value =
        FOR initialization_value := pmc$initialize_to_zero TO pmc$initialize_to_infinity DO
          IF default_program_options.preset = pmv$preset_conversion_table [initialization_value] THEN
            #TRANSLATE (osv$lower_to_upper, preset_string [initialization_value], translated_string);
            clp$make_keyword_value (translated_string, work_area,
                  result^.field_values^ [attribute_index].value);
          IFEND;
        FOREND;

      = maximum_stack_size =
        clp$make_integer_value (default_program_options.maximum_stack_size, 10, FALSE, work_area,
              result^.field_values^ [attribute_index].value);

      = debug_ring =
        clp$make_integer_value (pmp$job_debug_ring (), 10, FALSE, work_area, result^.
              field_values^ [attribute_index].value);

      = debug_input =
        IF default_program_options.debug_input = clv$standard_files [clc$sf_command_file].
              path_handle_name THEN
          file_reference := ':$LOCAL.COMMAND.1';
        ELSE
          clp$get_path_name (default_program_options.debug_input, osc$full_message_level, file_reference);
        IFEND;
        clp$make_file_value (file_reference, work_area, result^.field_values^ [attribute_index].value);

      = debug_output =
        clp$get_path_name (default_program_options.debug_output, osc$full_message_level, file_reference);
        clp$make_file_value (file_reference, work_area, result^.field_values^ [attribute_index].value);

      = abort_file =
        clp$get_path_name (default_program_options.abort_file, osc$full_message_level, file_reference);
        clp$make_file_value (file_reference, work_area, result^.field_values^ [attribute_index].value);

      = debug_mode =
        clp$make_boolean_value (default_program_options.debug_mode, clc$on_off_boolean, work_area,
              result^.field_values^ [attribute_index].value);

      = arithmetic_overflow =
        clp$make_boolean_value (pmc$arithmetic_overflow IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = arithmetic_loss_of_significance =
        clp$make_boolean_value (pmc$arithmetic_significance IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = divide_fault =
        clp$make_boolean_value (pmc$divide_fault IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = exponent_overflow =
        clp$make_boolean_value (pmc$exponent_overflow IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = exponent_underflow =
        clp$make_boolean_value (pmc$exponent_underflow IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = fp_indefinite =
        clp$make_boolean_value (pmc$fp_indefinite IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = fp_loss_of_significance =
        clp$make_boolean_value (pmc$fp_significance_loss IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);

      = invalid_bdp_data =
        clp$make_boolean_value (pmc$invalid_bdp_data IN default_program_options.conditions_enabled,
              clc$on_off_boolean, work_area, result^.field_values^ [attribute_index].value);
      ELSE
        ;
      CASEND;

      attribute_index := attribute_index + 1;
    WHILEND;

    osp$disestablish_cond_handler;

  PROCEND pmp$$program_attributes;

MODEND pmm$program_attributes;

